path: root/src/LivingVillage.Kernel/WorldSave.fs

namespace LivingVillage.Kernel

open System
open System.Globalization
open System.IO
open System.Text
open LivingVillage.Kernel.Sim

module WorldSave =

    let private invariant = CultureInfo.InvariantCulture
    let private formatVersion = "LV_WORLD_SAVE_V1"

    exception private SaveParseError of string

    type private TokenReader(tokens: string[]) =
        let mutable index = 0

        member _.Take(label: string) =
            if index >= tokens.Length then
                raise (SaveParseError(sprintf "missing %s" label))
            let value = tokens.[index]
            index <- index + 1
            value

        member _.Remaining = tokens.Length - index

    let private invalid message = raise (SaveParseError message)

    let private add (tokens: ResizeArray<string>) (value: string) = tokens.Add(value)

    let private addInt (tokens: ResizeArray<string>) (value: int) =
        add tokens (value.ToString(invariant))

    let private addInt64 (tokens: ResizeArray<string>) (value: int64) =
        add tokens (value.ToString(invariant))

    let private addUInt64 (tokens: ResizeArray<string>) (value: uint64) =
        add tokens (value.ToString(invariant))

    let private addFloat (tokens: ResizeArray<string>) (value: float) =
        add tokens (value.ToString("R", invariant))

    let private addFloat32 (tokens: ResizeArray<string>) (value: float32) =
        add tokens (value.ToString("R", invariant))

    let private addBool (tokens: ResizeArray<string>) (value: bool) =
        add tokens (if value then "1" else "0")

    let private addText (tokens: ResizeArray<string>) (value: string) =
        let safeValue = if isNull value then "" else value
        add tokens (Convert.ToBase64String(Encoding.UTF8.GetBytes(safeValue)))

    let private readInt (reader: TokenReader) label =
        let token = reader.Take(label)
        match Int32.TryParse(token, NumberStyles.Integer, invariant) with
        | true, value -> value
        | _ -> invalid (sprintf "invalid %s" label)

    let private readInt64 (reader: TokenReader) label =
        let token = reader.Take(label)
        match Int64.TryParse(token, NumberStyles.Integer, invariant) with
        | true, value -> value
        | _ -> invalid (sprintf "invalid %s" label)

    let private readUInt64 (reader: TokenReader) label =
        let token = reader.Take(label)
        match UInt64.TryParse(token, NumberStyles.Integer, invariant) with
        | true, value -> value
        | _ -> invalid (sprintf "invalid %s" label)

    let private readFloat (reader: TokenReader) label =
        let token = reader.Take(label)
        match Double.TryParse(token, NumberStyles.Float, invariant) with
        | true, value when not (Double.IsNaN(value) || Double.IsInfinity(value)) -> value
        | _ -> invalid (sprintf "invalid %s" label)

    let private readFloat32 (reader: TokenReader) label =
        let token = reader.Take(label)
        match Single.TryParse(token, NumberStyles.Float, invariant) with
        | true, value when not (Single.IsNaN(value) || Single.IsInfinity(value)) -> value
        | _ -> invalid (sprintf "invalid %s" label)

    let private readBool (reader: TokenReader) label =
        match reader.Take(label) with
        | "0" -> false
        | "1" -> true
        | _ -> invalid (sprintf "invalid %s" label)

    let private readText (reader: TokenReader) label =
        let token = reader.Take(label)
        try
            Encoding.UTF8.GetString(Convert.FromBase64String(token))
        with
        | :? FormatException -> invalid (sprintf "invalid %s" label)

    let private readCount (reader: TokenReader) label =
        let count = readInt reader label
        if count < 0 || count > 1000000 then
            invalid (sprintf "invalid %s count" label)
        count

    let private writeNpcId tokens (NpcId id) = addInt tokens id

    let private readNpcId (reader: TokenReader) label =
        NpcId(readInt reader label)

    let private writeRumorId tokens (RumorId id) = addInt64 tokens id

    let private readRumorId (reader: TokenReader) label =
        RumorId(readInt64 reader label)

    let private writeItemKind tokens item =
        match item with
        | Food -> add tokens "food"

    let private readItemKind (reader: TokenReader) label =
        match reader.Take(label) with
        | "food" -> Food
        | _ -> invalid (sprintf "invalid %s" label)

    let private writeActionKind tokens action =
        match action with
        | Eat -> add tokens "eat"
        | Sleep -> add tokens "sleep"
        | Wander -> add tokens "wander"
        | Work -> add tokens "work"
        | Chat -> add tokens "chat"

    let private readActionKind (reader: TokenReader) label =
        match reader.Take(label) with
        | "eat" -> Eat
        | "sleep" -> Sleep
        | "wander" -> Wander
        | "work" -> Work
        | "chat" -> Chat
        | _ -> invalid (sprintf "invalid %s" label)

    let private writeIntent tokens intent =
        match intent with
        | SmallTalk -> add tokens "small-talk"
        | AskHelp -> add tokens "ask-help"
        | OfferTrade -> add tokens "offer-trade"
        | Joke -> add tokens "joke"
        | Apologize -> add tokens "apologize"
        | Provoke -> add tokens "provoke"

    let private readIntent (reader: TokenReader) label =
        match reader.Take(label) with
        | "small-talk" -> SmallTalk
        | "ask-help" -> AskHelp
        | "offer-trade" -> OfferTrade
        | "joke" -> Joke
        | "apologize" -> Apologize
        | "provoke" -> Provoke
        | _ -> invalid (sprintf "invalid %s" label)

    let private writeResponse tokens response =
        match response with
        | Friendly -> add tokens "friendly"
        | Helpful -> add tokens "helpful"
        | Bargaining -> add tokens "bargaining"
        | Amused -> add tokens "amused"
        | Forgiving -> add tokens "forgiving"
        | Hostile -> add tokens "hostile"
        | Reserved -> add tokens "reserved"
        | Refused -> add tokens "refused"
        | Offended -> add tokens "offended"

    let private readResponse (reader: TokenReader) label =
        match reader.Take(label) with
        | "friendly" -> Friendly
        | "helpful" -> Helpful
        | "bargaining" -> Bargaining
        | "amused" -> Amused
        | "forgiving" -> Forgiving
        | "hostile" -> Hostile
        | "reserved" -> Reserved
        | "refused" -> Refused
        | "offended" -> Offended
        | _ -> invalid (sprintf "invalid %s" label)

    let private writeVec2 tokens (value: Vec2) =
        addFloat32 tokens value.X
        addFloat32 tokens value.Y

    let private readVec2 reader label =
        { X = readFloat32 reader (label + ".x")
          Y = readFloat32 reader (label + ".y") }

    let private writeNeeds tokens (value: Needs) =
        addFloat32 tokens value.Hunger
        addFloat32 tokens value.Energy
        addFloat32 tokens value.Social
        addFloat32 tokens value.Money

    let private readNeeds reader label =
        { Hunger = readFloat32 reader (label + ".hunger")
          Energy = readFloat32 reader (label + ".energy")
          Social = readFloat32 reader (label + ".social")
          Money = readFloat32 reader (label + ".money") }

    let private writePersonality tokens (value: Personality) =
        addFloat32 tokens value.Drive
        addFloat32 tokens value.Aggression
        addFloat32 tokens value.Extraversion
        addFloat32 tokens value.Honesty
        addFloat32 tokens value.Greed

    let private readPersonality reader label =
        { Drive = readFloat32 reader (label + ".drive")
          Aggression = readFloat32 reader (label + ".aggression")
          Extraversion = readFloat32 reader (label + ".extraversion")
          Honesty = readFloat32 reader (label + ".honesty")
          Greed = readFloat32 reader (label + ".greed") }

    let private writeDialogueOutcome tokens (value: DialogueOutcome) =
        addInt64 tokens value.Tick
        writeNpcId tokens value.Actor
        writeNpcId tokens value.Target
        writeIntent tokens value.Intent
        writeResponse tokens value.Response
        addFloat32 tokens value.Valence

    let private readDialogueOutcome reader label =
        { Tick = readInt64 reader (label + ".tick")
          Actor = readNpcId reader (label + ".actor")
          Target = readNpcId reader (label + ".target")
          Intent = readIntent reader (label + ".intent")
          Response = readResponse reader (label + ".response")
          Valence = readFloat32 reader (label + ".valence") }

    let private writeRumor tokens (value: RumorEvent) =
        writeRumorId tokens value.Id
        addInt64 tokens value.Tick
        addInt64 tokens value.OriginTick
        writeNpcId tokens value.Source
        writeNpcId tokens value.Narrator
        writeNpcId tokens value.Receiver
        match value.Parent with
        | None -> add tokens "none"
        | Some parent ->
            add tokens "some"
            writeRumorId tokens parent
        addInt tokens value.Depth
        addFloat32 tokens value.Strength

    let private readRumor (reader: TokenReader) label =
        let id = readRumorId reader (label + ".id")
        let tick = readInt64 reader (label + ".tick")
        let originTick = readInt64 reader (label + ".origin-tick")
        let source = readNpcId reader (label + ".source")
        let narrator = readNpcId reader (label + ".narrator")
        let receiver = readNpcId reader (label + ".receiver")
        let parent =
            match reader.Take(label + ".parent") with
            | "none" -> None
            | "some" -> Some(readRumorId reader (label + ".parent-id"))
            | _ -> invalid (sprintf "invalid %s parent" label)
        { Id = id
          Tick = tick
          OriginTick = originTick
          Source = source
          Narrator = narrator
          Receiver = receiver
          Parent = parent
          Depth = readInt reader (label + ".depth")
          Strength = readFloat32 reader (label + ".strength") }

    let private writeMemoryKind tokens kind =
        match kind with
        | Meal -> add tokens "meal"
        | Rest -> add tokens "rest"
        | Pay -> add tokens "pay"
        | Hungry -> add tokens "hungry"
        | Chatted partner ->
            add tokens "chatted"
            writeNpcId tokens partner
        | Rumor rumor ->
            add tokens "rumor"
            writeRumorId tokens rumor
        | Bought (partner, item, quantity, price) ->
            add tokens "bought"
            writeNpcId tokens partner
            writeItemKind tokens item
            addInt tokens quantity
            addFloat32 tokens price
        | Sold (partner, item, quantity, price) ->
            add tokens "sold"
            writeNpcId tokens partner
            writeItemKind tokens item
            addInt tokens quantity
            addFloat32 tokens price
        | Dialogue (target, intent, response) ->
            add tokens "dialogue"
            writeNpcId tokens target
            writeIntent tokens intent
            writeResponse tokens response

    let private readMemoryKind (reader: TokenReader) label =
        match reader.Take(label) with
        | "meal" -> Meal
        | "rest" -> Rest
        | "pay" -> Pay
        | "hungry" -> Hungry
        | "chatted" -> Chatted(readNpcId reader (label + ".partner"))
        | "rumor" -> Rumor(readRumorId reader (label + ".id"))
        | "bought" ->
            Bought(
                readNpcId reader (label + ".partner"),
                readItemKind reader (label + ".item"),
                readInt reader (label + ".quantity"),
                readFloat32 reader (label + ".price"))
        | "sold" ->
            Sold(
                readNpcId reader (label + ".partner"),
                readItemKind reader (label + ".item"),
                readInt reader (label + ".quantity"),
                readFloat32 reader (label + ".price"))
        | "dialogue" ->
            Dialogue(
                readNpcId reader (label + ".target"),
                readIntent reader (label + ".intent"),
                readResponse reader (label + ".response"))
        | _ -> invalid (sprintf "invalid %s" label)

    let private writeMemoryEvent tokens (value: MemoryEvent) =
        addInt64 tokens value.Tick
        writeMemoryKind tokens value.Kind
        addFloat32 tokens value.Valence

    let private readMemoryEvent reader label =
        { Tick = readInt64 reader (label + ".tick")
          Kind = readMemoryKind reader (label + ".kind")
          Valence = readFloat32 reader (label + ".valence") }

    let private writeInteractionKind tokens kind =
        match kind with
        | ChatInit (narrator, receiver) ->
            add tokens "chat-init"
            writeNpcId tokens narrator
            writeNpcId tokens receiver
        | TradeEvent (buyer, seller, item, quantity, price) ->
            add tokens "trade-event"
            writeNpcId tokens buyer
            writeNpcId tokens seller
            writeItemKind tokens item
            addInt tokens quantity
            addFloat32 tokens price
        | DialogueEvent outcome ->
            add tokens "dialogue-event"
            writeDialogueOutcome tokens outcome

    let private readInteractionKind (reader: TokenReader) label =
        match reader.Take(label) with
        | "chat-init" -> ChatInit(readNpcId reader (label + ".narrator"), readNpcId reader (label + ".receiver"))
        | "trade-event" ->
            TradeEvent(
                readNpcId reader (label + ".buyer"),
                readNpcId reader (label + ".seller"),
                readItemKind reader (label + ".item"),
                readInt reader (label + ".quantity"),
                readFloat32 reader (label + ".price"))
        | "dialogue-event" -> DialogueEvent(readDialogueOutcome reader (label + ".outcome"))
        | _ -> invalid (sprintf "invalid %s" label)

    let private writeInteraction tokens (value: InteractionEvent) =
        addInt64 tokens value.Tick
        writeInteractionKind tokens value.Kind

    let private readInteraction reader label =
        { Tick = readInt64 reader (label + ".tick")
          Kind = readInteractionKind reader (label + ".kind") }

    let private writeAnnalKind tokens kind =
        match kind with
        | DialogueAnnal outcome ->
            add tokens "dialogue"
            writeDialogueOutcome tokens outcome
        | RumorAnnal rumor ->
            add tokens "rumor"
            writeRumor tokens rumor
        | TradeAnnal event ->
            add tokens "trade"
            writeInteraction tokens event

    let private readAnnalKind (reader: TokenReader) label =
        match reader.Take(label) with
        | "dialogue" -> DialogueAnnal(readDialogueOutcome reader (label + ".outcome"))
        | "rumor" -> RumorAnnal(readRumor reader (label + ".rumor"))
        | "trade" -> TradeAnnal(readInteraction reader (label + ".event"))
        | _ -> invalid (sprintf "invalid %s" label)

    let private writeAnnal tokens (value: AnnalEntry) =
        addInt64 tokens value.Tick
        writeAnnalKind tokens value.Kind
        addText tokens value.Summary

    let private readAnnal reader label =
        { Tick = readInt64 reader (label + ".tick")
          Kind = readAnnalKind reader (label + ".kind")
          Summary = readText reader (label + ".summary") }

    let private writeMind tokens (value: Mind) =
        writeNeeds tokens value.Needs
        writePersonality tokens value.Personality
        writeActionKind tokens value.Action
        writeVec2 tokens value.Target
        addInt64 tokens value.ActionAge
        addBool tokens value.EffectDone
        addBool tokens value.HungerFlagged
        addInt tokens value.Memory.Length
        value.Memory |> List.iter (writeMemoryEvent tokens)

    let private readMind reader label =
        let needs = readNeeds reader (label + ".needs")
        let personality = readPersonality reader (label + ".personality")
        let action = readActionKind reader (label + ".action")
        let target = readVec2 reader (label + ".target")
        let actionAge = readInt64 reader (label + ".action-age")
        let effectDone = readBool reader (label + ".effect-done")
        let hungerFlagged = readBool reader (label + ".hunger-flagged")
        let memoryCount = readCount reader (label + ".memory")
        { Needs = needs
          Personality = personality
          Action = action
          Target = target
          ActionAge = actionAge
          EffectDone = effectDone
          HungerFlagged = hungerFlagged
          Memory = List.init memoryCount (fun index -> readMemoryEvent reader (sprintf "%s.memory[%d]" label index)) }

    let private writeAvatar tokens (value: Avatar) =
        writeVec2 tokens value.Pos
        writeMind tokens value.Mind

    let private readAvatar reader =
        { Pos = readVec2 reader "avatar.pos"
          Mind = readMind reader "avatar.mind" }

    let private writeInventory tokens (inventory: Map<ItemKind, int>) =
        let entries = inventory |> Map.toList |> List.sortBy (fun (item, _) -> sprintf "%A" item)
        addInt tokens entries.Length
        for item, quantity in entries do
            writeItemKind tokens item
            addInt tokens quantity

    let private readInventory reader label =
        let count = readCount reader (label + ".count")
        [ for index in 0 .. count - 1 do
              let item = readItemKind reader (sprintf "%s[%d].item" label index)
              let quantity = readInt reader (sprintf "%s[%d].quantity" label index)
              if quantity < 0 then
                  invalid (sprintf "invalid %s[%d].quantity" label index)
              yield item, quantity ]
        |> Map.ofList

    let private writeNpc tokens (value: Npc) =
        writeNpcId tokens value.Id
        writeVec2 tokens value.Pos
        writeInventory tokens value.Inventory
        writeMind tokens value.Mind

    let private readNpc reader index =
        { Id = readNpcId reader (sprintf "npc[%d].id" index)
          Pos = readVec2 reader (sprintf "npc[%d].pos" index)
          Inventory = readInventory reader (sprintf "npc[%d].inventory" index)
          Mind = readMind reader (sprintf "npc[%d].mind" index) }

    let save (world: World) : string =
        let tokens = ResizeArray<string>()
        add tokens formatVersion
        addInt64 tokens world.Tick
        addFloat tokens world.Time
        addUInt64 tokens world.Rng.State
        addUInt64 tokens world.NoHost.Reserved
        writeAvatar tokens world.Avatar
        addInt tokens world.Npcs.Length
        world.Npcs |> Array.iter (writeNpc tokens)
        addInt tokens world.Events.Length
        world.Events |> List.iter (writeInteraction tokens)
        addInt tokens world.Rumors.Length
        world.Rumors |> List.iter (writeRumor tokens)
        addInt tokens world.Annals.Length
        world.Annals |> List.iter (writeAnnal tokens)
        String.Join("|", tokens)

    let load (text: string) : Result<World, string> =
        if isNull text then
            Error "save text is null"
        else
            try
                let tokens = text.Split([| '|' |], StringSplitOptions.None)
                let reader = TokenReader(tokens)
                if reader.Take("format") <> formatVersion then
                    invalid "unsupported save format"
                let tick = readInt64 reader "tick"
                let time = readFloat reader "time"
                let rng = { State = readUInt64 reader "rng" }
                let noHost = { Reserved = readUInt64 reader "no-host" }
                let avatar = readAvatar reader
                let npcCount = readCount reader "npcs"
                let npcs = Array.init npcCount (fun index -> readNpc reader index)
                let eventCount = readCount reader "events"
                let events = List.init eventCount (fun index -> readInteraction reader (sprintf "event[%d]" index))
                let rumorCount = readCount reader "rumors"
                let rumors = List.init rumorCount (fun index -> readRumor reader (sprintf "rumor[%d]" index))
                let annalCount = readCount reader "annals"
                let annals = List.init annalCount (fun index -> readAnnal reader (sprintf "annal[%d]" index))
                if reader.Remaining <> 0 then
                    invalid "trailing save data"
                Ok
                    { Tick = tick
                      Time = time
                      Rng = rng
                      Avatar = avatar
                      NoHost = noHost
                      Npcs = npcs
                      Events = events
                      Rumors = rumors
                      Annals = annals }
            with
            | SaveParseError message -> Error message
            | :? FormatException as ex -> Error(sprintf "invalid save: %s" ex.Message)
            | :? OverflowException as ex -> Error(sprintf "invalid save: %s" ex.Message)
            | :? ArgumentException as ex -> Error(sprintf "invalid save: %s" ex.Message)

    let saveToFile (path: string) (world: World) : unit =
        File.WriteAllText(path, save world, UTF8Encoding(false))

    let loadFromFile (path: string) : Result<World, string> =
        try
            File.ReadAllText(path) |> load
        with
        | :? IOException as ex -> Error(sprintf "could not read save: %s" ex.Message)