module Game.LambdaHack.Atomic.MonadStateWrite
( MonadStateWrite(..)
, updateLevel, updateActor, updateFaction
, insertItemContainer, insertItemActor, deleteItemContainer, deleteItemActor
, updatePrio, updateFloor, updateTile, updateSmell
) where
import Control.Exception.Assert.Sugar
import qualified Data.EnumMap.Strict as EM
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.State
class MonadStateRead m => MonadStateWrite m where
modifyState :: (State -> State) -> m ()
putState :: State -> m ()
updatePrio :: (ActorPrio -> ActorPrio) -> Level -> Level
updatePrio f lvl = lvl {lprio = f (lprio lvl)}
updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level
updateFloor f lvl = lvl {lfloor = f (lfloor lvl)}
updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level
updateEmbed f lvl = lvl {lembed = f (lembed lvl)}
updateTile :: (TileMap -> TileMap) -> Level -> Level
updateTile f lvl = lvl {ltile = f (ltile lvl)}
updateSmell :: (SmellMap -> SmellMap) -> Level -> Level
updateSmell f lvl = lvl {lsmell = f (lsmell lvl)}
updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m ()
updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid
updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m ()
updateActor aid f = do
let alt Nothing = assert `failure` "no body to update" `twith` aid
alt (Just b) = Just $ f b
modifyState $ updateActorD $ EM.alter alt aid
updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m ()
updateFaction fid f = do
let alt Nothing = assert `failure` "no faction to update" `twith` fid
alt (Just fact) = Just $ f fact
modifyState $ updateFactionD $ EM.alter alt fid
insertItemContainer :: MonadStateWrite m
=> ItemId -> ItemQuant -> Container -> m ()
insertItemContainer iid kit c = case c of
CFloor lid pos -> insertItemFloor iid kit lid pos
CEmbed lid pos -> insertItemEmbed iid kit lid pos
CActor aid store -> insertItemActor iid kit aid store
CTrunk{} -> return ()
insertItemFloor :: MonadStateWrite m
=> ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemFloor iid kit lid pos =
let bag = EM.singleton iid kit
mergeBag = EM.insertWith (EM.unionWith mergeItemQuant) pos bag
in updateLevel lid $ updateFloor mergeBag
insertItemEmbed :: MonadStateWrite m
=> ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemEmbed iid kit lid pos =
let bag = EM.singleton iid kit
mergeBag = EM.insertWith (EM.unionWith mergeItemQuant) pos bag
in updateLevel lid $ updateEmbed mergeBag
insertItemActor :: MonadStateWrite m
=> ItemId -> ItemQuant -> ActorId -> CStore -> m ()
insertItemActor iid kit aid cstore = case cstore of
CGround -> do
b <- getsState $ getActorBody aid
insertItemFloor iid kit (blid b) (bpos b)
COrgan -> insertItemBody iid kit aid
CEqp -> insertItemEqp iid kit aid
CInv -> insertItemInv iid kit aid
CSha -> do
b <- getsState $ getActorBody aid
insertItemSha iid kit (bfid b)
insertItemBody :: MonadStateWrite m
=> ItemId -> ItemQuant -> ActorId -> m ()
insertItemBody iid kit aid = do
let bag = EM.singleton iid kit
upd = EM.unionWith mergeItemQuant bag
updateActor aid $ \b -> b {borgan = upd (borgan b)}
insertItemEqp :: MonadStateWrite m
=> ItemId -> ItemQuant -> ActorId -> m ()
insertItemEqp iid kit aid = do
let bag = EM.singleton iid kit
upd = EM.unionWith mergeItemQuant bag
updateActor aid $ \b -> b {beqp = upd (beqp b)}
insertItemInv :: MonadStateWrite m
=> ItemId -> ItemQuant -> ActorId -> m ()
insertItemInv iid kit aid = do
let bag = EM.singleton iid kit
upd = EM.unionWith mergeItemQuant bag
updateActor aid $ \b -> b {binv = upd (binv b)}
insertItemSha :: MonadStateWrite m
=> ItemId -> ItemQuant -> FactionId -> m ()
insertItemSha iid kit fid = do
let bag = EM.singleton iid kit
upd = EM.unionWith mergeItemQuant bag
updateFaction fid $ \fact -> fact {gsha = upd (gsha fact)}
deleteItemContainer :: MonadStateWrite m
=> ItemId -> ItemQuant -> Container -> m ()
deleteItemContainer iid kit c = case c of
CFloor lid pos -> deleteItemFloor iid kit lid pos
CEmbed lid pos -> deleteItemEmbed iid kit lid pos
CActor aid store -> deleteItemActor iid kit aid store
CTrunk{} -> assert `failure` c
deleteItemFloor :: MonadStateWrite m
=> ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemFloor iid kit lid pos =
let rmFromFloor (Just bag) =
let nbag = rmFromBag kit iid bag
in if EM.null nbag then Nothing else Just nbag
rmFromFloor Nothing = assert `failure` "item already removed"
`twith` (iid, kit, lid, pos)
in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos
deleteItemEmbed :: MonadStateWrite m
=> ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemEmbed iid kit lid pos =
let rmFromFloor (Just bag) =
let nbag = rmFromBag kit iid bag
in if EM.null nbag then Nothing else Just nbag
rmFromFloor Nothing = assert `failure` "item already removed"
`twith` (iid, kit, lid, pos)
in updateLevel lid $ updateEmbed $ EM.alter rmFromFloor pos
deleteItemActor :: MonadStateWrite m
=> ItemId -> ItemQuant -> ActorId -> CStore -> m ()
deleteItemActor iid kit aid cstore = case cstore of
CGround -> do
b <- getsState $ getActorBody aid
deleteItemFloor iid kit (blid b) (bpos b)
COrgan -> deleteItemBody iid kit aid
CEqp -> deleteItemEqp iid kit aid
CInv -> deleteItemInv iid kit aid
CSha -> do
b <- getsState $ getActorBody aid
deleteItemSha iid kit (bfid b)
deleteItemBody :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemBody iid kit aid =
updateActor aid $ \b -> b {borgan = rmFromBag kit iid (borgan b) }
deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemEqp iid kit aid =
updateActor aid $ \b -> b {beqp = rmFromBag kit iid (beqp b)}
deleteItemInv :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemInv iid kit aid =
updateActor aid $ \b -> b {binv = rmFromBag kit iid (binv b)}
deleteItemSha :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m ()
deleteItemSha iid kit fid =
updateFaction fid $ \fact -> fact {gsha = rmFromBag kit iid (gsha fact)}
rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag kit@(k, rmIt) iid bag =
let rfb Nothing = assert `failure` "rm from empty slot" `twith` (k, iid, bag)
rfb (Just (n, it)) =
case compare n k of
LT -> assert `failure` "rm more than there is"
`twith` (n, kit, iid, bag)
EQ -> Nothing
GT -> assert (rmIt == take k it
`blame` (rmIt, take k it, n, kit, iid, bag))
$ Just (n k, drop k it)
in EM.alter rfb iid bag