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"
        | Fish -> add tokens "fish"
        | Spice -> add tokens "spice"
        | Scroll -> add tokens "scroll"

    let private readItemKind (reader: TokenReader) label =
        match reader.Take(label) with
        | "food" -> Food
        | "fish" -> Fish
        | "spice" -> Spice
        | "scroll" -> Scroll
        | _ -> 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
          DayIndex = rumorDayIndex 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
        | StoryAnnal -> add tokens "story"

    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"))
        | "story" -> StoryAnnal
        | _ -> 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 writeTaskTemplateId tokens template =
        match template with
        | Occupation.DeliverGrain -> add tokens "deliver-grain"
        | Occupation.HelpWork -> add tokens "help-work"
        | Occupation.TillSoil -> add tokens "till-soil"
        | Occupation.NightCatch -> add tokens "night-catch"
        | Occupation.SellFish -> add tokens "sell-fish"
        | Occupation.MarketInquiry -> add tokens "market-inquiry"
        | Occupation.BuyGoods -> add tokens "buy-goods"
        | Occupation.Resell -> add tokens "resell"
        | Occupation.ObserveNotes -> add tokens "observe-notes"
        | Occupation.ReasonDebate -> add tokens "reason-debate"

    let private readTaskTemplateId (reader: TokenReader) label =
        match reader.Take(label) with
        | "deliver-grain" -> Occupation.DeliverGrain
        | "help-work" -> Occupation.HelpWork
        | "till-soil" -> Occupation.TillSoil
        | "night-catch" -> Occupation.NightCatch
        | "sell-fish" -> Occupation.SellFish
        | "market-inquiry" -> Occupation.MarketInquiry
        | "buy-goods" -> Occupation.BuyGoods
        | "resell" -> Occupation.Resell
        | "observe-notes" -> Occupation.ObserveNotes
        | "reason-debate" -> Occupation.ReasonDebate
        | _ -> invalid (sprintf "invalid %s" label)

    let private writeTaskState tokens state =
        match state with
        | Occupation.Offered -> add tokens "offered"
        | Occupation.Active -> add tokens "active"
        | Occupation.Done -> add tokens "done"
        | Occupation.Failed -> add tokens "failed"

    let private readTaskState (reader: TokenReader) label =
        match reader.Take(label) with
        | "offered" -> Occupation.Offered
        | "active" -> Occupation.Active
        | "done" -> Occupation.Done
        | "failed" -> Occupation.Failed
        | _ -> invalid (sprintf "invalid %s" label)

    /// v3 today-task 尾段（design §3）：紧跟 annals 之后，仅在有任务时写入。
    /// 旧 v3（P10 版式）无此尾段 → 新 reader 读出 Today = None。
    let private writeDailyTask tokens (task: Occupation.DailyTask) =
        add tokens "task-today"
        writeTaskTemplateId tokens task.TemplateId
        writeTaskState tokens task.State
        addInt64 tokens task.OfferedTick
        addInt64 tokens task.DueTick
        match task.TargetNpc with
        | None -> add tokens "npc-none"
        | Some npc ->
            add tokens "npc-some"
            writeNpcId tokens npc
        match task.TargetTile with
        | None -> add tokens "tile-none"
        | Some (tileX, tileY) ->
            add tokens "tile-some"
            addInt tokens tileX
            addInt tokens tileY

    let private readDailyTask (reader: TokenReader) : Occupation.DailyTask =
        let template = readTaskTemplateId reader "task.template"
        let state = readTaskState reader "task.state"
        let offeredTick = readInt64 reader "task.offered-tick"
        let dueTick = readInt64 reader "task.due-tick"
        let targetNpc =
            match reader.Take("task.target-npc") with
            | "npc-none" -> None
            | "npc-some" -> Some(readNpcId reader "task.target-npc.id")
            | _ -> invalid "invalid task.target-npc"
        let targetTile =
            match reader.Take("task.target-tile") with
            | "tile-none" -> None
            | "tile-some" -> Some(readInt reader "task.target-tile.x", readInt reader "task.target-tile.y")
            | _ -> invalid "invalid task.target-tile"
        { TemplateId = template
          TargetNpc = targetNpc
          TargetTile = targetTile
          OfferedTick = offeredTick
          DueTick = dueTick
          State = state }

    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) }

    /// v3 saves are produced only when an occupation is attached (design task
    /// requires the default (occupation-free) path to stay byte-identical to
    /// today's v2 output).
    /// v3 saves are emitted only when an occupation is attached; the default
    /// (occupation-free) path stays byte-identical to today's v2 output.
    /// When the occupation carries Today (design §3), a today-task tail segment
    /// is appended after the annals.
    let saveWith (occupation: Occupation.State option) (world: World) : string =
        let tokens = ResizeArray<string>()
        match occupation with
        | None -> add tokens "LV_WORLD_SAVE_V2"
        | Some state -> add tokens "LV_WORLD_SAVE_V3"
        addInt tokens mapWidthTiles
        addInt tokens mapHeightTiles
        match occupation with
        | Some state ->
            add tokens (Occupation.saveToken state.Profile.Kind)
            addInt tokens state.TaskToken
            addInt tokens state.StoryStage
        | None -> ()
        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)
        match occupation with
        | Some state ->
            match state.Today with
            | Some task -> writeDailyTask tokens task
            | None -> ()
        | None -> ()
        String.Join("|", tokens)

    /// Full parser: world plus the v3 occupation companion (None for v1/v2 or
    /// v3 without a recognized kind). The optional today-task tail after the
    /// annals is validated in both cases; only its value is dropped when there
    /// is no occupation state to attach it to.
    let private parse (text: string) : Result<World * Occupation.State option, string> =
        if isNull text then
            Error "save text is null"
        else
            try
                let tokens = text.Split([| '|' |], StringSplitOptions.None)
                let reader = TokenReader(tokens)
                let mutable occupationOption : Occupation.State option = None
                let versionTaken = reader.Take("format")
                match versionTaken with
                | "LV_WORLD_SAVE_V3" ->
                    configureBounds (readInt reader "bounds.w") (readInt reader "bounds.h")
                | v2 when v2 = "LV_WORLD_SAVE_V2" ->
                    configureBounds (readInt reader "bounds.w") (readInt reader "bounds.h")
                | v1 when v1 = formatVersion ->
                    configureBounds 64 48
                | _ -> invalid "unsupported save format"
                match versionTaken with
                | "LV_WORLD_SAVE_V3" ->
                    let kindToken = reader.Take("occupation.kind")
                    let task = readInt reader "occupation.task"
                    let stage = readInt reader "occupation.stage"
                    let kind =
                        match kindToken with
                        | "farmer" -> Some Occupation.Farmer
                        | "fisher" -> Some Occupation.Fisher
                        | "peddler" -> Some Occupation.Peddler
                        | "scholar" -> Some Occupation.Scholar
                        | _ -> None
                    occupationOption <- kind |> Option.map (fun kind -> { Profile = Occupation.profileOf kind; TaskToken = task; Today = None; StoryStage = stage })
                | _ -> ()
                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 rumorStats = rumorWorkingSetStats rumors
                let annalCount = readCount reader "annals"
                let annals = List.init annalCount (fun index -> readAnnal reader (sprintf "annal[%d]" index))
                let todayTask =
                    if reader.Remaining > 0 then
                        match reader.Take("task.today") with
                        | "task-today" -> Some(readDailyTask reader)
                        | _ -> invalid "trailing save data"
                    else None
                if reader.Remaining <> 0 then
                    invalid "trailing save data"
                let occupation =
                    occupationOption
                    |> Option.map (fun state -> { state with Today = todayTask })
                Ok
                    ({ Tick = tick
                       Time = time
                       Rng = rng
                       Avatar = avatar
                       NoHost = noHost
                       Npcs = npcs
                       Events = events
                       Rumors = rumors
                       RumorCount = fst rumorStats
                       RumorOldestDay = snd rumorStats
                       Annals = annals },
                     occupation)
            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 load (text: string) : Result<World, string> =
        parse text |> Result.map (fun (world, _) -> world)

    /// v2 output (no occupation) — byte-identical to the historic format.
    let save (world: World) : string = saveWith None world

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

    let saveToFileWith (occupation: Occupation.State option) (path: string) (world: World) : unit =
        File.WriteAllText(path, saveWith occupation world, UTF8Encoding(false))

    /// v3 companion reader: (world, occupation option incl. today task tail);
    /// None for v1/v2 or v3 w/o kind.
    let loadFromFileWith (path: string) : Result<World * Occupation.State option, string> =
        try
            File.ReadAllText path |> parse
        with
        | :? IOException as ex -> Error(sprintf "could not read save: %s" ex.Message)

    let loadFromFile (path: string) : Result<World, string> =
        loadFromFileWith path |> Result.map (fun (world, _) -> world)