summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/LivingVillage.Kernel.Tests/DeterminismTests.fs3
-rw-r--r--src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj1
-rw-r--r--src/LivingVillage.Kernel.Tests/RelationTests.fs2
-rw-r--r--src/LivingVillage.Kernel.Tests/TradeTests.fs154
-rw-r--r--src/LivingVillage.Kernel/Sim.fs135
5 files changed, 295 insertions, 0 deletions
diff --git a/src/LivingVillage.Kernel.Tests/DeterminismTests.fs b/src/LivingVillage.Kernel.Tests/DeterminismTests.fs
index 972ce19..c37be67 100644
--- a/src/LivingVillage.Kernel.Tests/DeterminismTests.fs
+++ b/src/LivingVillage.Kernel.Tests/DeterminismTests.fs
@@ -233,6 +233,9 @@ type DeterminismTests () =
| Rest -> 0.4f
| Pay -> 0.2f
| Hungry -> -0.4f
+ | Chatted _ -> Sim.chatValence
+ | Bought _ -> 0.3f
+ | Sold _ -> 0.3f
if e.Valence <> expected then
Assert.Fail($"valence/kind mismatch: {e.Kind} -> {e.Valence}")
if e.Valence < -1.0f || e.Valence > 1.0f then
diff --git a/src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj b/src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj
index 65e50db..d805d73 100644
--- a/src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj
+++ b/src/LivingVillage.Kernel.Tests/LivingVillage.Kernel.Tests.fsproj
@@ -8,6 +8,7 @@
<ItemGroup>
<Compile Include="DeterminismTests.fs" />
<Compile Include="RelationTests.fs" />
+ <Compile Include="TradeTests.fs" />
</ItemGroup>
<ItemGroup>
diff --git a/src/LivingVillage.Kernel.Tests/RelationTests.fs b/src/LivingVillage.Kernel.Tests/RelationTests.fs
index dc67e6d..dc433a7 100644
--- a/src/LivingVillage.Kernel.Tests/RelationTests.fs
+++ b/src/LivingVillage.Kernel.Tests/RelationTests.fs
@@ -19,6 +19,7 @@ module RelationHarness =
let mkNpc id mem =
{ Id = NpcId id
Pos = { X = 0.0f; Y = 0.0f }
+ Inventory = Map.empty
Mind =
{ Needs = needs
Personality = personalityOfSeed 1UL
@@ -163,6 +164,7 @@ type RelationTests () =
let npc id pos action age effectDone memory =
{ Id = NpcId id
Pos = pos
+ Inventory = Map.empty
Mind =
{ Needs = needs
Personality = personality
diff --git a/src/LivingVillage.Kernel.Tests/TradeTests.fs b/src/LivingVillage.Kernel.Tests/TradeTests.fs
new file mode 100644
index 0000000..c7c8ef4
--- /dev/null
+++ b/src/LivingVillage.Kernel.Tests/TradeTests.fs
@@ -0,0 +1,154 @@
+namespace LivingVillage.Kernel.Tests
+
+open Microsoft.VisualStudio.TestTools.UnitTesting
+open LivingVillage.Kernel
+open LivingVillage.Kernel.Sim
+
+module private TradeHarness =
+
+ let private personality =
+ { Drive = 0.5f
+ Aggression = 0.0f
+ Extraversion = 0.5f
+ Honesty = 0.5f
+ Greed = 0.5f }
+
+ let private needs money hunger =
+ { Hunger = hunger
+ Energy = 100.0f
+ Social = 100.0f
+ Money = money }
+
+ let private inventory food = Map.ofList [ Food, food ]
+
+ let private npc id money hunger food memory personalityOverride =
+ { Id = NpcId id
+ Pos = { X = float32 (id * 10); Y = 0.0f }
+ Inventory = inventory food
+ Mind =
+ { Needs = needs money hunger
+ Personality = defaultArg personalityOverride personality
+ Action = Wander
+ Target = actionTarget Wander
+ ActionAge = 0L
+ EffectDone = false
+ HungerFlagged = false
+ Memory = memory } }
+
+ let world buyerMoney buyerHunger buyerFood sellerMoney sellerHunger sellerFood sellerMemory =
+ { Tick = 10L
+ Time = 0.0
+ Rng = Rng.ofSeed 7UL
+ Avatar = { Pos = { X = 0.0f; Y = 0.0f } }
+ NoHost = { Reserved = 0UL }
+ Npcs =
+ [| npc 0 buyerMoney buyerHunger buyerFood [] None
+ npc 1 sellerMoney sellerHunger sellerFood sellerMemory None |]
+ Events = [] }
+
+ let request quantity =
+ { Buyer = NpcId 0
+ Seller = NpcId 1
+ Item = Food
+ Quantity = quantity }
+
+ let withSellerGreed greed world =
+ let seller = world.Npcs.[1]
+ { world with
+ Npcs =
+ [| world.Npcs.[0]
+ { seller with
+ Mind =
+ { seller.Mind with
+ Personality = { seller.Mind.Personality with Greed = greed } } } |] }
+
+ let succeeded result =
+ match result with
+ | TradeSucceeded world -> world
+ | TradeRejected (failure, _) -> Assert.Fail($"expected success, got {failure}"); Unchecked.defaultof<World>
+
+[<TestClass>]
+type TradeTests () =
+
+ [<TestMethod>]
+ member _.SuccessfulTradeTransfersItemMoneyAndMemoryAtomically () =
+ let before = TradeHarness.world 50.0f 30.0f 0 10.0f 80.0f 3 []
+ let request = TradeHarness.request 2
+ let unitPrice = Sim.quotePrice request before |> Option.get
+ let after = Sim.trade request before |> TradeHarness.succeeded
+ let total = unitPrice * 2.0f
+
+ Assert.IsTrue(after.Npcs.[0].Inventory.[Food] = 2)
+ Assert.IsTrue(after.Npcs.[1].Inventory.[Food] = 1)
+ Assert.IsTrue(abs (after.Npcs.[0].Mind.Needs.Money - (50.0f - total)) < 1e-5f)
+ Assert.IsTrue(abs (after.Npcs.[1].Mind.Needs.Money - (10.0f + total)) < 1e-5f)
+ Assert.IsTrue(abs ((after.Npcs.[0].Mind.Needs.Money + after.Npcs.[1].Mind.Needs.Money) - 60.0f) < 1e-5f)
+ Assert.IsTrue(after.Npcs.[0].Mind.Memory |> List.exists (fun e ->
+ match e.Kind with
+ | Bought (NpcId seller, Food, quantity, price) -> seller = 1 && quantity = 2 && price = unitPrice
+ | _ -> false))
+ Assert.IsTrue(after.Npcs.[1].Mind.Memory |> List.exists (fun e ->
+ match e.Kind with
+ | Sold (NpcId buyer, Food, quantity, price) -> buyer = 0 && quantity = 2 && price = unitPrice
+ | _ -> false))
+ Assert.IsTrue(after.Events |> List.exists (fun event ->
+ match event.Kind with
+ | TradeEvent (NpcId buyer, NpcId seller, Food, quantity, price) ->
+ buyer = 0 && seller = 1 && quantity = 2 && price = unitPrice
+ | _ -> false))
+ Assert.IsTrue(before.Npcs.[0].Inventory.[Food] = 0, "trade must not mutate the input world")
+ Assert.IsTrue(before.Npcs.[1].Inventory.[Food] = 3, "trade must not mutate the input world")
+
+ [<TestMethod>]
+ member _.RejectedTradesLeaveWorldUnchanged () =
+ let before = TradeHarness.world 50.0f 30.0f 0 10.0f 80.0f 3 []
+ let cases =
+ [ TradeHarness.request 0, InvalidQuantity
+ TradeHarness.request 4, OutOfStock
+ { TradeHarness.request 1 with Seller = NpcId 0 }, SameParticipant
+ TradeHarness.request 1, InsufficientFunds ]
+ for request, expected in cases do
+ let candidate =
+ if expected = InsufficientFunds then
+ TradeHarness.world 1.0f 30.0f 0 10.0f 80.0f 3 []
+ else before
+ match Sim.trade request candidate with
+ | TradeRejected (actual, unchanged) ->
+ if actual <> expected then Assert.Fail($"expected {expected}, got {actual}")
+ if unchanged <> candidate then Assert.Fail("rejected trade changed the world")
+ | TradeSucceeded _ -> Assert.Fail($"expected rejection {expected}")
+
+ [<TestMethod>]
+ member _.UnknownParticipantsAreRejectedWithoutChangingWorld () =
+ let before = TradeHarness.world 50.0f 30.0f 0 10.0f 80.0f 3 []
+ let missingBuyer = { TradeHarness.request 1 with Buyer = NpcId 9 }
+ let missingSeller = { TradeHarness.request 1 with Seller = NpcId 9 }
+ match Sim.trade missingBuyer before with
+ | TradeRejected (BuyerNotFound, unchanged) ->
+ if unchanged <> before then Assert.Fail("missing buyer changed the world")
+ | other -> Assert.Fail($"expected BuyerNotFound, got {other}")
+ match Sim.trade missingSeller before with
+ | TradeRejected (SellerNotFound, unchanged) ->
+ if unchanged <> before then Assert.Fail("missing seller changed the world")
+ | other -> Assert.Fail($"expected SellerNotFound, got {other}")
+
+ [<TestMethod>]
+ member _.QuoteIsDeterministicAndRespondsToNeedStockPersonalityAndRecentTrades () =
+ let request = TradeHarness.request 1
+ let baseWorld = TradeHarness.world 50.0f 100.0f 0 50.0f 100.0f 20 []
+ let urgentWorld = TradeHarness.world 50.0f 0.0f 0 50.0f 100.0f 20 []
+ let scarceWorld = TradeHarness.world 50.0f 100.0f 0 50.0f 100.0f 1 []
+ let greedySeller = TradeHarness.withSellerGreed 1.0f baseWorld
+ let recentMemory = [ { Tick = 9L; Kind = Sold(NpcId 0, Food, 1, 40.0f); Valence = 0.2f } ]
+ let recentWorld = TradeHarness.world 50.0f 100.0f 0 50.0f 100.0f 20 recentMemory
+ let p0 = Sim.quotePrice request baseWorld |> Option.get
+ let p1 = Sim.quotePrice request baseWorld |> Option.get
+ let urgent = Sim.quotePrice request urgentWorld |> Option.get
+ let scarce = Sim.quotePrice request scarceWorld |> Option.get
+ let greedy = Sim.quotePrice request greedySeller |> Option.get
+ let recent = Sim.quotePrice request recentWorld |> Option.get
+ if p0 <> p1 then Assert.Fail("same world and request must produce the same quote")
+ if urgent <= p0 then Assert.Fail("urgent buyer need must raise the quote")
+ if scarce <= p0 then Assert.Fail("scarce seller stock must raise the quote")
+ if greedy <= p0 then Assert.Fail("seller greed must affect the quote")
+ if recent <= p0 then Assert.Fail("recent transaction prices must affect the quote")
diff --git a/src/LivingVillage.Kernel/Sim.fs b/src/LivingVillage.Kernel/Sim.fs
index ba3fd37..a2944e5 100644
--- a/src/LivingVillage.Kernel/Sim.fs
+++ b/src/LivingVillage.Kernel/Sim.fs
@@ -41,6 +41,9 @@ module Sim =
Honesty: float32
Greed: float32 }
+ type ItemKind =
+ | Food
+
type NpcActionKind =
| Eat
| Sleep
@@ -54,6 +57,8 @@ module Sim =
| Pay
| Hungry
| Chatted of NpcId
+ | Bought of NpcId * ItemKind * int * float32
+ | Sold of NpcId * ItemKind * int * float32
type MemoryEvent =
{ Tick: int64
@@ -62,6 +67,7 @@ module Sim =
type InteractionKind =
| ChatInit of NpcId * NpcId
+ | TradeEvent of NpcId * NpcId * ItemKind * int * float32
type InteractionEvent =
{ Tick: int64
@@ -82,6 +88,7 @@ module Sim =
type Npc =
{ Id: NpcId
Pos: Vec2
+ Inventory: Map<ItemKind, int>
Mind: Mind }
[<Struct>]
@@ -94,6 +101,24 @@ module Sim =
Npcs: Npc[]
Events: InteractionEvent list }
+ type TradeRequest =
+ { Buyer: NpcId
+ Seller: NpcId
+ Item: ItemKind
+ Quantity: int }
+
+ type TradeFailure =
+ | BuyerNotFound
+ | SellerNotFound
+ | SameParticipant
+ | InvalidQuantity
+ | OutOfStock
+ | InsufficientFunds
+
+ type TradeResult =
+ | TradeSucceeded of World
+ | TradeRejected of TradeFailure * World
+
let ticksPerSecond = 60L
let secondsPerDay = 86400L
let ticksPerDay = secondsPerDay * ticksPerSecond
@@ -159,6 +184,8 @@ module Sim =
| Pay -> 0.2f
| Hungry -> -0.4f
| Chatted _ -> chatValence
+ | Bought _ -> 0.3f
+ | Sold _ -> 0.3f
let recordMemory (tick: int64) (kind: MemoryKind) (mem: MemoryEvent list) : MemoryEvent list =
let updated = { Tick = tick; Kind = kind; Valence = valenceOfKind kind } :: mem
@@ -249,10 +276,12 @@ module Sim =
let centerY = float32 (mapHeightTiles * tilePixels / 2 - tilePixels / 2)
let personality = personalityOfSeed seed
let needs = { Hunger = 100.0f; Energy = 100.0f; Social = 100.0f; Money = 50.0f }
+ let inventory = Map.ofList [ Food, 10 ]
let startAction = decideAction (isNightTick 0L) needs personality
let npc =
{ Id = NpcId 0
Pos = { X = centerX; Y = centerY }
+ Inventory = inventory
Mind =
{ Needs = needs
Personality = personality
@@ -275,6 +304,7 @@ module Sim =
let cols = 6
let spacing = 64.0f
let needs = { Hunger = 100.0f; Energy = 100.0f; Social = 100.0f; Money = 50.0f }
+ let inventory = Map.ofList [ Food, 10 ]
let npcs =
Array.init count (fun i ->
let col = i % cols
@@ -286,6 +316,7 @@ module Sim =
let startAction = decideAction (isNightTick 0L) needs personality
{ Id = NpcId i
Pos = pos
+ Inventory = inventory
Mind =
{ Needs = needs
Personality = personality
@@ -297,6 +328,109 @@ module Sim =
Memory = [] } })
{ base_ with Npcs = npcs }
+ let private inventoryQuantity (item: ItemKind) (inventory: Map<ItemKind, int>) : int =
+ inventory |> Map.tryFind item |> Option.defaultValue 0
+
+ let private changeInventory (item: ItemKind) (delta: int) (inventory: Map<ItemKind, int>) : Map<ItemKind, int> =
+ let next = inventoryQuantity item inventory + delta
+ if next <= 0 then Map.remove item inventory else Map.add item next inventory
+
+ let private findNpcIndex (id: NpcId) (npcs: Npc[]) : int option =
+ npcs |> Array.tryFindIndex (fun npc -> npc.Id = id)
+
+ let private recentTransactionPrice (item: ItemKind) (world: World) : float32 option =
+ world.Npcs
+ |> Array.toList
+ |> List.collect (fun npc -> npc.Mind.Memory)
+ |> List.choose (fun event ->
+ match event.Kind with
+ | Bought (_, tradedItem, _, price) when tradedItem = item -> Some(event.Tick, price)
+ | Sold (_, tradedItem, _, price) when tradedItem = item -> Some(event.Tick, price)
+ | _ -> None)
+ |> List.sortByDescending fst
+ |> List.truncate 8
+ |> List.map snd
+ |> function
+ | [] -> None
+ | prices -> Some(List.average prices)
+
+ let quotePrice (request: TradeRequest) (world: World) : float32 option =
+ match findNpcIndex request.Buyer world.Npcs, findNpcIndex request.Seller world.Npcs with
+ | Some buyerIndex, Some sellerIndex when buyerIndex <> sellerIndex ->
+ let buyer = world.Npcs.[buyerIndex]
+ let seller = world.Npcs.[sellerIndex]
+ let basePrice =
+ match request.Item with
+ | Food -> 10.0f
+ let buyerUrgency = clamp ((100.0f - buyer.Mind.Needs.Hunger) / 100.0f) 0.0f 1.0f
+ let stockPressure =
+ 1.0f - clamp (float32 (inventoryQuantity request.Item seller.Inventory) / 20.0f) 0.0f 1.0f
+ let sellerNeed = clamp ((100.0f - seller.Mind.Needs.Money) / 100.0f) 0.0f 1.0f
+ let personalityFactor =
+ 0.2f * seller.Mind.Personality.Greed
+ + 0.1f * (1.0f - buyer.Mind.Personality.Honesty)
+ - 0.05f * buyer.Mind.Personality.Greed
+ let marketFactor =
+ match recentTransactionPrice request.Item world with
+ | Some recent -> clamp (0.85f + 0.15f * recent / basePrice) 0.75f 1.5f
+ | None -> 1.0f
+ let raw =
+ basePrice
+ * (0.75f
+ + 0.35f * buyerUrgency
+ + 0.30f * stockPressure
+ + 0.15f * sellerNeed
+ + personalityFactor)
+ * marketFactor
+ Some(clamp raw 0.01f 1000.0f)
+ | _ -> None
+
+ let trade (request: TradeRequest) (world: World) : TradeResult =
+ match findNpcIndex request.Buyer world.Npcs with
+ | None -> TradeRejected(BuyerNotFound, world)
+ | Some buyerIndex ->
+ match findNpcIndex request.Seller world.Npcs with
+ | None -> TradeRejected(SellerNotFound, world)
+ | Some sellerIndex when buyerIndex = sellerIndex -> TradeRejected(SameParticipant, world)
+ | Some sellerIndex when request.Quantity <= 0 -> TradeRejected(InvalidQuantity, world)
+ | Some sellerIndex ->
+ let buyer = world.Npcs.[buyerIndex]
+ let seller = world.Npcs.[sellerIndex]
+ let stock = inventoryQuantity request.Item seller.Inventory
+ if stock < request.Quantity then
+ TradeRejected(OutOfStock, world)
+ else
+ match quotePrice request world with
+ | None -> TradeRejected(SameParticipant, world)
+ | Some unitPrice ->
+ let total = unitPrice * float32 request.Quantity
+ if buyer.Mind.Needs.Money < total then
+ TradeRejected(InsufficientFunds, world)
+ else
+ let newNpcs = Array.copy world.Npcs
+ let buyerMemory =
+ recordMemory world.Tick (Bought(request.Seller, request.Item, request.Quantity, unitPrice)) buyer.Mind.Memory
+ let sellerMemory =
+ recordMemory world.Tick (Sold(request.Buyer, request.Item, request.Quantity, unitPrice)) seller.Mind.Memory
+ newNpcs.[buyerIndex] <-
+ { buyer with
+ Inventory = changeInventory request.Item request.Quantity buyer.Inventory
+ Mind =
+ { buyer.Mind with
+ Needs = { buyer.Mind.Needs with Money = buyer.Mind.Needs.Money - total }
+ Memory = buyerMemory } }
+ newNpcs.[sellerIndex] <-
+ { seller with
+ Inventory = changeInventory request.Item (-request.Quantity) seller.Inventory
+ Mind =
+ { seller.Mind with
+ Needs = { seller.Mind.Needs with Money = seller.Mind.Needs.Money + total }
+ Memory = sellerMemory } }
+ let event =
+ { Tick = world.Tick
+ Kind = TradeEvent(request.Buyer, request.Seller, request.Item, request.Quantity, unitPrice) }
+ TradeSucceeded { world with Npcs = newNpcs; Events = world.Events @ [ event ] }
+
let chatableForChat (n: Npc) : bool =
n.Mind.Action <> Sleep && n.Mind.Action <> Chat
@@ -449,6 +583,7 @@ module Sim =
for ev in queue do
match ev.Kind with
| ChatInit (a, b) -> applyChatInit ev.Tick a b newNpcs |> ignore
+ | TradeEvent _ -> ()
{ Tick = tick
Time = float tick * dtSeconds
Rng = rngNext
generated by cgit v1.2.3 (git 2.39.1) at 2026-10-04 19:03:40 +0000