-- | The monad for writing to the main game state.
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
    -- * Internal operations
  , 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

-- | The monad for writing to the main game state. Atomic updates (@UpdAtomic@)
-- are given semantics in this monad.
class MonadStateRead m => MonadStateWrite m where
  modifyState :: (State -> State) -> m ()
  putState :: State -> m ()

-- | Exception signifying that atomic action failed because
-- the information it carries is inconsistent with the client's state,
-- (e.g., because the client knows too little to understand the command
-- or already deduced the state change from earlier commands
-- or is confused, amnesiac or sees illusory actors or tiles).
-- Whenever we know the failure is logically impossible,
-- we don't throw the @AtomicFail@ exception, but insert a normal assertion
-- or @error@ call, which are never caught nor handled.
newtype AtomicFail = AtomicFail String
  deriving Int -> AtomicFail -> ShowS
[AtomicFail] -> ShowS
AtomicFail -> String
(Int -> AtomicFail -> ShowS)
-> (AtomicFail -> String)
-> ([AtomicFail] -> ShowS)
-> Show AtomicFail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AtomicFail] -> ShowS
$cshowList :: [AtomicFail] -> ShowS
show :: AtomicFail -> String
$cshow :: AtomicFail -> String
showsPrec :: Int -> AtomicFail -> ShowS
$cshowsPrec :: Int -> AtomicFail -> ShowS
Show

instance Ex.Exception AtomicFail

atomicFail :: String -> a
atomicFail :: String -> a
atomicFail = AtomicFail -> a
forall a e. Exception e => e -> a
Ex.throw (AtomicFail -> a) -> (String -> AtomicFail) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AtomicFail
AtomicFail

-- INLIning offers no speedup, increases alloc and binary size.
-- EM.alter not necessary, because levels not removed, so little risk
-- of adjusting at absent index.
updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m ()
updateLevel :: LevelId -> (Level -> Level) -> m ()
updateLevel lid :: LevelId
lid f :: Level -> Level
f = (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (Dungeon -> Dungeon) -> State -> State
updateDungeon ((Dungeon -> Dungeon) -> State -> State)
-> (Dungeon -> Dungeon) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Level -> Level) -> LevelId -> Dungeon -> Dungeon
forall k a. Enum k => (a -> a) -> k -> EnumMap k a -> EnumMap k a
EM.adjust Level -> Level
f LevelId
lid

-- INLIning doesn't help despite probably canceling the alt indirection.
-- perhaps it's applied automatically due to INLINABLE.
updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m ()
updateActor :: ActorId -> (Actor -> Actor) -> m ()
updateActor aid :: ActorId
aid f :: Actor -> Actor
f = do
  let alt :: Maybe Actor -> Maybe Actor
alt Nothing = String -> Maybe Actor
forall a. HasCallStack => String -> a
error (String -> Maybe Actor) -> String -> Maybe Actor
forall a b. (a -> b) -> a -> b
$ "no body to update" String -> ActorId -> String
forall v. Show v => String -> v -> String
`showFailure` ActorId
aid
      alt (Just b :: Actor
b) = Actor -> Maybe Actor
forall a. a -> Maybe a
Just (Actor -> Maybe Actor) -> Actor -> Maybe Actor
forall a b. (a -> b) -> a -> b
$ Actor -> Actor
f 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
alt ActorId
aid

updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m ()
updateFaction :: FactionId -> (Faction -> Faction) -> m ()
updateFaction fid :: FactionId
fid f :: Faction -> Faction
f = do
  let alt :: Maybe Faction -> Maybe Faction
alt Nothing = String -> Maybe Faction
forall a. HasCallStack => String -> a
error (String -> Maybe Faction) -> String -> Maybe Faction
forall a b. (a -> b) -> a -> b
$ "no faction to update" String -> FactionId -> String
forall v. Show v => String -> v -> String
`showFailure` FactionId
fid
      alt (Just fact :: Faction
fact) = Faction -> Maybe Faction
forall a. a -> Maybe a
Just (Faction -> Maybe Faction) -> Faction -> Maybe Faction
forall a b. (a -> b) -> a -> b
$ Faction -> Faction
f Faction
fact
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (FactionDict -> FactionDict) -> State -> State
updateFactionD ((FactionDict -> FactionDict) -> State -> State)
-> (FactionDict -> FactionDict) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Maybe Faction -> Maybe Faction)
-> FactionId -> FactionDict -> FactionDict
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Faction -> Maybe Faction
alt FactionId
fid

moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m ()
moveActorMap :: ActorId -> Actor -> Actor -> m ()
moveActorMap aid :: ActorId
aid body :: Actor
body newBody :: Actor
newBody = do
  let rmBig :: Maybe ActorId -> Maybe ActorId
rmBig Nothing = String -> Maybe ActorId
forall a. HasCallStack => String -> a
error (String -> Maybe ActorId) -> String -> Maybe ActorId
forall a b. (a -> b) -> a -> b
$ "actor already removed"
                              String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body)
      rmBig (Just _aid2 :: ActorId
_aid2) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        assert (aid == _aid2 `blame` "actor already removed"
                             `swith` (aid, body, _aid2))
