-- | 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
  , itemsMatch, addItemToActorMaxSkills, resetActorMaxSkills
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , insertItemFloor, insertItemEmbed
  , insertItemOrgan, insertItemEqp, insertItemStash
  , deleteItemFloor, deleteItemEmbed
  , deleteItemOrgan, deleteItemEqp, deleteItemStash
  , rmFromBag
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Control.Exception as Ex
import qualified Data.EnumMap.Strict as EM
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.Point
import           Game.LambdaHack.Common.State
import           Game.LambdaHack.Common.Types
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 LevelId
lid 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.
updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m ()
updateActor :: ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid Actor -> Actor
f = do
  let alt :: Maybe Actor -> Maybe Actor
alt 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
"no body to update" String -> ActorId -> String
forall v. Show v => String -> v -> String
`showFailure` ActorId
aid
      alt (Just 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 FactionId
fid Faction -> Faction
f = do
  let alt :: Maybe Faction -> Maybe Faction
alt Maybe Faction
Nothing = String -> Maybe Faction
forall a. HasCallStack => String -> a
error (String -> Maybe Faction) -> String -> Maybe Faction
forall a b. (a -> b) -> a -> b
$ String
"no faction to update" String -> FactionId -> String
forall v. Show v => String -> v -> String
`showFailure` FactionId
fid
      alt (Just 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 ActorId
aid Actor
body Actor
newBody = do
  let rmBig :: Maybe ActorId -> Maybe ActorId
rmBig 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)
      rmBig (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
      addBig :: Maybe ActorId -> Maybe ActorId
addBig Maybe ActorId
Nothing = ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aid
      addBig (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)
      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 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)
      rmProj (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)
      addProj :: Maybe [ActorId] -> Maybe [ActorId]
addProj Maybe [ActorId]
Nothing = [ActorId] -> Maybe [ActorId]
forall a. a -> Maybe a
Just [ActorId
aid]
      addProj (Just [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 ActorId
source Actor
sbody ActorId
target Actor
tbody = do
  let addBig :: ActorId -> ActorId -> Maybe ActorId -> Maybe ActorId
addBig ActorId
aid1 ActorId
aid2 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, 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 ActorId
_aid1 ActorId
aid2 (Just ActorId
_aid) =
#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
_aid1 Bool -> (String, (ActorId, ActorId, ActorId, Actor, Actor)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"wrong actor present"
                              String
-> (ActorId, ActorId, ActorId, Actor, Actor)
-> (String, (ActorId, ActorId, ActorId, Actor, Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
_aid, ActorId
_aid1, ActorId
aid2, Actor
sbody, Actor
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 ItemBag
bag Container
c = case Container
c of
  CFloor LevelId
lid Point
pos -> do
    let alt :: Maybe ItemBag -> Maybe ItemBag
alt Maybe ItemBag
Nothing = ItemBag -> Maybe ItemBag
forall a. a -> Maybe a
Just ItemBag
bag
        alt (Just ItemBag
bag2) = String -> Maybe ItemBag
forall a. String -> a
atomicFail (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ String
"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 LevelId
lid Point
pos -> do
    let alt :: Maybe ItemBag -> Maybe ItemBag
alt Maybe ItemBag
Nothing = ItemBag -> Maybe ItemBag
forall a. a -> Maybe a
Just ItemBag
bag
        alt (Just ItemBag
bag2) = String -> Maybe ItemBag
forall a. String -> a
atomicFail (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ String
"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 ActorId
aid 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_ (\Key (EnumMap ItemId)
iid 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 ItemId
iid ItemQuant
kit Container
c = case Container
c of
  CFloor LevelId
lid 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 LevelId
lid 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 ActorId
aid 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 ItemId
iid ItemQuant
kit LevelId
lid 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 ItemId
iid ItemQuant
kit LevelId
lid 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 ItemId
iid ItemQuant
kit ActorId
aid CStore
cstore = case CStore
cstore of
  CStore
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)
  CStore
COrgan -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
insertItemOrgan ItemId
iid ItemQuant
kit ActorId
aid
  CStore
CEqp -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
insertItemEqp ItemId
iid ItemQuant
kit ActorId
aid
  CStore
CStash -> 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 ()
insertItemStash ItemId
iid ItemQuant
kit (Actor -> FactionId
bfid Actor
b)

-- We assume @Meleeable@ and @Benign@ are never secret and so we don't need
-- to fix the weapon counts when the item is identified later on.
insertItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
insertItemOrgan :: ItemId -> ItemQuant -> ActorId -> m ()
insertItemOrgan ItemId
iid kit :: ItemQuant
kit@(Int
k, ItemTimers
_) 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
$ \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
+ Int
k
                  else Actor -> Int
bweapon Actor
b
      , bweapBenign :: Int
bweapBenign = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arItem
                         Bool -> Bool -> Bool
&& Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Benign AspectRecord
arItem
                      then Actor -> Int
bweapBenign Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k
                      else Actor -> Int
bweapBenign Actor
b }

insertItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
insertItemEqp :: ItemId -> ItemQuant -> ActorId -> m ()
insertItemEqp ItemId
iid kit :: ItemQuant
kit@(Int
k, ItemTimers
_) 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
$ \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
+ Int
k
                  else Actor -> Int
bweapon Actor
b
      , bweapBenign :: Int
bweapBenign = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arItem
                         Bool -> Bool -> Bool
&& Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Benign AspectRecord
arItem
                      then Actor -> Int
bweapBenign Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k
                      else Actor -> Int
bweapBenign Actor
b }

insertItemStash :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m ()
insertItemStash :: ItemId -> ItemQuant -> FactionId -> m ()
insertItemStash ItemId
iid ItemQuant
kit FactionId
fid = do
  Maybe (LevelId, Point)
mstash <- (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point)))
-> (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall a b. (a -> b) -> a -> b
$ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
  case Maybe (LevelId, Point)
mstash of
    Just (LevelId
lid, 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
      -- can't be inserted into outdated or unseen stash position,
      -- because such commands are visible only when the stash position is
      -- and so @gstash@ points at the correct one, thanks to @atomicRemember@
    Maybe (LevelId, Point)
Nothing -> String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String -> (ItemId, ItemQuant, FactionId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemId
iid, ItemQuant
kit, FactionId
fid)

deleteBagContainer :: MonadStateWrite m
                   => ItemBag -> Container -> m ()
deleteBagContainer :: ItemBag -> Container -> m ()
deleteBagContainer ItemBag
bag Container
c = case Container
c of
  CFloor LevelId
lid Point
pos -> do
    let alt :: Maybe ItemBag -> Maybe ItemBag
alt Maybe ItemBag
Nothing = String -> Maybe ItemBag
forall a. String -> a
atomicFail (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ String
"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 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 LevelId
lid Point
pos -> do
    let alt :: Maybe ItemBag -> Maybe ItemBag
alt Maybe ItemBag
Nothing = String -> Maybe ItemBag
forall a. String -> a
atomicFail (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ String
"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 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 ActorId
aid 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_ (\Key (EnumMap ItemId)
iid 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
"" 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 ItemId
iid ItemQuant
kit Container
c = case Container
c of
  CFloor LevelId
lid 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 LevelId
lid 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 ActorId
aid 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
"" 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 ItemId
iid ItemQuant
kit LevelId
lid Point
pos =
  let rmFromFloor :: Maybe ItemBag -> Maybe ItemBag
rmFromFloor (Just 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 Maybe ItemBag
Nothing = String -> Maybe ItemBag
forall a. HasCallStack => String -> a
error (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ String
"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 ItemId
iid ItemQuant
kit LevelId
lid Point
pos =
  let rmFromFloor :: Maybe ItemBag -> Maybe ItemBag
rmFromFloor (Just 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 Maybe ItemBag
Nothing = String -> Maybe ItemBag
forall a. HasCallStack => String -> a
error (String -> Maybe ItemBag) -> String -> Maybe ItemBag
forall a b. (a -> b) -> a -> b
$ String
"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 ItemId
iid ItemQuant
kit ActorId
aid CStore
cstore = case CStore
cstore of
  CStore
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)
  CStore
COrgan -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
deleteItemOrgan ItemId
iid ItemQuant
kit ActorId
aid
  CStore
CEqp -> ItemId -> ItemQuant -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> m ()
deleteItemEqp ItemId
iid ItemQuant
kit ActorId
aid
  CStore
CStash -> 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 ()
deleteItemStash ItemId
iid ItemQuant
kit (Actor -> FactionId
bfid Actor
b)

deleteItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemOrgan :: ItemId -> ItemQuant -> ActorId -> m ()
deleteItemOrgan ItemId
iid kit :: ItemQuant
kit@(Int
k, ItemTimers
_) 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
$ \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
- Int
k
                  else Actor -> Int
bweapon Actor
b
      , bweapBenign :: Int
bweapBenign = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arItem
                         Bool -> Bool -> Bool
&& Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Benign AspectRecord
arItem
                      then Actor -> Int
bweapBenign Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k
                      else Actor -> Int
bweapBenign Actor
b }

deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()
deleteItemEqp :: ItemId -> ItemQuant -> ActorId -> m ()
deleteItemEqp ItemId
iid kit :: ItemQuant
kit@(Int
k, ItemTimers
_) 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
$ \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
- Int
k
                  else Actor -> Int
bweapon Actor
b
      , bweapBenign :: Int
bweapBenign = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arItem
                         Bool -> Bool -> Bool
&& Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Benign AspectRecord
arItem
                      then Actor -> Int
bweapBenign Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k
                      else Actor -> Int
bweapBenign Actor
b }

deleteItemStash :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m ()
deleteItemStash :: ItemId -> ItemQuant -> FactionId -> m ()
deleteItemStash ItemId
iid ItemQuant
kit FactionId
fid = do
  Maybe (LevelId, Point)
mstash <- (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point)))
-> (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall a b. (a -> b) -> a -> b
$ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
  case Maybe (LevelId, Point)
mstash of
    Just (LevelId
lid, 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
      -- can't be deleted from an outdated or unseen stash position,
      -- because such commands are visible only when the stash position is
      -- and so @gstash@ points at the correct one, thanks to @atomicRemember@
    Maybe (LevelId, Point)
Nothing -> String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String -> (ItemId, ItemQuant, FactionId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemId
iid, ItemQuant
kit, FactionId
fid)

-- 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@(Int
k, ItemTimers
rmIt) ItemId
iid ItemBag
bag =
  let rfb :: Maybe ItemQuant -> Maybe ItemQuant
rfb Maybe ItemQuant
Nothing = String -> Maybe ItemQuant
forall a. HasCallStack => String -> a
error (String -> Maybe ItemQuant) -> String -> Maybe ItemQuant
forall a b. (a -> b) -> a -> b
$ String
"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 (Int
n, ItemTimers
it)) =
        case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n Int
k of
          Ordering
LT -> String -> Maybe ItemQuant
forall a. HasCallStack => String -> a
error (String -> Maybe ItemQuant) -> String -> Maybe ItemQuant
forall a b. (a -> b) -> a -> b
$ String
"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)
          Ordering
EQ -> Bool -> Maybe ItemQuant -> Maybe ItemQuant
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimers
rmIt ItemTimers -> ItemTimers -> Bool
forall a. Eq a => a -> a -> Bool
== ItemTimers
it Bool
-> (ItemTimers, ItemTimers, Int, ItemQuant, ItemId, ItemBag)
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ItemTimers
rmIt, ItemTimers
it, Int
n, ItemQuant
kit, ItemId
iid, ItemBag
bag)) Maybe ItemQuant
forall a. Maybe a
Nothing
          Ordering
GT -> Bool -> Maybe ItemQuant -> Maybe ItemQuant
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimers
rmIt ItemTimers -> ItemTimers -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
k ItemTimers
it
                        Bool
-> (ItemTimers, ItemTimers, Int, ItemQuant, ItemId, ItemBag)
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ItemTimers
rmIt, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
k ItemTimers
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 -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k) ItemTimers
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

itemsMatch :: Item -> Item -> Bool
itemsMatch :: Item -> Item -> Bool
itemsMatch Item
item1 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 ItemId
iid Item
itemBase Int
k 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 Skills
actorMaxSk =
        [(Skills, Int)] -> Skills
Ability.sumScaledSkills [(Skills
actorMaxSk, Int
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