diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/LivingVillage.Desktop.Tests/DesktopTests.fs | 10 | ||||
| -rw-r--r-- | src/LivingVillage.Desktop.Tests/LivingVillage.Desktop.Tests.fsproj | 1 | ||||
| -rw-r--r-- | src/LivingVillage.Desktop.Tests/M6aTests.fs | 15 | ||||
| -rw-r--r-- | src/LivingVillage.Desktop/Game.fs | 77 | ||||
| -rw-r--r-- | src/LivingVillage.Desktop/LivingVillage.Desktop.fsproj | 1 | ||||
| -rw-r--r-- | src/LivingVillage.Desktop/M6Presentation.fs | 35 | ||||
| -rw-r--r-- | src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj | 1 | ||||
| -rw-r--r-- | src/LivingVillage.Kernel.Tests/M6aTests.fs | 99 | ||||
| -rw-r--r-- | src/LivingVillage.Kernel/LivingVillage.Kernel.fsproj | 2 | ||||
| -rw-r--r-- | src/LivingVillage.Kernel/SimulationControl.fs | 54 | ||||
| -rw-r--r-- | src/LivingVillage.Kernel/WorldSave.fs | 533 |
11 files changed, 818 insertions, 10 deletions
diff --git a/src/LivingVillage.Desktop.Tests/DesktopTests.fs b/src/LivingVillage.Desktop.Tests/DesktopTests.fs index ffcc6c0..650f757 100644 --- a/src/LivingVillage.Desktop.Tests/DesktopTests.fs +++ b/src/LivingVillage.Desktop.Tests/DesktopTests.fs @@ -61,3 +61,13 @@ type DesktopTests () = Assert.IsTrue(result.Chronicle.Contains("dialogue")) Assert.IsTrue(result.RumorTrace.Contains("receiver=-1")) Assert.IsTrue(result.RumorTrace.Contains("depth=3")) + + [<TestMethod>] + member _.DayNightStateChangesTheRenderProfile () = + let day = M6Presentation.profileAtTick (6L * Sim.ticksPerDay / 24L) + let night = M6Presentation.profileAtTick (22L * Sim.ticksPerDay / 24L) + + Assert.AreEqual<M6DayNight>(Day, day.Mode) + Assert.AreEqual<M6DayNight>(Night, night.Mode) + Assert.AreNotEqual(day.Background, night.Background) + Assert.AreNotEqual(day.WorldTint, night.WorldTint) diff --git a/src/LivingVillage.Desktop.Tests/LivingVillage.Desktop.Tests.fsproj b/src/LivingVillage.Desktop.Tests/LivingVillage.Desktop.Tests.fsproj index a1cbe33..b8e2055 100644 --- a/src/LivingVillage.Desktop.Tests/LivingVillage.Desktop.Tests.fsproj +++ b/src/LivingVillage.Desktop.Tests/LivingVillage.Desktop.Tests.fsproj @@ -7,6 +7,7 @@ <ItemGroup> <Compile Include="DesktopTests.fs" /> + <Compile Include="M6aTests.fs" /> </ItemGroup> <ItemGroup> diff --git a/src/LivingVillage.Desktop.Tests/M6aTests.fs b/src/LivingVillage.Desktop.Tests/M6aTests.fs new file mode 100644 index 0000000..1cc29d4 --- /dev/null +++ b/src/LivingVillage.Desktop.Tests/M6aTests.fs @@ -0,0 +1,15 @@ +namespace LivingVillage.Desktop.Tests + +open Microsoft.VisualStudio.TestTools.UnitTesting +open LivingVillage.Kernel +open LivingVillage.Desktop + +[<TestClass>] +type M6aDesktopTests () = + + [<TestMethod>] + member _.SpeedLabelsExposePauseAndThreeRunningModes () = + Assert.AreEqual<string>("PAUSED", M6Presentation.clockLabel { Paused = true; Speed = OneX }) + Assert.AreEqual<string>("1X", M6Presentation.clockLabel { Paused = false; Speed = OneX }) + Assert.AreEqual<string>("2X", M6Presentation.clockLabel { Paused = false; Speed = TwoX }) + Assert.AreEqual<string>("5X", M6Presentation.clockLabel { Paused = false; Speed = FiveX }) diff --git a/src/LivingVillage.Desktop/Game.fs b/src/LivingVillage.Desktop/Game.fs index 09d3364..232930d 100644 --- a/src/LivingVillage.Desktop/Game.fs +++ b/src/LivingVillage.Desktop/Game.fs @@ -139,13 +139,19 @@ type LivingVillageGame() as this = let autoplay = Environment.GetEnvironmentVariable("LV_AUTOPLAY") = "1" let titleSuffix = if autoplay then " [AUTOPLAY]" else "" let modeName = if autoplay then "autoplay" else "keyboard" - let stepsPerFrame = + let configuredStepsPerFrame = match Environment.GetEnvironmentVariable("LV_STEPS_PER_FRAME") with | null | "" -> 1 | s -> match Int32.TryParse s with | true, n when n > 0 -> n | _ -> 1 + let initialSimulationControl, initialLegacyStepsPerFrame = + SimulationControl.initialForConfiguredSteps configuredStepsPerFrame + let savePath = + match Environment.GetEnvironmentVariable("LV_SAVE_PATH") with + | null | "" -> "living-village.save" + | path -> path let graphics = new GraphicsDeviceManager(this) let mutable spriteBatch = Unchecked.defaultof<SpriteBatch> let mutable atlas = Unchecked.defaultof<Texture2D> @@ -159,6 +165,8 @@ type LivingVillageGame() as this = let mutable relationView = false let mutable relationSnapshot: float32[,] option = None let mutable m5View = M5Interaction.initial + let mutable simulationControl = initialSimulationControl + let mutable legacyStepsPerFrame = initialLegacyStepsPerFrame do graphics.PreferredBackBufferWidth <- 1280 @@ -166,9 +174,9 @@ type LivingVillageGame() as this = graphics.SynchronizeWithVerticalRetrace <- true this.IsFixedTimeStep <- true this.TargetElapsedTime <- TimeSpan.FromTicks(TimeSpan.TicksPerSecond / 60L) - this.Window.Title <- if autoplay then "Living Village M5 [AUTOPLAY]" else "Living Village M5" + this.Window.Title <- if autoplay then "Living Village M6 [AUTOPLAY]" else "Living Village M6" printfn $"mode={modeName} seed=42" - printfn "controls=WASD move E interact 1-6 choose Q observe Tab needs C chronicle L relations Esc close/exit" + printfn "controls=WASD move E interact 1-6 choose Q observe Tab needs C chronicle L relations P pause F1/F2/F3 speed F6 save F7 load Esc close/exit" member private this.CenterCamera() = let viewport = this.GraphicsDevice.Viewport let vw = float32 viewport.Width @@ -196,6 +204,37 @@ type LivingVillageGame() as this = let pressedAny (keys: Keys list) = keys |> List.exists pressed let lPressed = pressed Keys.L let escapePressed = pressed Keys.Escape + if pressed Keys.P then + simulationControl <- SimulationControl.togglePause simulationControl + printfn $"simulation={M6Presentation.clockLabel simulationControl}" + if pressed Keys.F1 then + simulationControl <- SimulationControl.setSpeed OneX simulationControl + legacyStepsPerFrame <- None + printfn $"simulation={M6Presentation.clockLabel simulationControl}" + if pressed Keys.F2 then + simulationControl <- SimulationControl.setSpeed TwoX simulationControl + legacyStepsPerFrame <- None + printfn $"simulation={M6Presentation.clockLabel simulationControl}" + if pressed Keys.F3 then + simulationControl <- SimulationControl.setSpeed FiveX simulationControl + legacyStepsPerFrame <- None + printfn $"simulation={M6Presentation.clockLabel simulationControl}" + if pressed Keys.F6 then + try + WorldSave.saveToFile savePath world + printfn $"save=ok path={savePath} tick={world.Tick}" + with + | ex -> printfn $"save=error path={savePath} message={ex.Message}" + if pressed Keys.F7 then + match WorldSave.loadFromFile savePath with + | Ok nextWorld -> + world <- nextWorld + relationView <- false + relationSnapshot <- None + m5View <- M5Interaction.initial + this.CenterCamera() + printfn $"load=ok path={savePath} tick={world.Tick}" + | Error failure -> printfn $"load=error path={savePath} message={failure}" if escapePressed then if m5View.Panel <> WorldPanel then let nextWorld, nextView = M5Interaction.apply ClosePanel world m5View @@ -245,8 +284,10 @@ type LivingVillageGame() as this = elif kb.IsKeyDown(Keys.W) then -1.0f else 0.0f) } let ts = { Input = input } - for _ in 1 .. stepsPerFrame do - world <- Sim.step ts world + let stepCount = SimulationControl.stepsPerFrameWithLegacy legacyStepsPerFrame simulationControl + if stepCount > 0 then + for _ in 1 .. stepCount do + world <- Sim.step ts world this.CenterCamera() fpsFrames <- fpsFrames + 1 fpsSeconds <- fpsSeconds + gameTime.ElapsedGameTime.TotalSeconds @@ -258,9 +299,14 @@ type LivingVillageGame() as this = if world.Npcs.Length > 0 then NpcView.actionName world.Npcs.[0].Mind.Action else "none" + let profile = M6Presentation.profileAtTick world.Tick + let dayNight = + match profile.Mode with + | Day -> "DAY" + | Night -> "NIGHT" let viewTag = if relationView then " | [RELATIONS]" else "" this.Window.Title <- - $"Living Village M5{titleSuffix} | fps {fps:F1} | tick {world.Tick} | npc {npcAction}{viewTag} | panel {M5Interaction.panelName m5View} | {M5Interaction.titleText m5View}" + $"Living Village M6{titleSuffix} | fps {fps:F1} | tick {world.Tick} | {dayNight} | {M6Presentation.clockLabel simulationControl} | npc {npcAction}{viewTag} | panel {M5Interaction.panelName m5View} | {M5Interaction.titleText m5View}" printfn $"fps={fps:F1} tick={world.Tick} pos=({world.Avatar.Pos.X:F0},{world.Avatar.Pos.Y:F0})" prevKb <- kb @@ -272,7 +318,8 @@ type LivingVillageGame() as this = spriteBatch.Draw(pixel, a, System.Nullable(), color, angle, Vector2.Zero, Vector2(len, thickness), SpriteEffects.None, 0.0f) member private this.DrawRelationView() = - this.GraphicsDevice.Clear(Color(16, 20, 26)) + let profile = M6Presentation.profileAtTick world.Tick + this.GraphicsDevice.Clear(profile.Background) let viewport = this.GraphicsDevice.Viewport let vw = float32 viewport.Width let vh = float32 viewport.Height @@ -310,7 +357,8 @@ type LivingVillageGame() as this = this.DrawWorldView() member private this.DrawWorldView() = - this.GraphicsDevice.Clear(Color.CornflowerBlue) + let profile = M6Presentation.profileAtTick world.Tick + this.GraphicsDevice.Clear(profile.Background) let viewport = this.GraphicsDevice.Viewport let camX = int camera.X let camY = int camera.Y @@ -324,7 +372,7 @@ type LivingVillageGame() as this = let src = Rectangle(int map.[x, y] * Sim.tilePixels, 0, Sim.tilePixels, Sim.tilePixels) let dst = Rectangle(x * Sim.tilePixels - camX, y * Sim.tilePixels - camY, Sim.tilePixels, Sim.tilePixels) - spriteBatch.Draw(atlas, dst, src, Color.White) + spriteBatch.Draw(atlas, dst, src, profile.WorldTint) let avatarDst = Rectangle(int world.Avatar.Pos.X - camX, int world.Avatar.Pos.Y - camY, Sim.tilePixels, Sim.tilePixels) spriteBatch.Draw(pixel, avatarDst, Color.Red) @@ -351,7 +399,16 @@ type LivingVillageGame() as this = let lineHeight = 18 let maxChars = max 1 (innerWidth / (6 * textScale)) let maxLines = max 1 ((panelHeight - 32) / lineHeight) - let lines = M5Interaction.panelLines world m5View |> List.truncate maxLines + let profile = M6Presentation.profileAtTick world.Tick + let dayNight = + match profile.Mode with + | Day -> "DAY" + | Night -> "NIGHT" + let m6Lines = + [ sprintf "TIME %s %s" dayNight (M6Presentation.clockLabel simulationControl) + "P PAUSE F1 F2 F3 SPEED" + "F6 SAVE F7 LOAD" ] + let lines = (m6Lines @ M5Interaction.panelLines world m5View) |> List.truncate maxLines spriteBatch.Begin() spriteBatch.Draw(pixel, panel, Color(15, 19, 25, 220)) spriteBatch.Draw(pixel, Rectangle(panelX, panelY, panelWidth, 4), Color(92, 180, 190)) diff --git a/src/LivingVillage.Desktop/LivingVillage.Desktop.fsproj b/src/LivingVillage.Desktop/LivingVillage.Desktop.fsproj index cd8ccab..caf8ba5 100644 --- a/src/LivingVillage.Desktop/LivingVillage.Desktop.fsproj +++ b/src/LivingVillage.Desktop/LivingVillage.Desktop.fsproj @@ -7,6 +7,7 @@ <ItemGroup> <Compile Include="Interaction.fs" /> + <Compile Include="M6Presentation.fs" /> <Compile Include="Game.fs" /> <Compile Include="Program.fs" /> </ItemGroup> diff --git a/src/LivingVillage.Desktop/M6Presentation.fs b/src/LivingVillage.Desktop/M6Presentation.fs new file mode 100644 index 0000000..410f20a --- /dev/null +++ b/src/LivingVillage.Desktop/M6Presentation.fs @@ -0,0 +1,35 @@ +namespace LivingVillage.Desktop + +open Microsoft.Xna.Framework +open LivingVillage.Kernel +open LivingVillage.Kernel.Sim + +type M6DayNight = + | Day + | Night + +type M6RenderProfile = + { Mode: M6DayNight + Background: Color + WorldTint: Color } + +module M6Presentation = + + let profileAtTick (tick: int64) : M6RenderProfile = + if Sim.isNightTick tick then + { Mode = Night + Background = Color(18, 25, 55) + WorldTint = Color(118, 136, 184) } + else + { Mode = Day + Background = Color(100, 160, 210) + WorldTint = Color.White } + + let clockLabel (control: SimulationControl) : string = + if control.Paused then + "PAUSED" + else + match control.Speed with + | OneX -> "1X" + | TwoX -> "2X" + | FiveX -> "5X" diff --git a/src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj b/src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj index 2a3ba3c..b30fc8f 100644 --- a/src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj +++ b/src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj @@ -11,6 +11,7 @@ <Compile Include="RumorTests.fs" /> <Compile Include="TradeTests.fs" /> <Compile Include="M5Tests.fs" /> + <Compile Include="M6aTests.fs" /> </ItemGroup> <ItemGroup> diff --git a/src/LivingVillage.Kernel.Tests/M6aTests.fs b/src/LivingVillage.Kernel.Tests/M6aTests.fs new file mode 100644 index 0000000..8a318be --- /dev/null +++ b/src/LivingVillage.Kernel.Tests/M6aTests.fs @@ -0,0 +1,99 @@ +namespace LivingVillage.Kernel.Tests + +open Microsoft.VisualStudio.TestTools.UnitTesting +open LivingVillage.Kernel +open LivingVillage.Kernel.Sim + +module private M6aHarness = + + let zeroInput = { Input = { MoveX = 0.0f; MoveY = 0.0f } } + + let atNpc (id: int) (world: World) : World = + let npc = world.Npcs.[id] + { world with Avatar = { world.Avatar with Pos = npc.Pos } } + + let readyForChat (world: World) : World = + { world with + Npcs = + world.Npcs + |> Array.map (fun npc -> + { npc with + Mind = + { npc.Mind with + Action = Wander + Target = actionTarget Wander + ActionAge = minActionTicks + EffectDone = true } }) } + + let withDialogue (world: World) : World = + match Sim.chooseDialogue (NpcId 0) SmallTalk (atNpc 0 world) with + | DialogueSucceeded (_, next) -> next + | DialogueRejected (failure, _) -> Assert.Fail($"dialogue rejected: {failure}"); Unchecked.defaultof<World> + + let withChat (world: World) : World = + match Sim.chat { Narrator = NpcId 0; Receiver = NpcId 1 } (readyForChat world) with + | ChatSucceeded (Some _, next) -> next + | ChatSucceeded (None, _) -> Assert.Fail("chat should create a rumor"); Unchecked.defaultof<World> + | ChatRejected (failure, _) -> Assert.Fail($"chat rejected: {failure}"); Unchecked.defaultof<World> + + let withTrade (world: World) : World = + match Sim.trade { Buyer = NpcId 0; Seller = NpcId 1; Item = Food; Quantity = 1 } world with + | TradeSucceeded next -> next + | TradeRejected (failure, _) -> Assert.Fail($"trade rejected: {failure}"); Unchecked.defaultof<World> + + let advance (inputs: Input list) (world: World) : World = + inputs |> List.fold (fun current input -> Sim.step { Input = input } current) world + +[<TestClass>] +type M6aTests () = + + [<TestMethod>] + member _.SaveLoadPreservesWorldAndDeterministicContinuation () = + let world = + Sim.initialWorldN 7UL 4 + |> M6aHarness.withDialogue + |> M6aHarness.withChat + |> M6aHarness.withTrade + let encoded = WorldSave.save world + + match WorldSave.load encoded with + | Error failure -> Assert.Fail($"save should load: {failure}") + | Ok restored -> + Assert.AreEqual<string>(encoded, WorldSave.save restored) + let inputs = + [ { MoveX = 0.5f; MoveY = -0.25f } + { MoveX = 0.0f; MoveY = 0.0f } + { MoveX = -1.0f; MoveY = 0.75f } + { MoveX = 0.25f; MoveY = 0.0f } ] + let continued = M6aHarness.advance inputs world + let restoredContinued = M6aHarness.advance inputs restored + Assert.AreEqual<string>(WorldSave.save continued, WorldSave.save restoredContinued) + Assert.AreEqual<int64>(world.Tick, restored.Tick) + Assert.AreEqual<uint64>(world.Rng.State, restored.Rng.State) + Assert.IsFalse(restored.Events.IsEmpty) + Assert.IsFalse(restored.Rumors.IsEmpty) + Assert.IsFalse(restored.Annals.IsEmpty) + Assert.AreEqual<Avatar>(world.Avatar, restored.Avatar) + CollectionAssert.AreEqual(world.Npcs, restored.Npcs) + + [<TestMethod>] + member _.SimulationClockSupportsPauseAndRequestedSpeeds () = + let initial = SimulationControl.initial + Assert.AreEqual<int>(1, SimulationControl.stepsPerFrame initial) + Assert.AreEqual<int>(2, SimulationControl.stepsPerFrame (SimulationControl.setSpeed TwoX initial)) + Assert.AreEqual<int>(5, SimulationControl.stepsPerFrame (SimulationControl.setSpeed FiveX initial)) + let paused = SimulationControl.togglePause initial + Assert.IsTrue(paused.Paused) + Assert.AreEqual<int>(0, SimulationControl.stepsPerFrame paused) + let resumed = SimulationControl.togglePause paused + Assert.IsFalse(resumed.Paused) + Assert.AreEqual<SimulationSpeed>(OneX, resumed.Speed) + + [<TestMethod>] + member _.ConfiguredLegacyStepCountsRemainExactUntilManualSpeedSelection () = + let control, legacySteps = SimulationControl.initialForConfiguredSteps 7 + Assert.AreEqual<int option>(Some 7, legacySteps) + Assert.AreEqual<int>(7, SimulationControl.stepsPerFrameWithLegacy legacySteps control) + Assert.AreEqual<int>(0, SimulationControl.stepsPerFrameWithLegacy legacySteps (SimulationControl.togglePause control)) + let manuallySelected = SimulationControl.setSpeed TwoX control + Assert.AreEqual<int>(2, SimulationControl.stepsPerFrameWithLegacy None manuallySelected) 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) |