#endif
        Maybe ActorId
forall a. Maybe a
Nothing
      addBig :: Maybe ActorId -> Maybe ActorId
addBig Nothing = ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aid
      addBig (Just aid2 :: ActorId
aid2) = String -> Maybe ActorId
forall a. HasCallStack => String -> a
error (String -> Maybe ActorId) -> String -> Maybe ActorId
forall a b. (a -> b) -> a -> b
$ "an actor already present there"
                                   String -> (ActorId, Actor, ActorId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body, ActorId
aid2)
      updBig :: EnumMap Point ActorId -> EnumMap Point ActorId
updBig = (Maybe ActorId -> Maybe ActorId)
-> Point -> EnumMap Point ActorId -> EnumMap Point ActorId
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ActorId -> Maybe ActorId
addBig (Actor -> Point
bpos Actor
newBody)
               (EnumMap Point ActorId -> EnumMap Point ActorId)
-> (EnumMap Point ActorId -> EnumMap Point ActorId)
-> EnumMap Point ActorId
-> EnumMap Point ActorId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ActorId -> Maybe ActorId)
-> Point -> EnumMap Point ActorId -> EnumMap Point ActorId
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ActorId -> Maybe ActorId
rmBig (Actor -> Point
bpos Actor
body)
  let rmProj :: Maybe [ActorId] -> Maybe [ActorId]
