module Game.LambdaHack.Atomic.MonadStateWrite
( MonadStateWrite(..), AtomicFail(..), atomicFail
, updateLevel, updateActor, updateFaction
, moveActorMap, swapActorMap
, insertBagContainer, insertItemContainer, insertItemActor
, deleteBagContainer, deleteItemContainer, deleteItemActor
, addAis, itemsMatch, addItemToActorMaxSkills, resetActorMaxSkills
#ifdef EXPOSE_INTERNAL
, insertItemFloor, insertItemEmbed
, insertItemOrgan, insertItemEqp, insertItemInv, insertItemSha
, deleteItemFloor, deleteItemEmbed
, deleteItemOrgan, deleteItemEqp, deleteItemInv, deleteItemSha
, rmFromBag
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Control.Exception as Ex
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Key (mapWithKeyM_)
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.Level
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
class MonadStateRead m => MonadStateWrite m where
modifyState :: (State -> State) -> m ()
putState :: State -> m ()
newtype AtomicFail = AtomicFail String
deriving Show
instance Ex.Exception AtomicFail
atomicFail :: String -> a
atomicFail = Ex.throw . AtomicFail
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 = error $ "no body to update" `showFailure` 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 = error $ "no faction to update" `showFailure` fid
alt (Just fact) = Just $ f fact
modifyState $ updateFactionD $ EM.alter alt fid
moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m ()
moveActorMap aid body newBody = do
let rmBig Nothing = error $ "actor already removed"
`showFailure` (aid, body)
rmBig (Just _aid2) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (aid == _aid2 `blame` "actor already removed"
`swith` (aid, body, _aid2))
#endif
Nothing
addBig Nothing = Just aid
addBig (Just aid2) = error $ "an actor already present there"
`showFailure` (aid, body, aid2)
updBig = EM.alter addBig (bpos newBody)
. EM.alter rmBig (bpos body)
let rmProj Nothing = error $ "actor already removed"
`showFailure` (aid, body)
rmProj (Just l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (aid `elem` l `blame` "actor already removed"
`swith` (aid, body, l))
#endif
(let l2 = delete aid l
in if null l2 then Nothing else Just l2)
addProj Nothing = Just [aid]
addProj (Just l) = Just $ aid : l
updProj = EM.alter addProj (bpos newBody)
. EM.alter rmProj (bpos body)
updateLevel (blid body) $ if bproj body
then updateProjMap updProj
else updateBigMap updBig
swapActorMap :: MonadStateWrite m
=> ActorId -> Actor -> ActorId -> Actor -> m ()
swapActorMap source sbody target tbody = do
let addBig aid1 aid2 Nothing =
error $ "actor already removed"
`showFailure` (aid1, aid2, source, sbody, target, tbody)
addBig _aid1 aid2 (Just _aid) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (_aid == _aid1 `blame` "wrong actor present"
`swith` (_aid, _aid1, aid2, sbody, tbody))
#endif
(Just aid2)
updBig = EM.alter (addBig source target) (bpos sbody)
. EM.alter (addBig target source) (bpos tbody)
if not (bproj sbody) && not (bproj tbody)
then updateLevel (blid sbody) $ updateBigMap updBig
else do
moveActorMap source sbody tbody
moveActorMap target tbody sbody
insertBagContainer :: MonadStateWrite m
=> ItemBag -> Container -> m ()
insertBagContainer bag c = case c of
CFloor lid pos -> do
let alt Nothing = Just bag
alt (Just bag2) = atomicFail $ "floor bag not empty"
`showFailure` (bag2, lid, pos, bag)
updateLevel lid $ updateFloor $ EM.alter alt pos
CEmbed lid pos -> do
let alt Nothing = Just bag
alt (Just bag2) = atomicFail $ "embed bag not empty"
`showFailure` (bag2, lid, pos, bag)
updateLevel lid $ updateEmbed $ EM.alter alt pos
CActor aid store ->
mapWithKeyM_ (\iid kit -> insertItemActor iid kit aid store) bag
CTrunk{} -> return ()
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 -> insertItemOrgan iid kit aid
CEqp -> insertItemEqp iid kit aid
CInv -> insertItemInv iid kit aid
CSha -> do
b <- getsState $ getActorBody aid
insertItemSha iid kit (bfid b)
insertItemOrgan :: MonadStateWrite m
=> ItemId -> ItemQuant -> ActorId -> m ()
insertItemOrgan iid kit aid = do
arItem <- getsState $ aspectRecordFromIid iid
let bag = EM.singleton iid kit
upd = EM.unionWith mergeItemQuant bag
updateActor aid $ \b ->
b { borgan = upd (borgan b)
, bweapon = if IA.checkFlag Ability.Meleeable arItem
then bweapon b + 1
else bweapon b }
insertItemEqp :: MonadStateWrite m
=> ItemId -> ItemQuant -> ActorId -> m ()
insertItemEqp iid kit aid = do
arItem <- getsState $ aspectRecordFromIid iid
let bag = EM.singleton iid kit
upd = EM.unionWith mergeItemQuant bag
updateActor aid $ \b ->
b { beqp = upd (beqp b)
, bweapon = if IA.checkFlag Ability.Meleeable arItem
then bweapon b + 1
else bweapon 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)}
deleteBagContainer :: MonadStateWrite m
=> ItemBag -> Container -> m ()
deleteBagContainer bag c = case c of
CFloor lid pos -> do
let alt Nothing = atomicFail $ "floor bag already empty"
`showFailure` (lid, pos, bag)
alt (Just bag2) = assert (bag == bag2) Nothing
updateLevel lid $ updateFloor $ EM.alter alt pos
CEmbed lid pos -> do
let alt Nothing = atomicFail $ "embed bag already empty"
`showFailure` (lid, pos, bag)
alt (Just bag2) = assert (bag == bag2 `blame` (bag, bag2)) Nothing
updateLevel lid $ updateEmbed $ EM.alter alt pos
CActor aid store ->
mapWithKeyM_ (\iid kit -> deleteItemActor iid kit aid store) bag
CTrunk{} -> error $ "" `showFailure` c
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{} -> error $ "" `showFailure` 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 = error $ "item already removed"
`showFailure` (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 = error $ "item already removed"
`showFailure` (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 -> deleteItemOrgan iid kit aid
CEqp -> deleteItemEqp iid kit aid
CInv -> deleteItemInv iid kit aid
CSha -> do
b <- getsState $ getActorBody aid
deleteItemSha iid kit (bfid b)
deleteItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemOrgan iid kit aid = do
arItem <- getsState $ aspectRecordFromIid iid
updateActor aid $ \b ->
b { borgan = rmFromBag kit iid (borgan b)
, bweapon = if IA.checkFlag Ability.Meleeable arItem
then bweapon b - 1
else bweapon b }
deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemEqp iid kit aid = do
arItem <- getsState $ aspectRecordFromIid iid
updateActor aid $ \b ->
b { beqp = rmFromBag kit iid (beqp b)
, bweapon = if IA.checkFlag Ability.Meleeable arItem
then bweapon b - 1
else bweapon 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 = error $ "rm from empty slot" `showFailure` (k, iid, bag)
rfb (Just (n, it)) =
case compare n k of
LT -> error $ "rm more than there is"
`showFailure` (n, kit, iid, bag)
EQ -> assert (rmIt == it `blame` (rmIt, it, n, kit, iid, bag)) Nothing
GT -> assert (rmIt == take k it
`blame` (rmIt, take k it, n, kit, iid, bag))
$ Just (n - k, take (n - k) it)
in EM.alter rfb iid bag
addAis :: MonadStateWrite m => [(ItemId, Item)] -> m ()
addAis ais = do
let h item1 item2 =
assert (itemsMatch item1 item2
`blame` "inconsistent added items"
`swith` (item1, item2, ais))
item2
forM_ ais $ \(iid, item) -> do
let f = case jkind item of
IdentityObvious _ -> id
IdentityCovered ix _ ->
updateItemIxMap $ EM.insertWith ES.union ix (ES.singleton iid)
modifyState $ f . updateItemD (EM.insertWith h iid item)
itemsMatch :: Item -> Item -> Bool
itemsMatch item1 item2 =
jkind item1 == jkind item2
addItemToActorMaxSkills :: MonadStateWrite m
=> ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills iid itemBase k aid = do
arItem <- getsState $ aspectRecordFromItem iid itemBase
let f actorMaxSk =
Ability.sumScaledSkills [(actorMaxSk, 1), (IA.aSkills arItem, k)]
modifyState $ updateActorMaxSkills $ EM.adjust f aid
resetActorMaxSkills :: MonadStateWrite m => m ()
resetActorMaxSkills = do
actorMaxSk <- getsState maxSkillsInDungeon
modifyState $ updateActorMaxSkills $ const actorMaxSk