feat(m6a): add save speed and day-night controls

3 files changed, 589 insertions, 0 deletions

diff --git a/src/LivingVillage.Kernel/LivingVillage.Kernel.fsproj b/src/LivingVillage.Kernel/LivingVillage.Kernel.fsproj
index 8a4fad1..2a3126c 100644
--- a/src/LivingVillage.Kernel/LivingVillage.Kernel.fsproj
+++ b/src/LivingVillage.Kernel/LivingVillage.Kernel.fsproj
@@ -7,6 +7,8 @@
   <ItemGroup>
     <Compile Include="Rng.fs" />
     <Compile Include="Sim.fs" />
+    <Compile Include="SimulationControl.fs" />
+    <Compile Include="WorldSave.fs" />
   </ItemGroup>
 
 </Project>
diff --git a/src/LivingVillage.Kernel/SimulationControl.fs b/src/LivingVillage.Kernel/SimulationControl.fs
new file mode 100644
index 0000000..83e5f36
--- /dev/null
+++ b/src/LivingVillage.Kernel/SimulationControl.fs
@@ -0,0 +1,54 @@
+namespace LivingVillage.Kernel
+
+type SimulationSpeed =
+    | OneX
+    | TwoX
+    | FiveX
+
+type SimulationControl =
+    { Paused: bool
+      Speed: SimulationSpeed }
+
+module SimulationControl =
+
+    let initial : SimulationControl =
+        { Paused = false
+          Speed = OneX }
+
+    let setSpeed (speed: SimulationSpeed) (control: SimulationControl) : SimulationControl =
+        { control with Speed = speed }
+
+    let togglePause (control: SimulationControl) : SimulationControl =
+        { control with Paused = not control.Paused }
+
+    let initialForConfiguredSteps (configuredSteps: int) : SimulationControl * int option =
+        let steps = if configuredSteps > 0 then configuredSteps else 1
+        let control =
+            match steps with
+            | 2 -> setSpeed TwoX initial
+            | 5 -> setSpeed FiveX initial
+            | _ -> initial
+        let legacySteps =
+            match steps with
+            | 1
+            | 2
+            | 5 -> None
+            | value -> Some value
+        control, legacySteps
+
+    let stepsPerFrame (control: SimulationControl) : int =
+        if control.Paused then
+            0
+        else
+            match control.Speed with
+            | OneX -> 1
+            | TwoX -> 2
+            | FiveX -> 5
+
+    let stepsPerFrameWithLegacy (legacySteps: int option) (control: SimulationControl) : int =
+        if control.Paused then
+            0
+        else
+            match legacySteps with
+            | Some steps when steps > 0 -> steps
+            | _ -> stepsPerFrame control
diff --git a/src/LivingVillage.Kernel/WorldSave.fs b/src/LivingVillage.Kernel/WorldSave.fs
new file mode 100644
index 0000000..726170b
--- /dev/null
+++ b/src/LivingVillage.Kernel/WorldSave.fs
@@ -0,0 +1,533 @@
+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 -> 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 -> 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)
+              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)