rmProj Nothing = String -> Maybe [ActorId]
forall a. HasCallStack => String -> a
error (String -> Maybe [ActorId]) -> String -> Maybe [ActorId]
forall a b. (a -> b) -> a -> b
$ "actor already removed"
                               String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body)
      rmProj (Just l :: [ActorId]
l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        assert (aid `elem` l `blame` "actor already removed"
                             `swith` (aid, body, 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)
      addProj :: Maybe [ActorId] -> Maybe [ActorId]
addProj Nothing = [ActorId] -> Maybe [ActorId]
forall a. a -> Maybe a
Just [ActorId
aid]
      addProj (Just l :: [ActorId]
l) = [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
      updProj :: EnumMap Point [ActorId] -> EnumMap Point [ActorId]
updProj = (Maybe [ActorId] -> Maybe [ActorId])
-> Point -> EnumMap Point [ActorId] -> EnumMap Point [ActorId]
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe [ActorId] -> Maybe [ActorId]
addProj (Actor -> Point
bpos Actor
newBody)
                (EnumMap Point [ActorId] -> EnumMap Point [ActorId])
-> (EnumMap Point [ActorId] -> EnumMap Point [ActorId])
-> EnumMap Point [ActorId]
-> EnumMap Point [ActorId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [ActorId] -> Maybe [ActorId])
-> Point -> EnumMap Point [ActorId] -> EnumMap Point [ActorId]
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe [ActorId] -> Maybe [ActorId]
rmProj (Actor -> Point
bpos Actor
body)
  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 (EnumMap Point [ActorId] -> EnumMap Point [ActorId])
-> Level -> Level
updateProjMap EnumMap Point [ActorId] -> EnumMap Point [ActorId]
updProj
                            else (EnumMap Point ActorId -> EnumMap Point ActorId) -> Level -> Level
updateBigMap EnumMap Point ActorId -> EnumMap Point ActorId
updBig

swapActorMap :: MonadStateWrite m
             => ActorId -> Actor -> ActorId -> Actor -> m ()
swapActorMap :: ActorId -> Actor -> ActorId -> Actor -> m ()
swapActorMap source :: ActorId
source sbody :: Actor
sbody target :: ActorId
target tbody :: Actor
tbody = do
  let addBig :: ActorId -> ActorId -> Maybe ActorId -> Maybe ActorId
addBig aid1 :: ActorId
aid1 aid2 :: ActorId
aid2 Nothing =
        String -> Maybe ActorId
forall a. HasCallStack => String -> a
error (String -> Maybe ActorId) -> String -> Maybe ActorId
forall a b. (a -> b) -> a -> b
$ "actor already removed"
                String
-> (ActorId, ActorId, ActorId, Actor, ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid1, ActorId
aid2, ActorId
source, Actor
sbody, ActorId
target, Actor
tbody)
      addBig _aid1 :: ActorId
_aid1 aid2 :: ActorId
aid2 (Just _aid :: ActorId
_aid) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        assert (_aid == _aid1 `blame` "wrong actor present"
                              `swith` (_aid, _aid1, aid2, sbody, tbody))
#endif
        (ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aid2)
      updBig :: EnumMap Point ActorId -> EnumMap Point ActorId
updBig = (Maybe ActorId -> Maybe ActorId)
-> Point -> EnumMap Point ActorId -> EnumMap Point ActorId
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (ActorId -> ActorId -> Maybe ActorId -> Maybe ActorId
addBig ActorId
source ActorId
target) (Actor -> Point
bpos Actor
sbody)
               (EnumMap Point ActorId -> EnumMap Point ActorId)
-> (EnumMap Point ActorId -> EnumMap Point ActorId)
-> EnumMap Point ActorId
-> EnumMap Point ActorId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ActorId -> Maybe ActorId)
-> Point -> EnumMap Point ActorId -> EnumMap Point ActorId
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (ActorId -> ActorId -> Maybe ActorId -> Maybe ActorId
addBig ActorId
target ActorId
source) (Actor -> Point
bpos Actor
tbody)
  if Bool -> Bool
not (Actor -> Bool
bproj Actor
sbody) Bool -> Bool -> Bool
&& Bool -> Bool
not (Actor -> Bool
bproj Actor
tbody)
  then LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel (Actor -> LevelId
blid Actor
sbody) ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (EnumMap Point ActorId -> EnumMap Point ActorId) -> Level -> Level
updateBigMap EnumMap Point ActorId -> EnumMap Point ActorId
updBig
  else do
    ActorId -> Actor -> Actor -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> Actor -> m ()
moveActorMap ActorId
source Actor
sbody Actor
tbody
    ActorId -> Actor -> Actor -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> Actor -> m ()
moveActorMap ActorId
target Actor
tbody Actor
sbody

insertBagContainer :: MonadStateWrite m
                   => ItemBag -> Container -> m ()
insertBagContainer :: ItemBag -> Container -> m ()
insertBagContainer bag :: ItemBag
bag c :: Container
c = case Container
c of
  CFloor lid :: LevelId
lid pos :: Point
pos -> do
    let alt :: Maybe ItemBag -> Maybe ItemBag
alt Nothing = ItemBag -> Maybe ItemBag
forall a. a -> Maybe a
Just ItemBag
bag
        alt (Just bag2 :: ItemBag
bag2) = String -> Maybe ItemBag
forall a. String -> a
atomicFail (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ "floor bag not empty"
                                       String -> (ItemBag, LevelId, Point, ItemBag) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemBag
bag2, LevelId
lid, Point
pos, ItemBag
bag)
    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
$ (ItemFloor -> ItemFloor) -> Level -> Level
updateFloor ((ItemFloor -> ItemFloor) -> Level -> Level)
-> (ItemFloor -> ItemFloor) -> Level -> Level
forall a b. (a -> b) -> a -> b
$ (Maybe ItemBag -> Maybe ItemBag) -> Point -> ItemFloor -> ItemFloor
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ItemBag -> Maybe ItemBag
alt Point
pos
  CEmbed lid :: LevelId
lid pos :: Point
pos -> do
    let alt :: Maybe ItemBag -> Maybe ItemBag
alt Nothing = ItemBag -> Maybe ItemBag
forall a. a -> Maybe a
Just ItemBag
bag
        alt (Just bag2 :: ItemBag
bag2) = String -> Maybe ItemBag
forall a. String -> a
atomicFail (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ "embed bag not empty"
                                       String -> (ItemBag, LevelId, Point, ItemBag) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemBag
bag2, LevelId
lid, Point
pos, ItemBag
bag)
    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
$ (ItemFloor -> ItemFloor) -> Level -> Level
updateEmbed ((ItemFloor -> ItemFloor) -> Level -> Level)
-> (ItemFloor -> ItemFloor) -> Level -> Level
forall a b. (a -> b) -> a -> b
$ (Maybe ItemBag -> Maybe ItemBag) -> Point -> ItemFloor -> ItemFloor
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ItemBag -> Maybe ItemBag
alt Point
pos
  CActor aid :: ActorId
aid store :: CStore
store ->
    -- Very unlikely case, so we prefer brevity over performance.
    (Key (EnumMap ItemId) -> ItemQuant -> m ()) -> ItemBag -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(FoldableWithKey t, Monad m) =>
(Key t -> a -> m b) -> t a -> m ()
mapWithKeyM_ (\iid :: Key (EnumMap ItemId)
iid kit :: ItemQuant
kit -> ItemId -> ItemQuant -> ActorId -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
insertItemActor Key (EnumMap ItemId)
ItemId
iid ItemQuant
kit ActorId
aid CStore
store) ItemBag
bag
  CTrunk{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

insertItemContainer :: MonadStateWrite m
                    => ItemId -> ItemQuant -> Container -> m ()
insertItemContainer :: ItemId -> ItemQuant -> Container -> m ()
insertItemContainer iid :: ItemId
iid kit :: ItemQuant
kit c :: Container
c = case Container
c of
  CFloor lid :: LevelId
lid pos :: Point
pos -> ItemId -> ItemQuant -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemFloor ItemId
iid ItemQuant
kit LevelId
lid Point
pos
  CEmbed lid :: LevelId
lid pos :: Point
pos -> ItemId -> ItemQuant -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemEmbed ItemId
iid ItemQuant
kit LevelId
lid Point
pos
  CActor aid :: ActorId
aid store :: CStore
store -> ItemId -> ItemQuant -> ActorId -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
insertItemActor ItemId
iid ItemQuant
kit ActorId
aid CStore
store
  CTrunk{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- New @kit@ lands at the front of the list.
insertItemFloor :: MonadStateWrite m
                => ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemFloor :: ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemFloor iid :: ItemId
iid kit :: ItemQuant
kit lid :: LevelId
lid pos :: Point
pos =
  let bag :: ItemBag
bag = ItemId -> ItemQuant -> ItemBag
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton ItemId
iid ItemQuant
kit
      mergeBag :: ItemFloor -> ItemFloor
mergeBag = (ItemBag -> ItemBag -> ItemBag)
-> Point -> ItemBag -> ItemFloor -> ItemFloor
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith ((ItemQuant -> ItemQuant -> ItemQuant)
-> ItemBag -> ItemBag -> ItemBag
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ItemQuant -> ItemQuant -> ItemQuant
mergeItemQuant) Point
pos ItemBag
bag
  in 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
$ (ItemFloor -> ItemFloor) -> Level -> Level
updateFloor ItemFloor -> ItemFloor
mergeBag

insertItemEmbed :: MonadStateWrite m
                => ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemEmbed :: ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemEmbed iid :: ItemId
iid kit :: ItemQuant
kit lid :: LevelId
lid pos :: Point
pos =
  let bag :: ItemBag
bag = ItemId -> ItemQuant -> ItemBag
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton ItemId
iid ItemQuant
kit
      mergeBag :: ItemFloor -> ItemFloor
mergeBag = (ItemBag -> ItemBag -> ItemBag)
-> Point -> ItemBag -> ItemFloor -> ItemFloor
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith ((ItemQuant -> ItemQuant -> ItemQuant)
-> ItemBag -> ItemBag -> ItemBag
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ItemQuant -> ItemQuant -> ItemQuant
mergeItemQuant) Point
pos ItemBag
bag
  in 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
$ (ItemFloor -> ItemFloor) -> Level -> Level
updateEmbed ItemFloor -> ItemFloor
mergeBag

insertItemActor :: MonadStateWrite m
                => ItemId -> ItemQuant -> ActorId -> CStore -> m ()
insertItemActor :: ItemId -> ItemQuant -> ActorId -> CStore -> m ()
insertItemActor iid :: ItemId
iid kit :: ItemQuant
kit aid :: ActorId
aid cstore :: CStore
cstore = case CStore
cstore of
  CGround -> 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
    ItemId -> ItemQuant -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> LevelId -> Point -> m ()
insertItemFloor ItemId
iid ItemQuant
kit (Actor -> LevelId
blid Actor
b) (Actor -> Point
bpos Actor
b)
  COrgan -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
insertItemOrgan ItemId
iid ItemQuant
kit ActorId
aid
  CEqp -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
insertItemEqp ItemId
iid ItemQuant
kit ActorId
aid
  CInv -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
insertItemInv ItemId
iid ItemQuant
kit ActorId
aid
  CSha -> 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
    ItemId -> ItemQuant -> FactionId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> FactionId -> m ()
insertItemSha ItemId
iid ItemQuant
kit (Actor -> FactionId
bfid Actor
b)

insertItemOrgan :: MonadStateWrite m
                => ItemId -> ItemQuant -> ActorId -> m ()
insertItemOrgan :: ItemId -> ItemQuant -> ActorId -> m ()
insertItemOrgan iid :: ItemId
iid kit :: ItemQuant
kit aid :: ActorId
aid = do
  AspectRecord
arItem <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> AspectRecord
aspectRecordFromIid ItemId
iid
  let bag :: ItemBag
bag = ItemId -> ItemQuant -> ItemBag
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton ItemId
iid ItemQuant
kit
      upd :: ItemBag -> ItemBag
upd = (ItemQuant -> ItemQuant -> ItemQuant)
-> ItemBag -> ItemBag -> ItemBag
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ItemQuant -> ItemQuant -> ItemQuant
mergeItemQuant ItemBag
bag
  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
$ \b :: Actor
b ->
    Actor
b { borgan :: ItemBag
borgan = ItemBag -> ItemBag
upd (Actor -> ItemBag
borgan Actor
b)
      , bweapon :: Int
bweapon = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arItem
                  then Actor -> Int
bweapon Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
                  else Actor -> Int
bweapon Actor
b }

insertItemEqp :: MonadStateWrite m
              => ItemId -> ItemQuant -> ActorId -> m ()
insertItemEqp :: ItemId -> ItemQuant -> ActorId -> m ()
insertItemEqp iid :: ItemId
iid kit :: ItemQuant
kit aid :: ActorId
aid = do
  AspectRecord
arItem <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> AspectRecord
aspectRecordFromIid ItemId
iid
  let bag :: ItemBag
bag = ItemId -> ItemQuant -> ItemBag
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton ItemId
iid ItemQuant
kit
      upd :: ItemBag -> ItemBag
upd = (ItemQuant -> ItemQuant -> ItemQuant)
-> ItemBag -> ItemBag -> ItemBag
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ItemQuant -> ItemQuant -> ItemQuant
mergeItemQuant ItemBag
bag
  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
$ \b :: Actor
b ->
    Actor
b { beqp :: ItemBag
beqp = ItemBag -> ItemBag
upd (Actor -> ItemBag
beqp Actor
b)
      , bweapon :: Int
bweapon = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arItem
                  then Actor -> Int
bweapon Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
                  else Actor -> Int
bweapon Actor
b }

insertItemInv :: MonadStateWrite m
              => ItemId -> ItemQuant -> ActorId -> m ()
insertItemInv :: ItemId -> ItemQuant -> ActorId -> m ()
insertItemInv iid :: ItemId
iid kit :: ItemQuant
kit aid :: ActorId
aid = do
  let bag :: ItemBag
bag = ItemId -> ItemQuant -> ItemBag
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton ItemId
iid ItemQuant
kit
      upd :: ItemBag -> ItemBag
upd = (ItemQuant -> ItemQuant -> ItemQuant)
-> ItemBag -> ItemBag -> ItemBag
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ItemQuant -> ItemQuant -> ItemQuant
mergeItemQuant ItemBag
bag
  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
$ \b :: Actor
b -> Actor
b {binv :: ItemBag
binv = ItemBag -> ItemBag
upd (Actor -> ItemBag
binv Actor
b)}

insertItemSha :: MonadStateWrite m
              => ItemId -> ItemQuant -> FactionId -> m ()
insertItemSha :: ItemId -> ItemQuant -> FactionId -> m ()
insertItemSha iid :: ItemId
iid kit :: ItemQuant
kit fid :: FactionId
fid = do
  let bag :: ItemBag
bag = ItemId -> ItemQuant -> ItemBag
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton ItemId
iid ItemQuant
kit
      upd :: ItemBag -> ItemBag
upd = (ItemQuant -> ItemQuant -> ItemQuant)
-> ItemBag -> ItemBag -> ItemBag
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ItemQuant -> ItemQuant -> ItemQuant
mergeItemQuant ItemBag
bag
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid ((Faction -> Faction) -> m ()) -> (Faction -> Faction) -> m ()
forall a b. (a -> b) -> a -> b
$ \fact :: Faction
fact -> Faction
fact {gsha :: ItemBag
gsha = ItemBag -> ItemBag
upd (Faction -> ItemBag
gsha Faction
fact)}

deleteBagContainer :: MonadStateWrite m
                   => ItemBag -> Container -> m ()
deleteBagContainer :: ItemBag -> Container -> m ()
deleteBagContainer bag :: ItemBag
bag c :: Container
c = case Container
c of
  CFloor lid :: LevelId
lid pos :: Point
pos -> do
    let alt :: Maybe ItemBag -> Maybe ItemBag
alt Nothing = String -> Maybe ItemBag
forall a. String -> a
atomicFail (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ "floor bag already empty"
                                   String -> (LevelId, Point, ItemBag) -> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, Point
pos, ItemBag
bag)
        alt (Just bag2 :: ItemBag
bag2) = Bool -> Maybe ItemBag -> Maybe ItemBag
forall a. HasCallStack => Bool -> a -> a
assert (ItemBag
bag ItemBag -> ItemBag -> Bool
forall a. Eq a => a -> a -> Bool
== ItemBag
bag2) Maybe ItemBag
forall a. Maybe a
Nothing
    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
$ (ItemFloor -> ItemFloor) -> Level -> Level
updateFloor ((ItemFloor -> ItemFloor) -> Level -> Level)
-> (ItemFloor -> ItemFloor) -> Level -> Level
forall a b. (a -> b) -> a -> b
$ (Maybe ItemBag -> Maybe ItemBag) -> Point -> ItemFloor -> ItemFloor
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ItemBag -> Maybe ItemBag
alt Point
pos
  CEmbed lid :: LevelId
lid pos :: Point
pos -> do
    let alt :: Maybe ItemBag -> Maybe ItemBag
alt Nothing = String -> Maybe ItemBag
forall a. String -> a
atomicFail (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ "embed bag already empty"
                                   String -> (LevelId, Point, ItemBag) -> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, Point
pos, ItemBag
bag)
        alt (Just bag2 :: ItemBag
bag2) = Bool -> Maybe ItemBag -> Maybe ItemBag
forall a. HasCallStack => Bool -> a -> a
assert (ItemBag
bag ItemBag -> ItemBag -> Bool
forall a. Eq a => a -> a -> Bool
== ItemBag
bag2 Bool -> (ItemBag, ItemBag) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ItemBag
bag, ItemBag
bag2)) Maybe ItemBag
forall a. Maybe a
Nothing
    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
$ (ItemFloor -> ItemFloor) -> Level -> Level
updateEmbed ((ItemFloor -> ItemFloor) -> Level -> Level)
-> (ItemFloor -> ItemFloor) -> Level -> Level
forall a b. (a -> b) -> a -> b
$ (Maybe ItemBag -> Maybe ItemBag) -> Point -> ItemFloor -> ItemFloor
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ItemBag -> Maybe ItemBag
alt Point
pos
  CActor aid :: ActorId
aid store :: CStore
store ->
    -- Very unlikely case, so we prefer brevity over performance.
    (Key (EnumMap ItemId) -> ItemQuant -> m ()) -> ItemBag -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(FoldableWithKey t, Monad m) =>
(Key t -> a -> m b) -> t a -> m ()
mapWithKeyM_ (\iid :: Key (EnumMap ItemId)
iid kit :: ItemQuant
kit -> ItemId -> ItemQuant -> ActorId -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
deleteItemActor Key (EnumMap ItemId)
ItemId
iid ItemQuant
kit ActorId
aid CStore
store) ItemBag
bag
  CTrunk{} -> String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "" String -> Container -> String
forall v. Show v => String -> v -> String
`showFailure` Container
c

deleteItemContainer :: MonadStateWrite m
                    => ItemId -> ItemQuant -> Container -> m ()
deleteItemContainer :: ItemId -> ItemQuant -> Container -> m ()
deleteItemContainer iid :: ItemId
iid kit :: ItemQuant
kit c :: Container
c = case Container
c of
  CFloor lid :: LevelId
lid pos :: Point
pos -> ItemId -> ItemQuant -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemFloor ItemId
iid ItemQuant
kit LevelId
lid Point
pos
  CEmbed lid :: LevelId
lid pos :: Point
pos -> ItemId -> ItemQuant -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemEmbed ItemId
iid ItemQuant
kit LevelId
lid Point
pos
  CActor aid :: ActorId
aid store :: CStore
store -> ItemId -> ItemQuant -> ActorId -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
deleteItemActor ItemId
iid ItemQuant
kit ActorId
aid CStore
store
  CTrunk{} -> String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "" String -> Container -> String
forall v. Show v => String -> v -> String
`showFailure` Container
c

deleteItemFloor :: MonadStateWrite m
                => ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemFloor :: ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemFloor iid :: ItemId
iid kit :: ItemQuant
kit lid :: LevelId
lid pos :: Point
pos =
  let rmFromFloor :: Maybe ItemBag -> Maybe ItemBag
rmFromFloor (Just bag :: ItemBag
bag) =
        let nbag :: ItemBag
nbag = ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag ItemQuant
kit ItemId
iid ItemBag
bag
        in if ItemBag -> Bool
forall k a. EnumMap k a -> Bool
EM.null ItemBag
nbag then Maybe ItemBag
forall a. Maybe a
Nothing else ItemBag -> Maybe ItemBag
forall a. a -> Maybe a
Just ItemBag
nbag
      rmFromFloor Nothing = String -> Maybe ItemBag
forall a. HasCallStack => String -> a
error (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ "item already removed"
                                    String -> (ItemId, ItemQuant, LevelId, Point) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemId
iid, ItemQuant
kit, LevelId
lid, Point
pos)
  in 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
$ (ItemFloor -> ItemFloor) -> Level -> Level
updateFloor ((ItemFloor -> ItemFloor) -> Level -> Level)
-> (ItemFloor -> ItemFloor) -> Level -> Level
forall a b. (a -> b) -> a -> b
$ (Maybe ItemBag -> Maybe ItemBag) -> Point -> ItemFloor -> ItemFloor
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ItemBag -> Maybe ItemBag
rmFromFloor Point
pos

deleteItemEmbed :: MonadStateWrite m
                => ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemEmbed :: ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemEmbed iid :: ItemId
iid kit :: ItemQuant
kit lid :: LevelId
lid pos :: Point
pos =
  let rmFromFloor :: Maybe ItemBag -> Maybe ItemBag
rmFromFloor (Just bag :: ItemBag
bag) =
        let nbag :: ItemBag
nbag = ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag ItemQuant
kit ItemId
iid ItemBag
bag
        in if ItemBag -> Bool
forall k a. EnumMap k a -> Bool
EM.null ItemBag
nbag then Maybe ItemBag
forall a. Maybe a
Nothing else ItemBag -> Maybe ItemBag
forall a. a -> Maybe a
Just ItemBag
nbag
      rmFromFloor Nothing = String -> Maybe ItemBag
forall a. HasCallStack => String -> a
error (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ "item already removed"
                                    String -> (ItemId, ItemQuant, LevelId, Point) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemId
iid, ItemQuant
kit, LevelId
lid, Point
pos)
  in 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
$ (ItemFloor -> ItemFloor) -> Level -> Level
updateEmbed ((ItemFloor -> ItemFloor) -> Level -> Level)
-> (ItemFloor -> ItemFloor) -> Level -> Level
forall a b. (a -> b) -> a -> b
$ (Maybe ItemBag -> Maybe ItemBag) -> Point -> ItemFloor -> ItemFloor
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ItemBag -> Maybe ItemBag
rmFromFloor Point
pos

deleteItemActor :: MonadStateWrite m
                => ItemId -> ItemQuant -> ActorId -> CStore -> m ()
deleteItemActor :: ItemId -> ItemQuant -> ActorId -> CStore -> m ()
deleteItemActor iid :: ItemId
iid kit :: ItemQuant
kit aid :: ActorId
aid cstore :: CStore
cstore = case CStore
cstore of
  CGround -> 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
    ItemId -> ItemQuant -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> LevelId -> Point -> m ()
deleteItemFloor ItemId
iid ItemQuant
kit (Actor -> LevelId
blid Actor
b) (Actor -> Point
bpos Actor
b)
  COrgan -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
deleteItemOrgan ItemId
iid ItemQuant
kit ActorId
aid
  CEqp -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
deleteItemEqp ItemId
iid ItemQuant
kit ActorId
aid
  CInv -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
deleteItemInv ItemId
iid ItemQuant
kit ActorId
aid
  CSha -> 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
    ItemId -> ItemQuant -> FactionId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> FactionId -> m ()
deleteItemSha ItemId
iid ItemQuant
kit (Actor -> FactionId
bfid Actor
b)

deleteItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemOrgan :: ItemId -> ItemQuant -> ActorId -> m ()
deleteItemOrgan iid :: ItemId
iid kit :: ItemQuant
kit aid :: ActorId
aid = do
  AspectRecord
arItem <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> AspectRecord
aspectRecordFromIid ItemId
iid
  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
$ \b :: Actor
b ->
    Actor
b { borgan :: ItemBag
borgan = ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag ItemQuant
kit ItemId
iid (Actor -> ItemBag
borgan Actor
b)
      , bweapon :: Int
bweapon = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arItem
                  then Actor -> Int
bweapon Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                  else Actor -> Int
bweapon Actor
b }

deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemEqp :: ItemId -> ItemQuant -> ActorId -> m ()
deleteItemEqp iid :: ItemId
iid kit :: ItemQuant
kit aid :: ActorId
aid = do
  AspectRecord
arItem <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> AspectRecord
aspectRecordFromIid ItemId
iid
  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
$ \b :: Actor
b ->
    Actor
b { beqp :: ItemBag
beqp = ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag ItemQuant
kit ItemId
iid (Actor -> ItemBag
beqp Actor
b)
      , bweapon :: Int
bweapon = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arItem
                  then Actor -> Int
bweapon Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                  else Actor -> Int
bweapon Actor
b }

deleteItemInv :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemInv :: ItemId -> ItemQuant -> ActorId -> m ()
deleteItemInv iid :: ItemId
iid kit :: ItemQuant
kit aid :: ActorId
aid =
  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
$ \b :: Actor
b -> Actor
b {binv :: ItemBag
binv = ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag ItemQuant
kit ItemId
iid (Actor -> ItemBag
binv Actor
b)}

deleteItemSha :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m ()
deleteItemSha :: ItemId -> ItemQuant -> FactionId -> m ()
deleteItemSha iid :: ItemId
iid kit :: ItemQuant
kit fid :: FactionId
fid =
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid ((Faction -> Faction) -> m ()) -> (Faction -> Faction) -> m ()
forall a b. (a -> b) -> a -> b
$ \fact :: Faction
fact -> Faction
fact {gsha :: ItemBag
gsha = ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag ItemQuant
kit ItemId
iid (Faction -> ItemBag
gsha Faction
fact)}

-- Removing the part of the kit from the back of the list,
-- so that @DestroyItem kit (CreateItem kit x) == x@.
rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag
rmFromBag kit :: ItemQuant
kit@(k :: Int
k, rmIt :: ItemTimer
rmIt) iid :: ItemId
iid bag :: ItemBag
bag =
  let rfb :: Maybe ItemQuant -> Maybe ItemQuant
rfb Nothing = String -> Maybe ItemQuant
forall a. HasCallStack => String -> a
error (String -> Maybe ItemQuant) -> String -> Maybe ItemQuant
forall a b. (a -> b) -> a -> b
$ "rm from empty slot" String -> (Int, ItemId, ItemBag) -> String
forall v. Show v => String -> v -> String
`showFailure` (Int
k, ItemId
iid, ItemBag
bag)
      rfb (Just (n :: Int
n, it :: ItemTimer
it)) =
        case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n Int
k of
          LT -> String -> Maybe ItemQuant
forall a. HasCallStack => String -> a
error (String -> Maybe ItemQuant) -> String -> Maybe ItemQuant
forall a b. (a -> b) -> a -> b
$ "rm more than there is"
                        String -> (Int, ItemQuant, ItemId, ItemBag) -> String
forall v. Show v => String -> v -> String
`showFailure` (Int
n, ItemQuant
kit, ItemId
iid, ItemBag
bag)
          EQ -> Bool -> Maybe ItemQuant -> Maybe ItemQuant
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimer
rmIt ItemTimer -> ItemTimer -> Bool
forall a. Eq a => a -> a -> Bool
== ItemTimer
it Bool
-> (ItemTimer, ItemTimer, Int, ItemQuant, ItemId, ItemBag) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ItemTimer
rmIt, ItemTimer
it, Int
n, ItemQuant
kit, ItemId
iid, ItemBag
bag)) Maybe ItemQuant
forall a. Maybe a
Nothing
          GT -> Bool -> Maybe ItemQuant -> Maybe ItemQuant
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimer
rmIt ItemTimer -> ItemTimer -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ItemTimer -> ItemTimer
forall a. Int -> [a] -> [a]
take Int
k ItemTimer
it
                        Bool
-> (ItemTimer, ItemTimer, Int, ItemQuant, ItemId, ItemBag) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ItemTimer
rmIt, Int -> ItemTimer -> ItemTimer
forall a. Int -> [a] -> [a]
take Int
k ItemTimer
it, Int
n, ItemQuant
kit, ItemId
iid, ItemBag
bag))
                (Maybe ItemQuant -> Maybe ItemQuant)
