{-# LANGUAGE FlexibleContexts #-}
module Game.LambdaHack.Atomic.HandleAtomicWrite
( handleUpdAtomic
#ifdef EXPOSE_INTERNAL
, updRegisterItems, updCreateActor, updDestroyActor
, updCreateItem, updDestroyItem, updSpotItemBag, updLoseItemBag
, updMoveActor, updWaitActor, updDisplaceActor, updMoveItem
, updRefillHP, updRefillCalm
, updTrajectory, updQuitFaction, updSpotStashFaction, updLoseStashFaction
, updLeadFaction, updDiplFaction, updDoctrineFaction, updAutoFaction
, updRecordKill, updAlterTile, updAlterExplorable, updSearchTile
, updSpotTile, updLoseTile, updAlterSmell, updSpotSmell, updLoseSmell
, updTimeItem, updAgeGame, updUnAgeGame, ageLevel, updDiscover, updCover
, updDiscoverKind, discoverKind, updCoverKind
, updDiscoverAspect, discoverAspect, updCoverAspect
, updDiscoverServer, updCoverServer
, updRestart, updRestartServer, updResumeServer
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Int (Int64)
import Game.LambdaHack.Atomic.CmdAtomic
import Game.LambdaHack.Atomic.MonadStateWrite
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.ItemKind (ItemKind)
import Game.LambdaHack.Content.ModeKind
import qualified Game.LambdaHack.Content.PlaceKind as PK
import Game.LambdaHack.Content.TileKind (TileKind, unknownId)
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m ()
handleUpdAtomic :: UpdAtomic -> m ()
handleUpdAtomic UpdAtomic
cmd = case UpdAtomic
cmd of
UpdRegisterItems [(ItemId, Item)]
ais -> [(ItemId, Item)] -> m ()
forall (m :: * -> *). MonadStateWrite m => [(ItemId, Item)] -> m ()
updRegisterItems [(ItemId, Item)]
ais
UpdCreateActor ActorId
aid Actor
body [(ItemId, Item)]
ais -> ActorId -> Actor -> [(ItemId, Item)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> [(ItemId, Item)] -> m ()
updCreateActor ActorId
aid Actor
body [(ItemId, Item)]
ais
UpdDestroyActor ActorId
aid Actor
body [(ItemId, Item)]
ais -> ActorId -> Actor -> [(ItemId, Item)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> [(ItemId, Item)] -> m ()
updDestroyActor ActorId
aid Actor
body [(ItemId, Item)]
ais
UpdCreateItem Bool
_ ItemId
iid Item
item ItemQuant
kit Container
c -> ItemId -> Item -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> ItemQuant -> Container -> m ()
updCreateItem ItemId
iid Item
item ItemQuant
kit Container
c
UpdDestroyItem Bool
_ ItemId
iid Item
item ItemQuant
kit Container
c -> ItemId -> Item -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem ItemId
iid Item
item ItemQuant
kit Container
c
UpdSpotActor ActorId
aid Actor
body -> ActorId -> Actor -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Actor -> m ()
updSpotActor ActorId
aid Actor
body
UpdLoseActor ActorId
aid Actor
body -> ActorId -> Actor -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Actor -> m ()
updLoseActor ActorId
aid Actor
body
UpdSpotItem Bool
_ ItemId
iid ItemQuant
kit Container
c -> ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
updSpotItem ItemId
iid ItemQuant
kit Container
c
UpdLoseItem Bool
_ ItemId
iid ItemQuant
kit Container
c -> ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
updLoseItem ItemId
iid ItemQuant
kit Container
c
UpdSpotItemBag Bool
_ Container
c ItemBag
bag -> Container -> ItemBag -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemBag -> m ()
updSpotItemBag Container
c ItemBag
bag
UpdLoseItemBag Bool
_ Container
c ItemBag
bag -> Container -> ItemBag -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemBag -> m ()
updLoseItemBag Container
c ItemBag
bag
UpdMoveActor ActorId
aid Point
fromP Point
toP -> ActorId -> Point -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Point -> Point -> m ()
updMoveActor ActorId
aid Point
fromP Point
toP
UpdWaitActor ActorId
aid Watchfulness
fromWS Watchfulness
toWS -> ActorId -> Watchfulness -> Watchfulness -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Watchfulness -> Watchfulness -> m ()
updWaitActor ActorId
aid Watchfulness
fromWS Watchfulness
toWS
UpdDisplaceActor ActorId
source ActorId
target -> ActorId -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> ActorId -> m ()
updDisplaceActor ActorId
source ActorId
target
UpdMoveItem ItemId
iid Int
k ActorId
aid CStore
c1 CStore
c2 -> ItemId -> Int -> ActorId -> CStore -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Int -> ActorId -> CStore -> CStore -> m ()
updMoveItem ItemId
iid Int
k ActorId
aid CStore
c1 CStore
c2
UpdRefillHP ActorId
aid Int64
n -> ActorId -> Int64 -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillHP ActorId
aid Int64
n
UpdRefillCalm ActorId
aid Int64
n -> ActorId -> Int64 -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillCalm ActorId
aid Int64
n
UpdTrajectory ActorId
aid Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed)
toT -> ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> m ()
updTrajectory ActorId
aid Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed)
toT
UpdQuitFaction FactionId
fid Maybe Status
fromSt Maybe Status
toSt Maybe (FactionAnalytics, GenerationAnalytics)
_ -> FactionId -> Maybe Status -> Maybe Status -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> Maybe Status -> Maybe Status -> m ()
updQuitFaction FactionId
fid Maybe Status
fromSt Maybe Status
toSt
UpdSpotStashFaction Bool
_ FactionId
fid LevelId
lid Point
pos -> FactionId -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> LevelId -> Point -> m ()
updSpotStashFaction FactionId
fid LevelId
lid Point
pos
UpdLoseStashFaction Bool
_ FactionId
fid LevelId
lid Point
pos -> FactionId -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> LevelId -> Point -> m ()
updLoseStashFaction FactionId
fid LevelId
lid Point
pos
UpdLeadFaction FactionId
fid Maybe ActorId
source Maybe ActorId
target -> FactionId -> Maybe ActorId -> Maybe ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> Maybe ActorId -> Maybe ActorId -> m ()
updLeadFaction FactionId
fid Maybe ActorId
source Maybe ActorId
target
UpdDiplFaction FactionId
fid1 FactionId
fid2 Diplomacy
fromDipl Diplomacy
toDipl ->
FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
updDiplFaction FactionId
fid1 FactionId
fid2 Diplomacy
fromDipl Diplomacy
toDipl
UpdDoctrineFaction FactionId
fid Doctrine
toT Doctrine
fromT -> FactionId -> Doctrine -> Doctrine -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> Doctrine -> Doctrine -> m ()
updDoctrineFaction FactionId
fid Doctrine
toT Doctrine
fromT
UpdAutoFaction FactionId
fid Bool
st -> FactionId -> Bool -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> Bool -> m ()
updAutoFaction FactionId
fid Bool
st
UpdRecordKill ActorId
aid ContentId ItemKind
ikind Int
k -> ActorId -> ContentId ItemKind -> Int -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> ContentId ItemKind -> Int -> m ()
updRecordKill ActorId
aid ContentId ItemKind
ikind Int
k
UpdAlterTile LevelId
lid Point
p ContentId TileKind
fromTile ContentId TileKind
toTile -> LevelId
-> Point -> ContentId TileKind -> ContentId TileKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId
-> Point -> ContentId TileKind -> ContentId TileKind -> m ()
updAlterTile LevelId
lid Point
p ContentId TileKind
fromTile ContentId TileKind
toTile
UpdAlterExplorable LevelId
lid Int
delta -> LevelId -> Int -> m ()
forall (m :: * -> *). MonadStateWrite m => LevelId -> Int -> m ()
updAlterExplorable LevelId
lid Int
delta
UpdAlterGold Int
delta -> Int -> m ()
forall (m :: * -> *). MonadStateWrite m => Int -> m ()
updAlterGold Int
delta
UpdSearchTile ActorId
aid Point
p ContentId TileKind
toTile -> ActorId -> Point -> ContentId TileKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Point -> ContentId TileKind -> m ()
updSearchTile ActorId
aid Point
p ContentId TileKind
toTile
UpdHideTile{} -> m ()
forall a. HasCallStack => a
undefined
UpdSpotTile LevelId
lid [(Point, ContentId TileKind)]
ts -> LevelId -> [(Point, ContentId TileKind)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile LevelId
lid [(Point, ContentId TileKind)]
ts
UpdLoseTile LevelId
lid [(Point, ContentId TileKind)]
ts -> LevelId -> [(Point, ContentId TileKind)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile LevelId
lid [(Point, ContentId TileKind)]
ts
UpdSpotEntry LevelId
lid [(Point, PlaceEntry)]
ts -> LevelId -> [(Point, PlaceEntry)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, PlaceEntry)] -> m ()
updSpotEntry LevelId
lid [(Point, PlaceEntry)]
ts
UpdLoseEntry LevelId
lid [(Point, PlaceEntry)]
ts -> LevelId -> [(Point, PlaceEntry)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, PlaceEntry)] -> m ()
updLoseEntry LevelId
lid [(Point, PlaceEntry)]
ts
UpdAlterSmell LevelId
lid Point
p Time
fromSm Time
toSm -> LevelId -> Point -> Time -> Time -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> Point -> Time -> Time -> m ()
updAlterSmell LevelId
lid Point
p Time
fromSm Time
toSm
UpdSpotSmell LevelId
lid [(Point, Time)]
sms -> LevelId -> [(Point, Time)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, Time)] -> m ()
updSpotSmell LevelId
lid [(Point, Time)]
sms
UpdLoseSmell LevelId
lid [(Point, Time)]
sms -> LevelId -> [(Point, Time)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, Time)] -> m ()
updLoseSmell LevelId
lid [(Point, Time)]
sms
UpdTimeItem ItemId
iid Container
c ItemTimers
fromIt ItemTimers
toIt -> ItemId -> Container -> ItemTimers -> ItemTimers -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Container -> ItemTimers -> ItemTimers -> m ()
updTimeItem ItemId
iid Container
c ItemTimers
fromIt ItemTimers
toIt
UpdAgeGame EnumSet LevelId
lids -> EnumSet LevelId -> m ()
forall (m :: * -> *). MonadStateWrite m => EnumSet LevelId -> m ()
updAgeGame EnumSet LevelId
lids
UpdUnAgeGame EnumSet LevelId
lids -> EnumSet LevelId -> m ()
forall (m :: * -> *). MonadStateWrite m => EnumSet LevelId -> m ()
updUnAgeGame EnumSet LevelId
lids
UpdDiscover Container
c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem -> Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
updDiscover Container
c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem
UpdCover Container
c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem -> Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
forall (m :: * -> *).
Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
updCover Container
c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem
UpdDiscoverKind Container
c ItemKindIx
ix ContentId ItemKind
ik -> Container -> ItemKindIx -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemKindIx -> ContentId ItemKind -> m ()
updDiscoverKind Container
c ItemKindIx
ix ContentId ItemKind
ik
UpdCoverKind Container
c ItemKindIx
ix ContentId ItemKind
ik -> Container -> ItemKindIx -> ContentId ItemKind -> m ()
forall (m :: * -> *).
Container -> ItemKindIx -> ContentId ItemKind -> m ()
updCoverKind Container
c ItemKindIx
ix ContentId ItemKind
ik
UpdDiscoverAspect Container
c ItemId
iid AspectRecord
arItem -> Container -> ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemId -> AspectRecord -> m ()
updDiscoverAspect Container
c ItemId
iid AspectRecord
arItem
UpdCoverAspect Container
c ItemId
iid AspectRecord
arItem -> Container -> ItemId -> AspectRecord -> m ()
forall (m :: * -> *). Container -> ItemId -> AspectRecord -> m ()
updCoverAspect Container
c ItemId
iid AspectRecord
arItem
UpdDiscoverServer ItemId
iid AspectRecord
arItem -> ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
updDiscoverServer ItemId
iid AspectRecord
arItem
UpdCoverServer ItemId
iid AspectRecord
arItem -> ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
updCoverServer ItemId
iid AspectRecord
arItem
UpdPerception LevelId
_ Perception
outPer Perception
inPer ->
Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Perception -> Bool
nullPer Perception
outPer Bool -> Bool -> Bool
&& Perception -> Bool
nullPer Perception
inPer)) (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
UpdRestart FactionId
_ PerLid
_ State
s Challenge
_ ClientOptions
_ SMGen
_ -> State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
updRestart State
s
UpdRestartServer State
s -> State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
updRestartServer State
s
UpdResume{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
UpdResumeServer State
s -> State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
updResumeServer State
s
UpdKillExit{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
UpdAtomic
UpdWriteSave -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
UpdHearFid{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
UpdMuteMessages{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updRegisterItems :: MonadStateWrite m => [(ItemId, Item)] -> m ()
updRegisterItems :: [(ItemId, Item)] -> m ()
updRegisterItems [(ItemId, Item)]
ais = do
let h :: Item -> Item -> Item
h Item
item1 Item
item2 =
Bool -> Item -> Item
forall a. HasCallStack => Bool -> a -> a
assert (Item -> Item -> Bool
itemsMatch Item
item1 Item
item2
Bool -> (String, (Item, Item, [(ItemId, Item)])) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"inconsistent added items"
String
-> (Item, Item, [(ItemId, Item)])
-> (String, (Item, Item, [(ItemId, Item)]))
forall v. String -> v -> (String, v)
`swith` (Item
item1, Item
item2, [(ItemId, Item)]
ais))
Item
item2
[(ItemId, Item)] -> ((ItemId, Item) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [(ItemId, Item)]
ais (((ItemId, Item) -> m ()) -> m ())
-> ((ItemId, Item) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ItemId
iid, Item
item) -> do
let f :: State -> State
f = case Item -> ItemIdentity
jkind Item
item of
IdentityObvious ContentId ItemKind
_ -> State -> State
forall a. a -> a
id
IdentityCovered ItemKindIx
ix ContentId ItemKind
_ ->
(ItemIxMap -> ItemIxMap) -> State -> State
updateItemIxMap ((ItemIxMap -> ItemIxMap) -> State -> State)
-> (ItemIxMap -> ItemIxMap) -> State -> State
forall a b. (a -> b) -> a -> b
$ (EnumSet ItemId -> EnumSet ItemId -> EnumSet ItemId)
-> ItemKindIx -> EnumSet ItemId -> ItemIxMap -> ItemIxMap
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith EnumSet ItemId -> EnumSet ItemId -> EnumSet ItemId
forall k. EnumSet k -> EnumSet k -> EnumSet k
ES.union ItemKindIx
ix (ItemId -> EnumSet ItemId
forall k. Enum k => k -> EnumSet k
ES.singleton ItemId
iid)
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ State -> State
f (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ItemDict -> ItemDict) -> State -> State
updateItemD ((Item -> Item -> Item) -> ItemId -> Item -> ItemDict -> ItemDict
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith Item -> Item -> Item
h ItemId
iid Item
item)
updCreateActor :: MonadStateWrite m
=> ActorId -> Actor -> [(ItemId, Item)] -> m ()
updCreateActor :: ActorId -> Actor -> [(ItemId, Item)] -> m ()
updCreateActor ActorId
aid Actor
body [(ItemId, Item)]
ais = do
[(ItemId, Item)] -> m ()
forall (m :: * -> *). MonadStateWrite m => [(ItemId, Item)] -> m ()
updRegisterItems [(ItemId, Item)]
ais
ActorId -> Actor -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Actor -> m ()
updSpotActor ActorId
aid Actor
body
updDestroyActor :: MonadStateWrite m
=> ActorId -> Actor -> [(ItemId, Item)] -> m ()
updDestroyActor :: ActorId -> Actor -> [(ItemId, Item)] -> m ()
updDestroyActor ActorId
aid Actor
body [(ItemId, Item)]
ais = do
ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
let match :: (ItemId, Item) -> Bool
match (ItemId
iid, Item
item) = Item -> Item -> Bool
itemsMatch (ItemDict
itemD ItemDict -> ItemId -> Item
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid) Item
item
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (((ItemId, Item) -> Bool) -> [(ItemId, Item)] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (ItemId, Item) -> Bool
match [(ItemId, Item)]
ais Bool
-> (String, (ActorId, Actor, [(ItemId, Item)], ItemDict)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"destroyed actor items not found"
String
-> (ActorId, Actor, [(ItemId, Item)], ItemDict)
-> (String, (ActorId, Actor, [(ItemId, Item)], ItemDict))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, [(ItemId, Item)]
ais, ItemDict
itemD)) ()
ActorId -> Actor -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Actor -> m ()
updLoseActor ActorId
aid Actor
body
updCreateItem :: MonadStateWrite m
=> ItemId -> Item -> ItemQuant -> Container -> m ()
updCreateItem :: ItemId -> Item -> ItemQuant -> Container -> m ()
updCreateItem ItemId
iid Item
item ItemQuant
kit Container
c = do
[(ItemId, Item)] -> m ()
forall (m :: * -> *). MonadStateWrite m => [(ItemId, Item)] -> m ()
updRegisterItems [(ItemId
iid, Item
item)]
ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
updSpotItem ItemId
iid ItemQuant
kit Container
c
updDestroyItem :: MonadStateWrite m
=> ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem :: ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem ItemId
iid Item
item kit :: ItemQuant
kit@(Int
k, ItemTimers
_) Container
c = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert ((case ItemId
iid ItemId -> ItemDict -> Maybe Item
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemDict
itemD of
Maybe Item
Nothing -> Bool
False
Just Item
item0 -> Item -> Item -> Bool
itemsMatch Item
item0 Item
item)
Bool -> (String, (ItemId, Item, ItemDict)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"item already removed"
String
-> (ItemId, Item, ItemDict) -> (String, (ItemId, Item, ItemDict))
forall v. String -> v -> (String, v)
`swith` (ItemId
iid, Item
item, ItemDict
itemD)) ()
ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
updLoseItem ItemId
iid ItemQuant
kit Container
c
updSpotActor :: MonadStateWrite m => ActorId -> Actor -> m ()
updSpotActor :: ActorId -> Actor -> m ()
updSpotActor ActorId
aid Actor
body = do
let f :: Maybe Actor -> Maybe Actor
f Maybe Actor
Nothing = Actor -> Maybe Actor
forall a. a -> Maybe a
Just Actor
body
f (Just Actor
b) = Bool -> Maybe Actor -> Maybe Actor
forall a. HasCallStack => Bool -> a -> a
assert (Actor
body Actor -> Actor -> Bool
forall a. Eq a => a -> a -> Bool
== Actor
b Bool -> (ActorId, Actor, Actor) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ActorId
aid, Actor
body, Actor
b)) (Maybe Actor -> Maybe Actor) -> Maybe Actor -> Maybe Actor
forall a b. (a -> b) -> a -> b
$
String -> Maybe Actor
forall a. String -> a
atomicFail (String -> Maybe Actor) -> String -> Maybe Actor
forall a b. (a -> b) -> a -> b
$ String
"actor already added" String -> (ActorId, Actor, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body, Actor
b)
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (ActorDict -> ActorDict) -> State -> State
updateActorD ((ActorDict -> ActorDict) -> State -> State)
-> (ActorDict -> ActorDict) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Maybe Actor -> Maybe Actor) -> ActorId -> ActorDict -> ActorDict
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Actor -> Maybe Actor
f ActorId
aid
let g :: Maybe [ActorId] -> Maybe [ActorId]
g Maybe [ActorId]
Nothing = [ActorId] -> Maybe [ActorId]
forall a. a -> Maybe a
Just [ActorId
aid]
g (Just [ActorId]
l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
Bool -> Maybe [ActorId] -> Maybe [ActorId]
forall a. HasCallStack => Bool -> a -> a
assert (ActorId
aid ActorId -> [ActorId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ActorId]
l Bool -> (String, (ActorId, Actor, [ActorId])) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"actor already added"
String
-> (ActorId, Actor, [ActorId])
-> (String, (ActorId, Actor, [ActorId]))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, [ActorId]
l))
#endif
([ActorId] -> Maybe [ActorId]
forall a. a -> Maybe a
Just ([ActorId] -> Maybe [ActorId]) -> [ActorId] -> Maybe [ActorId]
forall a b. (a -> b) -> a -> b
$ ActorId
aid ActorId -> [ActorId] -> [ActorId]
forall a. a -> [a] -> [a]
: [ActorId]
l)
let h :: Maybe ActorId -> Maybe ActorId
h Maybe ActorId
Nothing = ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aid
h (Just ActorId
aid2) = String -> Maybe ActorId
forall a. HasCallStack => String -> a
error (String -> Maybe ActorId) -> String -> Maybe ActorId
forall a b. (a -> b) -> a -> b
$ String
"an actor already present there"
String -> (ActorId, Actor, ActorId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body, ActorId
aid2)
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel (Actor -> LevelId
blid Actor
body) ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ if Actor -> Bool
bproj Actor
body
then (ProjectileMap -> ProjectileMap) -> Level -> Level
updateProjMap ((Maybe [ActorId] -> Maybe [ActorId])
-> Point -> ProjectileMap -> ProjectileMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe [ActorId] -> Maybe [ActorId]
g (Actor -> Point
bpos Actor
body))
else (BigActorMap -> BigActorMap) -> Level -> Level
updateBigMap ((Maybe ActorId -> Maybe ActorId)
-> Point -> BigActorMap -> BigActorMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ActorId -> Maybe ActorId
h (Actor -> Point
bpos Actor
body))
Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ Actor -> State -> Skills
maxSkillsFromActor Actor
body
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (ActorMaxSkills -> ActorMaxSkills) -> State -> State
updateActorMaxSkills ((ActorMaxSkills -> ActorMaxSkills) -> State -> State)
-> (ActorMaxSkills -> ActorMaxSkills) -> State -> State
forall a b. (a -> b) -> a -> b
$ ActorId -> Skills -> ActorMaxSkills -> ActorMaxSkills
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert ActorId
aid Skills
actorMaxSk
updLoseActor :: MonadStateWrite m => ActorId -> Actor -> m ()
updLoseActor :: ActorId -> Actor -> m ()
updLoseActor ActorId
aid Actor
body = do
let f :: Maybe Actor -> Maybe Actor
f Maybe Actor
Nothing = String -> Maybe Actor
forall a. HasCallStack => String -> a
error (String -> Maybe Actor) -> String -> Maybe Actor
forall a b. (a -> b) -> a -> b
$ String
"actor already removed" String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body)
f (Just Actor
b) = Bool -> Maybe Actor -> Maybe Actor
forall a. HasCallStack => Bool -> a -> a
assert (Actor
b Actor -> Actor -> Bool
forall a. Eq a => a -> a -> Bool
== Actor
body Bool -> (String, (ActorId, Actor, Actor)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"inconsistent destroyed actor body"
String
-> (ActorId, Actor, Actor) -> (String, (ActorId, Actor, Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, Actor
b)) Maybe Actor
forall a. Maybe a
Nothing
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (ActorDict -> ActorDict) -> State -> State
updateActorD ((ActorDict -> ActorDict) -> State -> State)
-> (ActorDict -> ActorDict) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Maybe Actor -> Maybe Actor) -> ActorId -> ActorDict -> ActorDict
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Actor -> Maybe Actor
f ActorId
aid
let g :: Maybe [ActorId] -> Maybe [ActorId]
g Maybe [ActorId]
Nothing = String -> Maybe [ActorId]
forall a. HasCallStack => String -> a
error (String -> Maybe [ActorId]) -> String -> Maybe [ActorId]
forall a b. (a -> b) -> a -> b
$ String
"actor already removed" String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body)
g (Just [ActorId]
l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
Bool -> Maybe [ActorId] -> Maybe [ActorId]
forall a. HasCallStack => Bool -> a -> a
assert (ActorId
aid ActorId -> [ActorId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ActorId]
l Bool -> (String, (ActorId, Actor, [ActorId])) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"actor already removed"
String
-> (ActorId, Actor, [ActorId])
-> (String, (ActorId, Actor, [ActorId]))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, [ActorId]
l))
#endif
(let l2 :: [ActorId]
l2 = ActorId -> [ActorId] -> [ActorId]
forall a. Eq a => a -> [a] -> [a]
delete ActorId
aid [ActorId]
l
in if [ActorId] -> Bool
forall a. [a] -> Bool
null [ActorId]
l2 then Maybe [ActorId]
forall a. Maybe a
Nothing else [ActorId] -> Maybe [ActorId]
forall a. a -> Maybe a
Just [ActorId]
l2)
let h :: Maybe ActorId -> Maybe ActorId
h Maybe ActorId
Nothing = String -> Maybe ActorId
forall a. HasCallStack => String -> a
error (String -> Maybe ActorId) -> String -> Maybe ActorId
forall a b. (a -> b) -> a -> b
$ String
"actor already removed" String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body)
h (Just ActorId
_aid2) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
Bool -> Maybe ActorId -> Maybe ActorId
forall a. HasCallStack => Bool -> a -> a
assert (ActorId
aid ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
== ActorId
_aid2 Bool -> (String, (ActorId, Actor, ActorId)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"actor already removed"
String
-> (ActorId, Actor, ActorId) -> (String, (ActorId, Actor, ActorId))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, ActorId
_aid2))
#endif
Maybe ActorId
forall a. Maybe a
Nothing
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel (Actor -> LevelId
blid Actor
body) ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ if Actor -> Bool
bproj Actor
body
then (ProjectileMap -> ProjectileMap) -> Level -> Level
updateProjMap ((Maybe [ActorId] -> Maybe [ActorId])
-> Point -> ProjectileMap -> ProjectileMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe [ActorId] -> Maybe [ActorId]
g (Actor -> Point
bpos Actor
body))
else (BigActorMap -> BigActorMap) -> Level -> Level
updateBigMap ((Maybe ActorId -> Maybe ActorId)
-> Point -> BigActorMap -> BigActorMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ActorId -> Maybe ActorId
h (Actor -> Point
bpos Actor
body))
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (ActorMaxSkills -> ActorMaxSkills) -> State -> State
updateActorMaxSkills ((ActorMaxSkills -> ActorMaxSkills) -> State -> State)
-> (ActorMaxSkills -> ActorMaxSkills) -> State -> State
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorMaxSkills -> ActorMaxSkills
forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EM.delete ActorId
aid
updSpotItem :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m ()
updSpotItem :: ItemId -> ItemQuant -> Container -> m ()
updSpotItem ItemId
iid kit :: ItemQuant
kit@(Int
k, ItemTimers
_) Container
c = do
Item
item <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
insertItemContainer ItemId
iid ItemQuant
kit Container
c
case Container
c of
CActor ActorId
aid CStore
store -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
store CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan])
(m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
item Int
k ActorId
aid
Container
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updLoseItem :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m ()
updLoseItem :: ItemId -> ItemQuant -> Container -> m ()
updLoseItem ItemId
iid kit :: ItemQuant
kit@(Int
k, ItemTimers
_) Container
c = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Item
item <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
deleteItemContainer ItemId
iid ItemQuant
kit Container
c
case Container
c of
CActor ActorId
aid CStore
store -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
store CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan])
(m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
item (-Int
k) ActorId
aid
Container
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updSpotItemBag :: MonadStateWrite m => Container -> ItemBag -> m ()
updSpotItemBag :: Container -> ItemBag -> m ()
updSpotItemBag Container
c ItemBag
bag =
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ItemBag -> Bool
forall k a. EnumMap k a -> Bool
EM.null ItemBag
bag) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ItemBag -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemBag -> Container -> m ()
insertBagContainer ItemBag
bag Container
c
case Container
c of
CActor ActorId
aid CStore
store ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
store CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan]) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
let ais :: [(ItemId, Item)]
ais = (ItemId -> (ItemId, Item)) -> [ItemId] -> [(ItemId, Item)]
forall a b. (a -> b) -> [a] -> [b]
map (\ItemId
iid -> (ItemId
iid, ItemDict
itemD ItemDict -> ItemId -> Item
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid)) ([ItemId] -> [(ItemId, Item)]) -> [ItemId] -> [(ItemId, Item)]
forall a b. (a -> b) -> a -> b
$ ItemBag -> [ItemId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys ItemBag
bag
[(ItemId, Item)] -> ((ItemId, Item) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [(ItemId, Item)]
ais (((ItemId, Item) -> m ()) -> m ())
-> ((ItemId, Item) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ItemId
iid, Item
item) ->
ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
item (ItemQuant -> Int
forall a b. (a, b) -> a
fst (ItemQuant -> Int) -> ItemQuant -> Int
forall a b. (a -> b) -> a -> b
$ ItemBag
bag ItemBag -> ItemId -> ItemQuant
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid) ActorId
aid
Container
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updLoseItemBag :: MonadStateWrite m => Container -> ItemBag -> m ()
updLoseItemBag :: Container -> ItemBag -> m ()
updLoseItemBag Container
c ItemBag
bag = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ItemBag -> Int
forall k a. EnumMap k a -> Int
EM.size ItemBag
bag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ItemBag -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemBag -> Container -> m ()
deleteBagContainer ItemBag
bag Container
c
case Container
c of
CActor ActorId
aid CStore
store ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
store CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan]) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
let ais :: [(ItemId, Item)]
ais = (ItemId -> (ItemId, Item)) -> [ItemId] -> [(ItemId, Item)]
forall a b. (a -> b) -> [a] -> [b]
map (\ItemId
iid -> (ItemId
iid, ItemDict
itemD ItemDict -> ItemId -> Item
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid)) ([ItemId] -> [(ItemId, Item)]) -> [ItemId] -> [(ItemId, Item)]
forall a b. (a -> b) -> a -> b
$ ItemBag -> [ItemId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys ItemBag
bag
[(ItemId, Item)] -> ((ItemId, Item) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [(ItemId, Item)]
ais (((ItemId, Item) -> m ()) -> m ())
-> ((ItemId, Item) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ItemId
iid, Item
item) ->
ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
item (- (ItemQuant -> Int
forall a b. (a, b) -> a
fst (ItemQuant -> Int) -> ItemQuant -> Int
forall a b. (a -> b) -> a -> b
$ ItemBag
bag ItemBag -> ItemId -> ItemQuant
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid)) ActorId
aid
Container
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m ()
updMoveActor :: ActorId -> Point -> Point -> m ()
updMoveActor ActorId
aid Point
fromP Point
toP = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Point
fromP Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
/= Point
toP) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Actor
body <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Point
fromP Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Point
bpos Actor
body
Bool -> (String, (ActorId, Point, Point, Point, Actor)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected moved actor position"
String
-> (ActorId, Point, Point, Point, Actor)
-> (String, (ActorId, Point, Point, Point, Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Point
fromP, Point
toP, Actor -> Point
bpos Actor
body, Actor
body)) ()
newBody :: Actor
newBody = Actor
body {bpos :: Point
bpos = Point
toP, boldpos :: Maybe Point
boldpos = Point -> Maybe Point
forall a. a -> Maybe a
Just Point
fromP}
ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ Actor -> Actor -> Actor
forall a b. a -> b -> a
const Actor
newBody
ActorId -> Actor -> Actor -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> Actor -> m ()
moveActorMap ActorId
aid Actor
body Actor
newBody
updWaitActor :: MonadStateWrite m
=> ActorId -> Watchfulness -> Watchfulness -> m ()
updWaitActor :: ActorId -> Watchfulness -> Watchfulness -> m ()
updWaitActor ActorId
aid Watchfulness
fromWS Watchfulness
toWS = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Watchfulness
fromWS Watchfulness -> Watchfulness -> Bool
forall a. Eq a => a -> a -> Bool
/= Watchfulness
toWS) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Actor
body <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Watchfulness
fromWS Watchfulness -> Watchfulness -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Watchfulness
bwatch Actor
body
Bool
-> (String, (ActorId, Watchfulness, Watchfulness, Actor)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor wait state"
String
-> (ActorId, Watchfulness, Watchfulness, Actor)
-> (String, (ActorId, Watchfulness, Watchfulness, Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Watchfulness
fromWS, Actor -> Watchfulness
bwatch Actor
body, Actor
body)) ()
ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ \Actor
b -> Actor
b {bwatch :: Watchfulness
bwatch = Watchfulness
toWS}
updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()
updDisplaceActor :: ActorId -> ActorId -> m ()
updDisplaceActor ActorId
source ActorId
target = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ActorId
source ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= ActorId
target) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Actor
sbody <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
Actor
tbody <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
target
let spos :: Point
spos = Actor -> Point
bpos Actor
sbody
tpos :: Point
tpos = Actor -> Point
bpos Actor
tbody
snewBody :: Actor
snewBody = Actor
sbody {bpos :: Point
bpos = Point
tpos, boldpos :: Maybe Point
boldpos = Point -> Maybe Point
forall a. a -> Maybe a
Just Point
spos}
tnewBody :: Actor
tnewBody = Actor
tbody {bpos :: Point
bpos = Point
spos, boldpos :: Maybe Point
boldpos = Point -> Maybe Point
forall a. a -> Maybe a
Just Point
tpos}
ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
source ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ Actor -> Actor -> Actor
forall a b. a -> b -> a
const Actor
snewBody
ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
target ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ Actor -> Actor -> Actor
forall a b. a -> b -> a
const Actor
tnewBody
ActorId -> Actor -> ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> ActorId -> Actor -> m ()
swapActorMap ActorId
source Actor
sbody ActorId
target Actor
tbody
updMoveItem :: MonadStateWrite m
=> ItemId -> Int -> ActorId -> CStore -> CStore
-> m ()
updMoveItem :: ItemId -> Int -> ActorId -> CStore -> CStore -> m ()
updMoveItem ItemId
iid Int
k ActorId
aid CStore
s1 CStore
s2 = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& CStore
s1 CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
/= CStore
s2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
ItemBag
bag <- (State -> ItemBag) -> m ItemBag
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemBag) -> m ItemBag)
-> (State -> ItemBag) -> m ItemBag
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> ItemBag
getBodyStoreBag Actor
b CStore
s1
case ItemId
iid ItemId -> ItemBag -> Maybe ItemQuant
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemBag
bag of
Maybe ItemQuant
Nothing -> String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String -> (ItemId, Int, ActorId, CStore, CStore) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemId
iid, Int
k, ActorId
aid, CStore
s1, CStore
s2)
Just (Int
_, ItemTimers
it) -> do
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
deleteItemActor ItemId
iid (Int
k, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
k ItemTimers
it) ActorId
aid CStore
s1
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
insertItemActor ItemId
iid (Int
k, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
k ItemTimers
it) ActorId
aid CStore
s2
case CStore
s1 of
CStore
CEqp -> case CStore
s2 of
CStore
COrgan -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CStore
_ -> do
Item
itemBase <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
itemBase (-Int
k) ActorId
aid
CStore
COrgan -> case CStore
s2 of
CStore
CEqp -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CStore
_ -> do
Item
itemBase <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
itemBase (-Int
k) ActorId
aid
CStore
_ ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
s2 CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan]) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Item
itemBase <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
itemBase Int
k ActorId
aid
updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillHP :: ActorId -> Int64 -> m ()
updRefillHP ActorId
aid Int64
nRaw =
ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ \Actor
b ->
let newRawHP :: Int64
newRawHP = Actor -> Int64
bhp Actor
b Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
nRaw
newHP :: Int64
newHP = if Actor -> Int64
bhp Actor
b Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0 then Int64
newRawHP else Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max Int64
0 Int64
newRawHP
n :: Int64
n = Int64
newHP Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Actor -> Int64
bhp Actor
b
in Actor
b { bhp :: Int64
bhp = Int64
newHP
, bhpDelta :: ResDelta
bhpDelta = let oldD :: ResDelta
oldD = Actor -> ResDelta
bhpDelta Actor
b
in case Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int64
n Int64
0 of
Ordering
EQ -> ResDelta :: (Int64, Int64) -> (Int64, Int64) -> ResDelta
ResDelta { resCurrentTurn :: (Int64, Int64)
resCurrentTurn = (Int64
0, Int64
0)
, resPreviousTurn :: (Int64, Int64)
resPreviousTurn = ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD }
Ordering
LT -> ResDelta
oldD {resCurrentTurn :: (Int64, Int64)
resCurrentTurn =
( (Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n
, (Int64, Int64) -> Int64
forall a b. (a, b) -> b
snd (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) )}
Ordering
GT -> ResDelta
oldD {resCurrentTurn :: (Int64, Int64)
resCurrentTurn =
( (Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD)
, (Int64, Int64) -> Int64
forall a b. (a, b) -> b
snd (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n )}
}
updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillCalm :: ActorId -> Int64 -> m ()
updRefillCalm ActorId
aid Int64
n =
ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ \Actor
b ->
Actor
b { bcalm :: Int64
bcalm = Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max Int64
0 (Int64 -> Int64) -> Int64 -> Int64
forall a b. (a -> b) -> a -> b
$ Actor -> Int64
bcalm Actor
b Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n
, bcalmDelta :: ResDelta
bcalmDelta = let oldD :: ResDelta
oldD = Actor -> ResDelta
bcalmDelta Actor
b
in case Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int64
n Int64
0 of
Ordering
EQ -> ResDelta :: (Int64, Int64) -> (Int64, Int64) -> ResDelta
ResDelta { resCurrentTurn :: (Int64, Int64)
resCurrentTurn = (Int64
0, Int64
0)
, resPreviousTurn :: (Int64, Int64)
resPreviousTurn = ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD }
Ordering
LT -> ResDelta
oldD {resCurrentTurn :: (Int64, Int64)
resCurrentTurn =
( (Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n
, (Int64, Int64) -> Int64
forall a b. (a, b) -> b
snd (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) )}
Ordering
GT -> ResDelta
oldD {resCurrentTurn :: (Int64, Int64)
resCurrentTurn =
( (Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD)
, (Int64, Int64) -> Int64
forall a b. (a, b) -> b
snd (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n )}
}
updTrajectory :: MonadStateWrite m
=> ActorId
-> Maybe ([Vector], Speed)
-> Maybe ([Vector], Speed)
-> m ()
updTrajectory :: ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> m ()
updTrajectory ActorId
aid Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed)
toT = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ([Vector], Speed)
toT) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Actor
body <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Maybe ([Vector], Speed)
btrajectory Actor
body
Bool
-> (String,
(ActorId, Maybe ([Vector], Speed), Maybe ([Vector], Speed), Actor))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor trajectory"
String
-> (ActorId, Maybe ([Vector], Speed), Maybe ([Vector], Speed),
Actor)
-> (String,
(ActorId, Maybe ([Vector], Speed), Maybe ([Vector], Speed), Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Maybe ([Vector], Speed)
fromT, Maybe ([Vector], Speed)
toT, Actor
body)) ()
ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ \Actor
b -> Actor
b {btrajectory :: Maybe ([Vector], Speed)
btrajectory = Maybe ([Vector], Speed)
toT}
updQuitFaction :: MonadStateWrite m
=> FactionId -> Maybe Status -> Maybe Status
-> m ()
updQuitFaction :: FactionId -> Maybe Status -> Maybe Status -> m ()
updQuitFaction FactionId
fid Maybe Status
fromSt Maybe Status
toSt = do
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Status
fromSt Maybe Status -> Maybe Status -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Status
toSt Bool -> (FactionId, Maybe Status, Maybe Status) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (FactionId
fid, Maybe Status
fromSt, Maybe Status
toSt)) ()
Faction
fact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Status
fromSt Maybe Status -> Maybe Status -> Bool
forall a. Eq a => a -> a -> Bool
== Faction -> Maybe Status
gquit Faction
fact
Bool
-> (String, (FactionId, Maybe Status, Maybe Status, Faction))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor quit status"
String
-> (FactionId, Maybe Status, Maybe Status, Faction)
-> (String, (FactionId, Maybe Status, Maybe Status, Faction))
forall v. String -> v -> (String, v)
`swith` (FactionId
fid, Maybe Status
fromSt, Maybe Status
toSt, Faction
fact)) ()
let adj :: Faction -> Faction
adj Faction
fa = Faction
fa {gquit :: Maybe Status
gquit = Maybe Status
toSt}
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj
updSpotStashFaction :: MonadStateWrite m
=> FactionId -> LevelId -> Point -> m ()
updSpotStashFaction :: FactionId -> LevelId -> Point -> m ()
updSpotStashFaction FactionId
fid LevelId
lid Point
pos = do
let adj :: Faction -> Faction
adj Faction
fa = Faction
fa {gstash :: Maybe (LevelId, Point)
gstash = (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (LevelId
lid, Point
pos)}
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj
updLoseStashFaction :: MonadStateWrite m
=> FactionId -> LevelId -> Point -> m ()
updLoseStashFaction :: FactionId -> LevelId -> Point -> m ()
updLoseStashFaction FactionId
fid LevelId
lid Point
pos = do
let adj :: Faction -> Faction
adj Faction
fa = Bool -> Faction -> Faction
forall a. HasCallStack => Bool -> a -> a
assert (Faction -> Maybe (LevelId, Point)
gstash Faction
fa Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (LevelId
lid, Point
pos)
Bool -> (String, (FactionId, LevelId, Point, Faction)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected lack of gstash"
String
-> (FactionId, LevelId, Point, Faction)
-> (String, (FactionId, LevelId, Point, Faction))
forall v. String -> v -> (String, v)
`swith` (FactionId
fid, LevelId
lid, Point
pos, Faction
fa))
(Faction -> Faction) -> Faction -> Faction
forall a b. (a -> b) -> a -> b
$ Faction
fa {gstash :: Maybe (LevelId, Point)
gstash = Maybe (LevelId, Point)
forall a. Maybe a
Nothing}
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj
updLeadFaction :: MonadStateWrite m
=> FactionId
-> Maybe ActorId
-> Maybe ActorId
-> m ()
updLeadFaction :: FactionId -> Maybe ActorId -> Maybe ActorId -> m ()
updLeadFaction FactionId
fid Maybe ActorId
source Maybe ActorId
target = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe ActorId
source Maybe ActorId -> Maybe ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ActorId
target) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Faction
fact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Player -> Maybe AutoLeader
fleaderMode (Faction -> Player
gplayer Faction
fact) Maybe AutoLeader -> Maybe AutoLeader -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe AutoLeader
forall a. Maybe a
Nothing) ()
Maybe Actor
mtb <- (State -> Maybe Actor) -> m (Maybe Actor)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe Actor) -> m (Maybe Actor))
-> (State -> Maybe Actor) -> m (Maybe Actor)
forall a b. (a -> b) -> a -> b
$ \State
s -> (ActorId -> State -> Actor) -> State -> ActorId -> Actor
forall a b c. (a -> b -> c) -> b -> a -> c
flip ActorId -> State -> Actor
getActorBody State
s (ActorId -> Actor) -> Maybe ActorId -> Maybe Actor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ActorId
target
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> (Actor -> Bool) -> Maybe Actor -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (Actor -> Bool) -> Actor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Actor -> Bool
bproj) Maybe Actor
mtb
Bool
-> (FactionId, Maybe ActorId, Maybe ActorId, Maybe Actor, Faction)
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (FactionId
fid, Maybe ActorId
source, Maybe ActorId
target, Maybe Actor
mtb, Faction
fact)) ()
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe ActorId
source Maybe ActorId -> Maybe ActorId -> Bool
forall a. Eq a => a -> a -> Bool
== Faction -> Maybe ActorId
gleader Faction
fact
Bool
-> (String,
(FactionId, Maybe ActorId, Maybe ActorId, Maybe Actor, Faction))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor leader"
String
-> (FactionId, Maybe ActorId, Maybe ActorId, Maybe Actor, Faction)
-> (String,
(FactionId, Maybe ActorId, Maybe ActorId, Maybe Actor, Faction))
forall v. String -> v -> (String, v)
`swith` (FactionId
fid, Maybe ActorId
source, Maybe ActorId
target, Maybe Actor
mtb, Faction
fact)) ()
let adj :: Faction -> Faction
adj Faction
fa = Faction
fa {_gleader :: Maybe ActorId
_gleader = Maybe ActorId
target}
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj
updDiplFaction :: MonadStateWrite m
=> FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
updDiplFaction :: FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
updDiplFaction FactionId
fid1 FactionId
fid2 Diplomacy
fromDipl Diplomacy
toDipl =
Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (FactionId
fid1 FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
/= FactionId
fid2 Bool -> Bool -> Bool
&& Diplomacy
fromDipl Diplomacy -> Diplomacy -> Bool
forall a. Eq a => a -> a -> Bool
/= Diplomacy
toDipl) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Faction
fact1 <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid1) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
Faction
fact2 <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid2) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
let !_A :: ()
_A =
Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Diplomacy
fromDipl Diplomacy -> Diplomacy -> Bool
forall a. Eq a => a -> a -> Bool
== Diplomacy -> FactionId -> EnumMap FactionId Diplomacy -> Diplomacy
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault Diplomacy
Unknown FactionId
fid2 (Faction -> EnumMap FactionId Diplomacy
gdipl Faction
fact1)
Bool -> Bool -> Bool
&& Diplomacy
fromDipl Diplomacy -> Diplomacy -> Bool
forall a. Eq a => a -> a -> Bool
== Diplomacy -> FactionId -> EnumMap FactionId Diplomacy -> Diplomacy
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault Diplomacy
Unknown FactionId
fid1 (Faction -> EnumMap FactionId Diplomacy
gdipl Faction
fact2)
Bool
-> (String,
(FactionId, FactionId, Diplomacy, Diplomacy, Faction, Faction))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor diplomacy status"
String
-> (FactionId, FactionId, Diplomacy, Diplomacy, Faction, Faction)
-> (String,
(FactionId, FactionId, Diplomacy, Diplomacy, Faction, Faction))
forall v. String -> v -> (String, v)
`swith` (FactionId
fid1, FactionId
fid2, Diplomacy
fromDipl, Diplomacy
toDipl, Faction
fact1, Faction
fact2)) ()
let adj :: FactionId -> Faction -> Faction
adj FactionId
fid Faction
fact = Faction
fact {gdipl :: EnumMap FactionId Diplomacy
gdipl = FactionId
-> Diplomacy
-> EnumMap FactionId Diplomacy
-> EnumMap FactionId Diplomacy
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
fid Diplomacy
toDipl (Faction -> EnumMap FactionId Diplomacy
gdipl Faction
fact)}
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid1 (FactionId -> Faction -> Faction
adj FactionId
fid2)
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid2 (FactionId -> Faction -> Faction
adj FactionId
fid1)
updDoctrineFaction :: MonadStateWrite m
=> FactionId -> Ability.Doctrine -> Ability.Doctrine -> m ()
updDoctrineFaction :: FactionId -> Doctrine -> Doctrine -> m ()
updDoctrineFaction FactionId
fid Doctrine
toT Doctrine
fromT = do
let adj :: Faction -> Faction
adj Faction
fact =
let player :: Player
player = Faction -> Player
gplayer Faction
fact
in Bool -> Faction -> Faction
forall a. HasCallStack => Bool -> a -> a
assert (Player -> Doctrine
fdoctrine Player
player Doctrine -> Doctrine -> Bool
forall a. Eq a => a -> a -> Bool
== Doctrine
fromT)
(Faction -> Faction) -> Faction -> Faction
forall a b. (a -> b) -> a -> b
$ Faction
fact {gplayer :: Player
gplayer = Player
player {fdoctrine :: Doctrine
fdoctrine = Doctrine
toT}}
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj
updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()
updAutoFaction :: FactionId -> Bool -> m ()
updAutoFaction FactionId
fid Bool
st =
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid (\Faction
fact ->
Bool -> Faction -> Faction
forall a. HasCallStack => Bool -> a -> a
assert (Faction -> Bool
isAIFact Faction
fact Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Bool
not Bool
st)
(Faction -> Faction) -> Faction -> Faction
forall a b. (a -> b) -> a -> b
$ Faction
fact {gplayer :: Player
gplayer = Bool -> Player -> Player
automatePlayer Bool
st (Faction -> Player
gplayer Faction
fact)})
updRecordKill :: MonadStateWrite m
=> ActorId -> ContentId ItemKind -> Int -> m ()
updRecordKill :: ActorId -> ContentId ItemKind -> Int -> m ()
updRecordKill ActorId
aid ContentId ItemKind
ikind Int
k = do
Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
let !_A :: Any -> Any
_A = Bool -> Any -> Any
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Actor -> Bool
bproj Actor
b) Bool -> (ActorId, Actor) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ActorId
aid, Actor
b))
let alterKind :: Maybe Int -> Maybe Int
alterKind Maybe Int
mn = let n :: Int
n = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
mn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k
in if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe Int
forall a. Maybe a
Nothing else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
adjFact :: Faction -> Faction
adjFact Faction
fact = Faction
fact {gvictims :: EnumMap (ContentId ItemKind) Int
gvictims = (Maybe Int -> Maybe Int)
-> ContentId ItemKind
-> EnumMap (ContentId ItemKind) Int
-> EnumMap (ContentId ItemKind) Int
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Int -> Maybe Int
alterKind ContentId ItemKind
ikind
(EnumMap (ContentId ItemKind) Int
-> EnumMap (ContentId ItemKind) Int)
-> EnumMap (ContentId ItemKind) Int
-> EnumMap (ContentId ItemKind) Int
forall a b. (a -> b) -> a -> b
$ Faction -> EnumMap (ContentId ItemKind) Int
gvictims Faction
fact}
FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction (Actor -> FactionId
bfid Actor
b) Faction -> Faction
adjFact
updAlterTile :: MonadStateWrite m
=> LevelId -> Point -> ContentId TileKind -> ContentId TileKind
-> m ()
updAlterTile :: LevelId
-> Point -> ContentId TileKind -> ContentId TileKind -> m ()
updAlterTile LevelId
lid Point
p ContentId TileKind
fromTile ContentId TileKind
toTile = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ContentId TileKind
fromTile ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
/= ContentId TileKind
toTile) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
COps{TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
let t :: ContentId TileKind
t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
p
if ContentId TileKind
t ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
/= ContentId TileKind
fromTile
then String -> m ()
forall a. String -> a
atomicFail String
"terrain to modify is different than assumed"
else do
let adj :: Array (ContentId TileKind) -> Array (ContentId TileKind)
adj Array (ContentId TileKind)
ts = Array (ContentId TileKind)
ts Array (ContentId TileKind)
-> [(Point, ContentId TileKind)] -> Array (ContentId TileKind)
forall c. UnboxRepClass c => Array c -> [(Point, c)] -> Array c
PointArray.// [(Point
p, ContentId TileKind
toTile)]
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Level -> Level
updateTile Array (ContentId TileKind) -> Array (ContentId TileKind)
adj
case ( TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
fromTile
, TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
toTile ) of
(Bool
False, Bool
True) -> LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl2 -> Level
lvl2 {lseen :: Int
lseen = Level -> Int
lseen Level
lvl2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
(Bool
True, Bool
False) -> LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl2 -> Level
lvl2 {lseen :: Int
lseen = Level -> Int
lseen Level
lvl2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
(Bool, Bool)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updAlterExplorable :: MonadStateWrite m => LevelId -> Int -> m ()
updAlterExplorable :: LevelId -> Int -> m ()
updAlterExplorable LevelId
lid Int
delta = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
delta Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl -> Level
lvl {lexpl :: Int
lexpl = Level -> Int
lexpl Level
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta}
updAlterGold :: MonadStateWrite m => Int -> m ()
updAlterGold :: Int -> m ()
updAlterGold Int
delta = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
delta Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> State -> State
updateGold (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta)
updSearchTile :: MonadStateWrite m
=> ActorId -> Point -> ContentId TileKind -> m ()
updSearchTile :: ActorId -> Point -> ContentId TileKind -> m ()
updSearchTile ActorId
aid Point
p ContentId TileKind
toTile = do
COps{ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b
let t :: ContentId TileKind
t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
p
if ContentId TileKind
t ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
== ContentId TileKind
toTile
then String -> m ()
forall a. String -> a
atomicFail String
"tile already searched"
else Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ContentId TileKind -> Maybe (ContentId TileKind)
forall a. a -> Maybe a
Just ContentId TileKind
t Maybe (ContentId TileKind) -> Maybe (ContentId TileKind) -> Bool
forall a. Eq a => a -> a -> Bool
== ContentData TileKind
-> ContentId TileKind -> Maybe (ContentId TileKind)
Tile.hideAs ContentData TileKind
cotile ContentId TileKind
toTile) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
LevelId -> [(Point, ContentId TileKind)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile (Actor -> LevelId
blid Actor
b) [(Point
p, ContentId TileKind
t)]
LevelId -> [(Point, ContentId TileKind)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile (Actor -> LevelId
blid Actor
b) [(Point
p, ContentId TileKind
toTile)]
updSpotTile :: MonadStateWrite m
=> LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile :: LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile LevelId
lid [(Point, ContentId TileKind)]
ts = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, ContentId TileKind)] -> Bool
forall a. [a] -> Bool
null [(Point, ContentId TileKind)]
ts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
let unk :: Array (ContentId TileKind) -> (Point, b) -> Bool
unk Array (ContentId TileKind)
tileMap (Point
p, b
_) = Array (ContentId TileKind)
tileMap Array (ContentId TileKind) -> Point -> ContentId TileKind
forall c. UnboxRepClass c => Array c -> Point -> c
PointArray.! Point
p ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
== ContentId TileKind
unknownId
adj :: Array (ContentId TileKind) -> Array (ContentId TileKind)
adj Array (ContentId TileKind)
tileMap = Bool -> Array (ContentId TileKind) -> Array (ContentId TileKind)
forall a. HasCallStack => Bool -> a -> a
assert (((Point, ContentId TileKind) -> Bool)
-> [(Point, ContentId TileKind)] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (Array (ContentId TileKind) -> (Point, ContentId TileKind) -> Bool
forall b. Array (ContentId TileKind) -> (Point, b) -> Bool
unk Array (ContentId TileKind)
tileMap) [(Point, ContentId TileKind)]
ts)
(Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Array (ContentId TileKind) -> Array (ContentId TileKind)
forall a b. (a -> b) -> a -> b
$ Array (ContentId TileKind)
tileMap Array (ContentId TileKind)
-> [(Point, ContentId TileKind)] -> Array (ContentId TileKind)
forall c. UnboxRepClass c => Array c -> [(Point, c)] -> Array c
PointArray.// [(Point, ContentId TileKind)]
ts
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Level -> Level
updateTile Array (ContentId TileKind) -> Array (ContentId TileKind)
adj
let f :: (Point, ContentId TileKind) -> m ()
f (Point
_, ContentId TileKind
t1) = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
t1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl -> Level
lvl {lseen :: Int
lseen = Level -> Int
lseen Level
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
((Point, ContentId TileKind) -> m ())
-> [(Point, ContentId TileKind)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Point, ContentId TileKind) -> m ()
f [(Point, ContentId TileKind)]
ts
updLoseTile :: MonadStateWrite m
=> LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile :: LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile LevelId
lid [(Point, ContentId TileKind)]
ts = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, ContentId TileKind)] -> Bool
forall a. [a] -> Bool
null [(Point, ContentId TileKind)]
ts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
let matches :: Array a -> (Point, a) -> Bool
matches Array a
tileMap (Point
p, a
ov) = Array a
tileMap Array a -> Point -> a
forall c. UnboxRepClass c => Array c -> Point -> c
PointArray.! Point
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ov
tu :: [(Point, ContentId TileKind)]
tu = ((Point, ContentId TileKind) -> (Point, ContentId TileKind))
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a b. (a -> b) -> [a] -> [b]
map ((ContentId TileKind -> ContentId TileKind)
-> (Point, ContentId TileKind) -> (Point, ContentId TileKind)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (ContentId TileKind -> ContentId TileKind -> ContentId TileKind
forall a b. a -> b -> a
const ContentId TileKind
unknownId)) [(Point, ContentId TileKind)]
ts
adj :: Array (ContentId TileKind) -> Array (ContentId TileKind)
adj Array (ContentId TileKind)
tileMap = Bool -> Array (ContentId TileKind) -> Array (ContentId TileKind)
forall a. HasCallStack => Bool -> a -> a
assert (((Point, ContentId TileKind) -> Bool)
-> [(Point, ContentId TileKind)] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (Array (ContentId TileKind) -> (Point, ContentId TileKind) -> Bool
forall a. UnboxRepClass a => Array a -> (Point, a) -> Bool
matches Array (ContentId TileKind)
tileMap) [(Point, ContentId TileKind)]
ts)
(Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Array (ContentId TileKind) -> Array (ContentId TileKind)
forall a b. (a -> b) -> a -> b
$ Array (ContentId TileKind)
tileMap Array (ContentId TileKind)
-> [(Point, ContentId TileKind)] -> Array (ContentId TileKind)
forall c. UnboxRepClass c => Array c -> [(Point, c)] -> Array c
PointArray.// [(Point, ContentId TileKind)]
tu
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Level -> Level
updateTile Array (ContentId TileKind) -> Array (ContentId TileKind)
adj
let f :: (Point, ContentId TileKind) -> m ()
f (Point
_, ContentId TileKind
t1) = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
t1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl -> Level
lvl {lseen :: Int
lseen = Level -> Int
lseen Level
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
((Point, ContentId TileKind) -> m ())
-> [(Point, ContentId TileKind)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Point, ContentId TileKind) -> m ()
f [(Point, ContentId TileKind)]
ts
updSpotEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()
updSpotEntry :: LevelId -> [(Point, PlaceEntry)] -> m ()
updSpotEntry LevelId
lid [(Point, PlaceEntry)]
ts = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, PlaceEntry)] -> Bool
forall a. [a] -> Bool
null [(Point, PlaceEntry)]
ts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let alt :: PlaceEntry -> Maybe PlaceEntry -> Maybe PlaceEntry
alt PlaceEntry
en Maybe PlaceEntry
Nothing = PlaceEntry -> Maybe PlaceEntry
forall a. a -> Maybe a
Just PlaceEntry
en
alt PlaceEntry
en (Just PlaceEntry
oldEn) = String -> Maybe PlaceEntry
forall a. String -> a
atomicFail (String -> Maybe PlaceEntry) -> String -> Maybe PlaceEntry
forall a b. (a -> b) -> a -> b
$ String
"entry already added"
String
-> (LevelId, [(Point, PlaceEntry)], PlaceEntry, PlaceEntry)
-> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, [(Point, PlaceEntry)]
ts, PlaceEntry
en, PlaceEntry
oldEn)
f :: (Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
f (Point
p, PlaceEntry
en) = (Maybe PlaceEntry -> Maybe PlaceEntry)
-> Point -> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (PlaceEntry -> Maybe PlaceEntry -> Maybe PlaceEntry
alt PlaceEntry
en) Point
p
upd :: EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
upd EnumMap Point PlaceEntry
m = ((Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry)
-> EnumMap Point PlaceEntry
-> [(Point, PlaceEntry)]
-> EnumMap Point PlaceEntry
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
f EnumMap Point PlaceEntry
m [(Point, PlaceEntry)]
ts
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry)
-> Level -> Level
updateEntry EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
upd
updLoseEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()
updLoseEntry :: LevelId -> [(Point, PlaceEntry)] -> m ()
updLoseEntry LevelId
lid [(Point, PlaceEntry)]
ts = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, PlaceEntry)] -> Bool
forall a. [a] -> Bool
null [(Point, PlaceEntry)]
ts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let alt :: PlaceEntry -> Maybe PlaceEntry -> Maybe PlaceEntry
alt PlaceEntry
en Maybe PlaceEntry
Nothing = String -> Maybe PlaceEntry
forall a. HasCallStack => String -> a
error (String -> Maybe PlaceEntry) -> String -> Maybe PlaceEntry
forall a b. (a -> b) -> a -> b
$ String
"entry already removed"
String -> (LevelId, [(Point, PlaceEntry)], PlaceEntry) -> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, [(Point, PlaceEntry)]
ts, PlaceEntry
en)
alt PlaceEntry
en (Just PlaceEntry
oldEn) =
Bool -> Maybe PlaceEntry -> Maybe PlaceEntry
forall a. HasCallStack => Bool -> a -> a
assert (PlaceEntry
en PlaceEntry -> PlaceEntry -> Bool
forall a. Eq a => a -> a -> Bool
== PlaceEntry
oldEn Bool
-> (String,
(LevelId, [(Point, PlaceEntry)], PlaceEntry, PlaceEntry))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected lost entry"
String
-> (LevelId, [(Point, PlaceEntry)], PlaceEntry, PlaceEntry)
-> (String,
(LevelId, [(Point, PlaceEntry)], PlaceEntry, PlaceEntry))
forall v. String -> v -> (String, v)
`swith` (LevelId
lid, [(Point, PlaceEntry)]
ts, PlaceEntry
en, PlaceEntry
oldEn)) Maybe PlaceEntry
forall a. Maybe a
Nothing
f :: (Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
f (Point
p, PlaceEntry
en) = (Maybe PlaceEntry -> Maybe PlaceEntry)
-> Point -> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (PlaceEntry -> Maybe PlaceEntry -> Maybe PlaceEntry
alt PlaceEntry
en) Point
p
upd :: EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
upd EnumMap Point PlaceEntry
m = ((Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry)
-> EnumMap Point PlaceEntry
-> [(Point, PlaceEntry)]
-> EnumMap Point PlaceEntry
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
f EnumMap Point PlaceEntry
m [(Point, PlaceEntry)]
ts
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry)
-> Level -> Level
updateEntry EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
upd
updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m ()
updAlterSmell :: LevelId -> Point -> Time -> Time -> m ()
updAlterSmell LevelId
lid Point
p Time
fromSm' Time
toSm' = do
let fromSm :: Maybe Time
fromSm = if Time
fromSm' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
timeZero then Maybe Time
forall a. Maybe a
Nothing else Time -> Maybe Time
forall a. a -> Maybe a
Just Time
fromSm'
toSm :: Maybe Time
toSm = if Time
toSm' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
timeZero then Maybe Time
forall a. Maybe a
Nothing else Time -> Maybe Time
forall a. a -> Maybe a
Just Time
toSm'
alt :: Maybe Time -> Maybe Time
alt Maybe Time
sm = Bool -> Maybe Time -> Maybe Time
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Time
sm Maybe Time -> Maybe Time -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Time
fromSm Bool
-> (String, (LevelId, Point, Maybe Time, Maybe Time, Maybe Time))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected tile smell"
String
-> (LevelId, Point, Maybe Time, Maybe Time, Maybe Time)
-> (String, (LevelId, Point, Maybe Time, Maybe Time, Maybe Time))
forall v. String -> v -> (String, v)
`swith` (LevelId
lid, Point
p, Maybe Time
fromSm, Maybe Time
toSm, Maybe Time
sm)) Maybe Time
toSm
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (SmellMap -> SmellMap) -> Level -> Level
updateSmell ((SmellMap -> SmellMap) -> Level -> Level)
-> (SmellMap -> SmellMap) -> Level -> Level
forall a b. (a -> b) -> a -> b
$ (Maybe Time -> Maybe Time) -> Point -> SmellMap -> SmellMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Time -> Maybe Time
alt Point
p
updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()
updSpotSmell :: LevelId -> [(Point, Time)] -> m ()
updSpotSmell LevelId
lid [(Point, Time)]
sms = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, Time)] -> Bool
forall a. [a] -> Bool
null [(Point, Time)]
sms) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let alt :: Time -> Maybe Time -> Maybe Time
alt Time
sm Maybe Time
Nothing = Time -> Maybe Time
forall a. a -> Maybe a
Just Time
sm
alt Time
sm (Just Time
oldSm) = String -> Maybe Time
forall a. HasCallStack => String -> a
error (String -> Maybe Time) -> String -> Maybe Time
forall a b. (a -> b) -> a -> b
$ String
"smell already added"
String -> (LevelId, [(Point, Time)], Time, Time) -> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, [(Point, Time)]
sms, Time
sm, Time
oldSm)
f :: (Point, Time) -> SmellMap -> SmellMap
f (Point
p, Time
sm) = (Maybe Time -> Maybe Time) -> Point -> SmellMap -> SmellMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (Time -> Maybe Time -> Maybe Time
alt Time
sm) Point
p
upd :: SmellMap -> SmellMap
upd SmellMap
m = ((Point, Time) -> SmellMap -> SmellMap)
-> SmellMap -> [(Point, Time)] -> SmellMap
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point, Time) -> SmellMap -> SmellMap
f SmellMap
m [(Point, Time)]
sms
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (SmellMap -> SmellMap) -> Level -> Level
updateSmell SmellMap -> SmellMap
upd
updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()
updLoseSmell :: LevelId -> [(Point, Time)] -> m ()
updLoseSmell LevelId
lid [(Point, Time)]
sms = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, Time)] -> Bool
forall a. [a] -> Bool
null [(Point, Time)]
sms) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let alt :: Time -> Maybe Time -> Maybe Time
alt Time
sm Maybe Time
Nothing = String -> Maybe Time
forall a. HasCallStack => String -> a
error (String -> Maybe Time) -> String -> Maybe Time
forall a b. (a -> b) -> a -> b
$ String
"smell already removed"
String -> (LevelId, [(Point, Time)], Time) -> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, [(Point, Time)]
sms, Time
sm)
alt Time
sm (Just Time
oldSm) =
Bool -> Maybe Time -> Maybe Time
forall a. HasCallStack => Bool -> a -> a
assert (Time
sm Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
oldSm Bool -> (String, (LevelId, [(Point, Time)], Time, Time)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected lost smell"
String
-> (LevelId, [(Point, Time)], Time, Time)
-> (String, (LevelId, [(Point, Time)], Time, Time))
forall v. String -> v -> (String, v)
`swith` (LevelId
lid, [(Point, Time)]
sms, Time
sm, Time
oldSm)) Maybe Time
forall a. Maybe a
Nothing
f :: (Point, Time) -> SmellMap -> SmellMap
f (Point
p, Time
sm) = (Maybe Time -> Maybe Time) -> Point -> SmellMap -> SmellMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (Time -> Maybe Time -> Maybe Time
alt Time
sm) Point
p
upd :: SmellMap -> SmellMap
upd SmellMap
m = ((Point, Time) -> SmellMap -> SmellMap)
-> SmellMap -> [(Point, Time)] -> SmellMap
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point, Time) -> SmellMap -> SmellMap
f SmellMap
m [(Point, Time)]
sms
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (SmellMap -> SmellMap) -> Level -> Level
updateSmell SmellMap -> SmellMap
upd
updTimeItem :: MonadStateWrite m
=> ItemId -> Container -> ItemTimers -> ItemTimers
-> m ()
updTimeItem :: ItemId -> Container -> ItemTimers -> ItemTimers -> m ()
updTimeItem ItemId
iid Container
c ItemTimers
fromIt ItemTimers
toIt = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimers
fromIt ItemTimers -> ItemTimers -> Bool
forall a. Eq a => a -> a -> Bool
/= ItemTimers
toIt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ItemBag
bag <- (State -> ItemBag) -> m ItemBag
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemBag) -> m ItemBag)
-> (State -> ItemBag) -> m ItemBag
forall a b. (a -> b) -> a -> b
$ Container -> State -> ItemBag
getContainerBag Container
c
case ItemId
iid ItemId -> ItemBag -> Maybe ItemQuant
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemBag
bag of
Just (Int
k, ItemTimers
it) -> do
let !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimers
fromIt ItemTimers -> ItemTimers -> Bool
forall a. Eq a => a -> a -> Bool
== ItemTimers
it Bool
-> (Int, ItemTimers, ItemId, Container, ItemTimers, ItemTimers)
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (Int
k, ItemTimers
it, ItemId
iid, Container
c, ItemTimers
fromIt, ItemTimers
toIt)) ()
!_A2 :: ()
_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimers -> Int
forall a. [a] -> Int
length ItemTimers
toIt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k Bool -> (Int, ItemTimers, ItemId, Container, ItemTimers) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (Int
k, ItemTimers
toIt, ItemId
iid, Container
c, ItemTimers
fromIt)) ()
ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
deleteItemContainer ItemId
iid (Int
k, ItemTimers
fromIt) Container
c
ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
insertItemContainer ItemId
iid (Int
k, ItemTimers
toIt) Container
c
Maybe ItemQuant
Nothing -> String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String
-> (ItemBag, ItemId, Container, ItemTimers, ItemTimers) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemBag
bag, ItemId
iid, Container
c, ItemTimers
fromIt, ItemTimers
toIt)
updAgeGame :: MonadStateWrite m => ES.EnumSet LevelId -> m ()
updAgeGame :: EnumSet LevelId -> m ()
updAgeGame EnumSet LevelId
lids = do
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (Time -> Time) -> State -> State
updateTime ((Time -> Time) -> State -> State)
-> (Time -> Time) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Time -> Delta Time -> Time) -> Delta Time -> Time -> Time
forall a b c. (a -> b -> c) -> b -> a -> c
flip Time -> Delta Time -> Time
timeShift (Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)
(LevelId -> m ()) -> [LevelId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Delta Time -> LevelId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Delta Time -> LevelId -> m ()
ageLevel (Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)) ([LevelId] -> m ()) -> [LevelId] -> m ()
forall a b. (a -> b) -> a -> b
$ EnumSet LevelId -> [LevelId]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet LevelId
lids
updUnAgeGame :: MonadStateWrite m => ES.EnumSet LevelId -> m ()
updUnAgeGame :: EnumSet LevelId -> m ()
updUnAgeGame EnumSet LevelId
lids = do
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (Time -> Time) -> State -> State
updateTime ((Time -> Time) -> State -> State)
-> (Time -> Time) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Time -> Delta Time -> Time) -> Delta Time -> Time -> Time
forall a b c. (a -> b -> c) -> b -> a -> c
flip Time -> Delta Time -> Time
timeShift (Delta Time -> Delta Time
timeDeltaReverse (Delta Time -> Delta Time) -> Delta Time -> Delta Time
forall a b. (a -> b) -> a -> b
$ Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)
(LevelId -> m ()) -> [LevelId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Delta Time -> LevelId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Delta Time -> LevelId -> m ()
ageLevel (Delta Time -> Delta Time
timeDeltaReverse (Delta Time -> Delta Time) -> Delta Time -> Delta Time
forall a b. (a -> b) -> a -> b
$ Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)) ([LevelId] -> m ()) -> [LevelId] -> m ()
forall a b. (a -> b) -> a -> b
$ EnumSet LevelId -> [LevelId]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet LevelId
lids
ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m ()
ageLevel :: Delta Time -> LevelId -> m ()
ageLevel Delta Time
delta LevelId
lid =
LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl -> Level
lvl {ltime :: Time
ltime = Time -> Delta Time -> Time
timeShift (Level -> Time
ltime Level
lvl) Delta Time
delta}
updDiscover :: MonadStateWrite m
=> Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord
-> m ()
updDiscover :: Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
updDiscover Container
_c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem = do
ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
COps{ItemSpeedup
coItemSpeedup :: COps -> ItemSpeedup
coItemSpeedup :: ItemSpeedup
coItemSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
let kmIsConst :: Bool
kmIsConst = KindMean -> Bool
IA.kmConst (KindMean -> Bool) -> KindMean -> Bool
forall a b. (a -> b) -> a -> b
$ ContentId ItemKind -> ItemSpeedup -> KindMean
getKindMean ContentId ItemKind
ik ItemSpeedup
coItemSpeedup
DiscoveryKind
discoKind <- (State -> DiscoveryKind) -> m DiscoveryKind
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryKind
sdiscoKind
let discoverAtMostAspect :: m ()
discoverAtMostAspect = do
DiscoveryAspect
discoAspect <- (State -> DiscoveryAspect) -> m DiscoveryAspect
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryAspect
sdiscoAspect
if Bool
kmIsConst Bool -> Bool -> Bool
|| ItemId
iid ItemId -> DiscoveryAspect -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.member` DiscoveryAspect
discoAspect
then String -> m ()
forall a. String -> a
atomicFail String
"item already fully discovered"
else ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
discoverAspect ItemId
iid AspectRecord
arItem
case ItemId -> ItemDict -> Maybe Item
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup ItemId
iid ItemDict
itemD of
Maybe Item
Nothing -> String -> m ()
forall a. String -> a
atomicFail String
"discovered item unheard of"
Just Item
item -> case Item -> ItemIdentity
jkind Item
item of
IdentityObvious ContentId ItemKind
_ -> m ()
discoverAtMostAspect
IdentityCovered ItemKindIx
ix ContentId ItemKind
_ik -> case ItemKindIx -> DiscoveryKind -> Maybe (ContentId ItemKind)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup ItemKindIx
ix DiscoveryKind
discoKind of
Just{} -> m ()
discoverAtMostAspect
Maybe (ContentId ItemKind)
Nothing -> do
ItemKindIx -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemKindIx -> ContentId ItemKind -> m ()
discoverKind ItemKindIx
ix ContentId ItemKind
ik
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
kmIsConst (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
discoverAspect ItemId
iid AspectRecord
arItem
m ()
forall (m :: * -> *). MonadStateWrite m => m ()
resetActorMaxSkills
updCover :: Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord -> m ()
updCover :: Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
updCover Container
_c ItemId
_iid ContentId ItemKind
_ik AspectRecord
_arItem = m ()
forall a. HasCallStack => a
undefined
updDiscoverKind :: MonadStateWrite m
=> Container -> ItemKindIx -> ContentId ItemKind -> m ()
updDiscoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()
updDiscoverKind Container
_c ItemKindIx
ix ContentId ItemKind
kmKind = do
DiscoveryKind
discoKind <- (State -> DiscoveryKind) -> m DiscoveryKind
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryKind
sdiscoKind
if ItemKindIx
ix ItemKindIx -> DiscoveryKind -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.member` DiscoveryKind
discoKind
then String -> m ()
forall a. String -> a
atomicFail String
"item kind already discovered"
else do
ItemKindIx -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemKindIx -> ContentId ItemKind -> m ()
discoverKind ItemKindIx
ix ContentId ItemKind
kmKind
m ()
forall (m :: * -> *). MonadStateWrite m => m ()
resetActorMaxSkills
discoverKind :: MonadStateWrite m => ItemKindIx -> ContentId ItemKind -> m ()
discoverKind :: ItemKindIx -> ContentId ItemKind -> m ()
discoverKind ItemKindIx
ix ContentId ItemKind
kindId = do
let f :: Maybe (ContentId ItemKind) -> Maybe (ContentId ItemKind)
f Maybe (ContentId ItemKind)
Nothing = ContentId ItemKind -> Maybe (ContentId ItemKind)
forall a. a -> Maybe a
Just ContentId ItemKind
kindId
f Just{} = String -> Maybe (ContentId ItemKind)
forall a. HasCallStack => String -> a
error (String -> Maybe (ContentId ItemKind))
-> String -> Maybe (ContentId ItemKind)
forall a b. (a -> b) -> a -> b
$ String
"already discovered" String -> (ItemKindIx, ContentId ItemKind) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemKindIx
ix, ContentId ItemKind
kindId)
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryKind -> DiscoveryKind) -> State -> State
updateDiscoKind ((DiscoveryKind -> DiscoveryKind) -> State -> State)
-> (DiscoveryKind -> DiscoveryKind) -> State -> State
forall a b. (a -> b) -> a -> b
$ \DiscoveryKind
discoKind1 ->
(Maybe (ContentId ItemKind) -> Maybe (ContentId ItemKind))
-> ItemKindIx -> DiscoveryKind -> DiscoveryKind
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe (ContentId ItemKind) -> Maybe (ContentId ItemKind)
f ItemKindIx
ix DiscoveryKind
discoKind1
updCoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()
updCoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()
updCoverKind Container
_c ItemKindIx
_ix ContentId ItemKind
_ik = m ()
forall a. HasCallStack => a
undefined
updDiscoverAspect :: MonadStateWrite m
=> Container -> ItemId -> IA.AspectRecord -> m ()
updDiscoverAspect :: Container -> ItemId -> AspectRecord -> m ()
updDiscoverAspect Container
_c ItemId
iid AspectRecord
arItem = do
COps{ItemSpeedup
coItemSpeedup :: ItemSpeedup
coItemSpeedup :: COps -> ItemSpeedup
coItemSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
case ItemId -> ItemDict -> Maybe Item
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup ItemId
iid ItemDict
itemD of
Maybe Item
Nothing -> String -> m ()
forall a. String -> a
atomicFail String
"discovered item unheard of"
Just Item
item -> do
ContentId ItemKind
kindId <- (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ContentId ItemKind) -> m (ContentId ItemKind))
-> (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall a b. (a -> b) -> a -> b
$ Item -> State -> ContentId ItemKind
getItemKindIdServer Item
item
DiscoveryAspect
discoAspect <- (State -> DiscoveryAspect) -> m DiscoveryAspect
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryAspect
sdiscoAspect
let kmIsConst :: Bool
kmIsConst = KindMean -> Bool
IA.kmConst (KindMean -> Bool) -> KindMean -> Bool
forall a b. (a -> b) -> a -> b
$ ContentId ItemKind -> ItemSpeedup -> KindMean
getKindMean ContentId ItemKind
kindId ItemSpeedup
coItemSpeedup
if Bool
kmIsConst Bool -> Bool -> Bool
|| ItemId
iid ItemId -> DiscoveryAspect -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.member` DiscoveryAspect
discoAspect
then String -> m ()
forall a. String -> a
atomicFail String
"item arItem already discovered"
else do
ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
discoverAspect ItemId
iid AspectRecord
arItem
m ()
forall (m :: * -> *). MonadStateWrite m => m ()
resetActorMaxSkills
discoverAspect :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
discoverAspect :: ItemId -> AspectRecord -> m ()
discoverAspect ItemId
iid AspectRecord
arItem = do
let f :: Maybe AspectRecord -> Maybe AspectRecord
f Maybe AspectRecord
Nothing = AspectRecord -> Maybe AspectRecord
forall a. a -> Maybe a
Just AspectRecord
arItem
f Just{} = String -> Maybe AspectRecord
forall a. HasCallStack => String -> a
error (String -> Maybe AspectRecord) -> String -> Maybe AspectRecord
forall a b. (a -> b) -> a -> b
$ String
"already discovered" String -> (ItemId, AspectRecord) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemId
iid, AspectRecord
arItem)
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryAspect -> DiscoveryAspect) -> State -> State
updateDiscoAspect ((DiscoveryAspect -> DiscoveryAspect) -> State -> State)
-> (DiscoveryAspect -> DiscoveryAspect) -> State -> State
forall a b. (a -> b) -> a -> b
$ \DiscoveryAspect
discoAspect1 ->
(Maybe AspectRecord -> Maybe AspectRecord)
-> ItemId -> DiscoveryAspect -> DiscoveryAspect
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe AspectRecord -> Maybe AspectRecord
f ItemId
iid DiscoveryAspect
discoAspect1
updCoverAspect :: Container -> ItemId -> IA.AspectRecord -> m ()
updCoverAspect :: Container -> ItemId -> AspectRecord -> m ()
updCoverAspect Container
_c ItemId
_iid AspectRecord
_arItem = m ()
forall a. HasCallStack => a
undefined
updDiscoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
updDiscoverServer :: ItemId -> AspectRecord -> m ()
updDiscoverServer ItemId
iid AspectRecord
arItem =
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryAspect -> DiscoveryAspect) -> State -> State
updateDiscoAspect ((DiscoveryAspect -> DiscoveryAspect) -> State -> State)
-> (DiscoveryAspect -> DiscoveryAspect) -> State -> State
forall a b. (a -> b) -> a -> b
$ \DiscoveryAspect
discoAspect1 ->
ItemId -> AspectRecord -> DiscoveryAspect -> DiscoveryAspect
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert ItemId
iid AspectRecord
arItem DiscoveryAspect
discoAspect1
updCoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
updCoverServer :: ItemId -> AspectRecord -> m ()
updCoverServer ItemId
iid AspectRecord
arItem =
(State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryAspect -> DiscoveryAspect) -> State -> State
updateDiscoAspect ((DiscoveryAspect -> DiscoveryAspect) -> State -> State)
-> (DiscoveryAspect -> DiscoveryAspect) -> State -> State
forall a b. (a -> b) -> a -> b
$ \DiscoveryAspect
discoAspect1 ->
Bool -> DiscoveryAspect -> DiscoveryAspect
forall a. HasCallStack => Bool -> a -> a
assert (DiscoveryAspect
discoAspect1 DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid AspectRecord -> AspectRecord -> Bool
forall a. Eq a => a -> a -> Bool
== AspectRecord
arItem)
(DiscoveryAspect -> DiscoveryAspect)
-> DiscoveryAspect -> DiscoveryAspect
forall a b. (a -> b) -> a -> b
$ ItemId -> DiscoveryAspect -> DiscoveryAspect
forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EM.delete ItemId
iid DiscoveryAspect
discoAspect1
updRestart :: MonadStateWrite m => State -> m ()
updRestart :: State -> m ()
updRestart = State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
putState
updRestartServer :: MonadStateWrite m => State -> m ()
updRestartServer :: State -> m ()
updRestartServer = State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
putState
updResumeServer :: MonadStateWrite m => State -> m ()
updResumeServer :: State -> m ()
updResumeServer = State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
putState