-> Maybe ItemQuant -> Maybe ItemQuant
forall a b. (a -> b) -> a -> b
$ ItemQuant -> Maybe ItemQuant
forall a. a -> Maybe a
Just (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k, Int -> ItemTimer -> ItemTimer
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k) ItemTimer
it)
  in (Maybe ItemQuant -> Maybe ItemQuant)
-> ItemId -> ItemBag -> ItemBag
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ItemQuant -> Maybe ItemQuant
rfb ItemId
iid ItemBag
bag

-- Actor's items may or may not be already present in @sitemD@,
-- regardless if they are already present otherwise in the dungeon.
-- We re-add them all to save time determining which really need it.
-- If collision occurs, pick the item found on easier level.
addAis :: MonadStateWrite m => [(ItemId, Item)] -> m ()
addAis :: [(ItemId, Item)] -> m ()
addAis ais :: [(ItemId, Item)]
ais = do
  let h :: Item -> Item -> Item
h item1 :: Item
item1 item2 :: 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` "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 -- keep the first found level
  [(ItemId, Item)] -> ((ItemId, Item) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(ItemId, Item)]
ais (((ItemId, Item) -> m ()) -> m ())
-> ((ItemId, Item) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(iid :: ItemId
iid, item :: Item
item) -> do
    let f :: State -> State
f = case Item -> ItemIdentity
jkind Item
item of
          IdentityObvious _ -> State -> State
forall a. a -> a
id
          IdentityCovered ix :: ItemKindIx
ix _ ->
            (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)

itemsMatch :: Item -> Item -> Bool
itemsMatch :: Item -> Item -> Bool
itemsMatch item1 :: Item
item1 item2 :: Item
item2 =
  Item -> ItemIdentity
jkind Item
item1 ItemIdentity -> ItemIdentity -> Bool
forall a. Eq a => a -> a -> Bool
== Item -> ItemIdentity
jkind Item
item2
  -- Note that nothing else needs to be the same, since items are merged
  -- and clients have different views on dungeon items than the server.

addItemToActorMaxSkills :: MonadStateWrite m
                        => ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills :: ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills iid :: ItemId
iid itemBase :: Item
itemBase k :: Int
k aid :: ActorId
aid = do
  AspectRecord
arItem <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ ItemId -> Item -> State -> AspectRecord
aspectRecordFromItem ItemId
iid Item
itemBase
  let f :: Skills -> Skills
f actorMaxSk :: Skills
actorMaxSk =
        [(Skills, Int)] -> Skills
Ability.sumScaledSkills [(Skills
actorMaxSk, 1), (AspectRecord -> Skills
IA.aSkills AspectRecord
arItem, Int
k)]
  (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
$ (Skills -> Skills) -> ActorId -> ActorMaxSkills -> ActorMaxSkills
forall k a. Enum k => (a -> a) -> k -> EnumMap k a -> EnumMap k a
EM.adjust Skills -> Skills
f ActorId
aid

resetActorMaxSkills :: MonadStateWrite m => m ()
resetActorMaxSkills :: m ()
resetActorMaxSkills = do
  -- Each actor's equipment and organs would need to be inspected,
  -- the iid looked up, e.g., if it wasn't in old discoKind, but is in new,
  -- and then aspect record updated, so it's simpler and not much more
  -- expensive to generate new sactorMaxSkills. Optimize only after profiling.
  -- Also note this doesn't get invoked on the server, because it bails out
  -- earlier, upon noticing the item is already fully known.
  ActorMaxSkills
actorMaxSk <- (State -> ActorMaxSkills) -> m ActorMaxSkills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ActorMaxSkills
maxSkillsInDungeon
  (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
$ ActorMaxSkills -> ActorMaxSkills -> ActorMaxSkills
forall a b. a -> b -> a
const ActorMaxSkills
actorMaxSk