{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Common.ActorState
( fidActorNotProjAssocs, actorAssocs, actorRegularAssocs
, warActorRegularList, friendlyActorRegularList, fidActorRegularIds
, bagAssocs, bagAssocsK, calculateTotal
, mergeItemQuant, sharedEqp, sharedAllOwnedFid, findIid
, getContainerBag, getFloorBag, getEmbedBag, getBodyStoreBag
, mapActorItems_, getActorAssocs
, nearbyFreePoints, getCarriedAssocs, getCarriedIidCStore
, posToAidsLvl, posToAids, posToAssocs
, getItemBody, memActor, getActorBody, getLocalTime, regenCalmDelta
, actorInAmbient, canDeAmbientList, actorSkills, dispEnemy, fullAssocs
, storeFromC, lidFromC, posFromC, aidFromC, isEscape, isStair
, anyFoeAdj, actorAdjacentAssocs, armorHurtBonus
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import Data.Int (Int64)
import GHC.Exts (inline)
import qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.TileKind (TileKind)
fidActorNotProjAssocs :: FactionId -> State -> [(ActorId, Actor)]
fidActorNotProjAssocs fid s =
let f (_, b) = not (bproj b) && bfid b == fid
in filter f $ EM.assocs $ sactorD s
actorAssocs :: (FactionId -> Bool) -> LevelId -> State
-> [(ActorId, Actor)]
actorAssocs p lid s =
let f (_, b) = blid b == lid && p (bfid b)
in filter f $ EM.assocs $ sactorD s
actorRegularAssocs :: (FactionId -> Bool) -> LevelId -> State
-> [(ActorId, Actor)]
{-# INLINE actorRegularAssocs #-}
actorRegularAssocs p lid s =
let f (_, b) = not (bproj b) && blid b == lid && p (bfid b) && bhp b > 0
in filter f $ EM.assocs $ sactorD s
warActorRegularList :: FactionId -> LevelId -> State -> [Actor]
warActorRegularList fid lid s =
let fact = (EM.! fid) . sfactionD $ s
in map snd $ actorRegularAssocs (inline isAtWar fact) lid s
friendlyActorRegularList :: FactionId -> LevelId -> State -> [Actor]
friendlyActorRegularList fid lid s =
let fact = (EM.! fid) . sfactionD $ s
friendlyFid fid2 = fid2 == fid || inline isAllied fact fid2
in map snd $ actorRegularAssocs friendlyFid lid s
fidActorRegularIds :: FactionId -> LevelId -> State -> [ActorId]
fidActorRegularIds fid lid s =
map fst $ actorRegularAssocs (== fid) lid s
getItemBody :: ItemId -> State -> Item
getItemBody iid s =
let assFail = error $ "item body not found" `showFailure` (iid, s)
in EM.findWithDefault assFail iid $ sitemD s
bagAssocs :: State -> ItemBag -> [(ItemId, Item)]
bagAssocs s bag =
let iidItem iid = (iid, getItemBody iid s)
in map iidItem $ EM.keys bag
bagAssocsK :: State -> ItemBag -> [(ItemId, (Item, ItemQuant))]
bagAssocsK s bag =
let iidItem (iid, kit) = (iid, (getItemBody iid s, kit))
in map iidItem $ EM.assocs bag
posToAidsLvl :: Point -> Level -> [ActorId]
{-# INLINE posToAidsLvl #-}
posToAidsLvl pos lvl = EM.findWithDefault [] pos $ lactor lvl
posToAids :: Point -> LevelId -> State -> [ActorId]
posToAids pos lid s = posToAidsLvl pos $ sdungeon s EM.! lid
posToAssocs :: Point -> LevelId -> State -> [(ActorId, Actor)]
posToAssocs pos lid s =
let l = posToAidsLvl pos $ sdungeon s EM.! lid
in map (\aid -> (aid, getActorBody aid s)) l
nearbyFreePoints :: (Kind.Id TileKind -> Bool) -> Point -> LevelId -> State
-> [Point]
nearbyFreePoints f start lid s =
let lvl@Level{lxsize, lysize} = sdungeon s EM.! lid
good p = f (lvl `at` p)
&& Tile.isWalkable (Kind.coTileSpeedup $ scops s) (lvl `at` p)
&& null (posToAidsLvl p lvl)
ps = nub $ start : concatMap (vicinity lxsize lysize) ps
in filter good ps
calculateTotal :: FactionId -> State -> (ItemBag, Int)
calculateTotal fid s =
let bag = sharedAllOwned fid s
items = map (\(iid, (k, _)) -> (getItemBody iid s, k)) $ EM.assocs bag
in (bag, sum $ map itemPrice items)
mergeItemQuant :: ItemQuant -> ItemQuant -> ItemQuant
mergeItemQuant (k2, it2) (k1, it1) = (k1 + k2, it1 ++ it2)
sharedInv :: FactionId -> State -> ItemBag
sharedInv fid s =
let bs = inline fidActorNotProjAssocs fid s
in EM.unionsWith mergeItemQuant $ map (binv . snd) bs
sharedEqp :: FactionId -> State -> ItemBag
sharedEqp fid s =
let bs = inline fidActorNotProjAssocs fid s
in EM.unionsWith mergeItemQuant $ map (beqp . snd) bs
sharedAllOwned :: FactionId -> State -> ItemBag
sharedAllOwned fid s =
let shaBag = gsha $ sfactionD s EM.! fid
in EM.unionsWith mergeItemQuant [sharedEqp fid s, sharedInv fid s, shaBag]
sharedAllOwnedFid :: Bool -> FactionId -> State -> ItemBag
sharedAllOwnedFid onlyOrgans fid s =
let shaBag = gsha $ sfactionD s EM.! fid
bs = map snd $ inline fidActorNotProjAssocs fid s
in EM.unionsWith mergeItemQuant
$ if onlyOrgans
then map borgan bs
else map binv bs ++ map beqp bs ++ [shaBag]
findIid :: ActorId -> FactionId -> ItemId -> State
-> [(ActorId, (Actor, CStore))]
findIid leader fid iid s =
let actors = fidActorNotProjAssocs fid s
itemsOfActor (aid, b) =
let itemsOfCStore store =
let bag = getBodyStoreBag b store s
in map (\iid2 -> (iid2, (aid, (b, store)))) (EM.keys bag)
stores = [CInv, CEqp, COrgan] ++ [CSha | aid == leader]
in concatMap itemsOfCStore stores
items = concatMap itemsOfActor actors
in map snd $ filter ((== iid) . fst) items
getActorBody :: ActorId -> State -> Actor
{-# INLINE getActorBody #-}
getActorBody aid s = sactorD s EM.! aid
getCarriedAssocs :: Actor -> State -> [(ItemId, Item)]
getCarriedAssocs b s =
let trunk = EM.singleton (btrunk b) (1, [])
in bagAssocs s $ EM.unionsWith const [binv b, beqp b, borgan b, trunk]
getCarriedIidCStore :: Actor -> [(ItemId, CStore)]
getCarriedIidCStore b =
let trunk = EM.singleton (btrunk b) (1, [])
bagCarried (cstore, bag) = map (,cstore) $ EM.keys bag
in concatMap bagCarried [ (CInv, binv b)
, (CEqp, beqp b)
, (COrgan, EM.unionWith const (borgan b) trunk) ]
getContainerBag :: Container -> State -> ItemBag
getContainerBag c s = case c of
CFloor lid p -> getFloorBag lid p s
CEmbed lid p -> getEmbedBag lid p s
CActor aid cstore -> let b = getActorBody aid s
in getBodyStoreBag b cstore s
CTrunk{} -> error $ "" `showFailure` c
getFloorBag :: LevelId -> Point -> State -> ItemBag
getFloorBag lid p s = EM.findWithDefault EM.empty p
$ lfloor (sdungeon s EM.! lid)
getEmbedBag :: LevelId -> Point -> State -> ItemBag
getEmbedBag lid p s = EM.findWithDefault EM.empty p
$ lembed (sdungeon s EM.! lid)
getBodyStoreBag :: Actor -> CStore -> State -> ItemBag
getBodyStoreBag b cstore s =
case cstore of
CGround -> getFloorBag (blid b) (bpos b) s
COrgan -> borgan b
CEqp -> beqp b
CInv -> binv b
CSha -> gsha $ sfactionD s EM.! bfid b
mapActorItems_ :: Monad m
=> (CStore -> ItemId -> ItemQuant -> m a) -> Actor
-> State
-> m ()
mapActorItems_ f b s = do
let notProcessed = [CGround]
sts = [minBound..maxBound] \\ notProcessed
g cstore = do
let bag = getBodyStoreBag b cstore s
mapM_ (uncurry $ f cstore) $ EM.assocs bag
mapM_ g sts
getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)]
getActorAssocs aid cstore s =
let b = getActorBody aid s
in bagAssocs s $ getBodyStoreBag b cstore s
getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, ItemQuant))]
getActorAssocsK aid cstore s =
let b = getActorBody aid s
in bagAssocsK s $ getBodyStoreBag b cstore s
memActor :: ActorId -> LevelId -> State -> Bool
memActor aid lid s =
maybe False ((== lid) . blid) $ EM.lookup aid $ sactorD s
getLocalTime :: LevelId -> State -> Time
getLocalTime lid s = ltime $ sdungeon s EM.! lid
regenCalmDelta :: Actor -> AspectRecord -> State -> Int64
regenCalmDelta body AspectRecord{aMaxCalm} s =
let calmIncr = oneM
maxDeltaCalm = xM aMaxCalm - bcalm body
fact = (EM.! bfid body) . sfactionD $ s
isHeardFoe b = blid b == blid body
&& chessDist (bpos b) (bpos body) <= 3
&& not (waitedLastTurn b)
&& inline isAtWar fact (bfid b)
in if any isHeardFoe $ EM.elems $ sactorD s
then minusM
else min calmIncr (max 0 maxDeltaCalm)
actorInAmbient :: Actor -> State -> Bool
actorInAmbient b s =
let lvl = (EM.! blid b) . sdungeon $ s
in Tile.isLit (Kind.coTileSpeedup $ scops s) (lvl `at` bpos b)
canDeAmbientList :: Actor -> State -> [Point]
canDeAmbientList b s =
let Kind.COps{coTileSpeedup} = scops s
lvl = (EM.! blid b) . sdungeon $ s
posDeAmbient p =
let t = lvl `at` p
in Tile.isWalkable coTileSpeedup t
&& not (Tile.isLit coTileSpeedup t)
in if Tile.isLit coTileSpeedup (lvl `at` bpos b)
then filter posDeAmbient (vicinityUnsafe $ bpos b)
else []
actorSkills :: Maybe ActorId -> ActorId -> AspectRecord -> State
-> Ability.Skills
actorSkills mleader aid ar s =
let body = getActorBody aid s
player = gplayer . (EM.! bfid body) . sfactionD $ s
skillsFromTactic = Ability.tacticSkills $ ftactic player
factionSkills
| Just aid == mleader = Ability.zeroSkills
| otherwise = fskillsOther player `Ability.addSkills` skillsFromTactic
itemSkills = aSkills ar
in itemSkills `Ability.addSkills` factionSkills
dispEnemy :: ActorId -> ActorId -> Ability.Skills -> State -> Bool
dispEnemy source target actorMaxSk s =
let hasSupport b =
let adjacentAssocs = actorAdjacentAssocs b s
fact = (EM.! bfid b) . sfactionD $ s
friendlyFid fid = fid == bfid b || isAllied fact fid
friend (_, b2) =
not (bproj b2) && friendlyFid (bfid b2) && bhp b2 > 0
in any friend adjacentAssocs
sb = getActorBody source s
tb = getActorBody target s
in bproj tb
|| not (isAtWar ((EM.! bfid tb) . sfactionD $ s) (bfid sb))
|| not (actorDying tb
|| braced tb
|| EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0
|| hasSupport sb && hasSupport tb)
fullAssocs :: Kind.COps -> DiscoveryKind -> DiscoveryAspect
-> ActorId -> [CStore] -> State
-> [(ItemId, ItemFull)]
fullAssocs cops disco discoAspect aid cstores s =
let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores
iToFull (iid, (item, kit)) =
(iid, itemToFull cops disco discoAspect iid item kit)
in map iToFull allAssocs
storeFromC :: Container -> CStore
storeFromC c = case c of
CFloor{} -> CGround
CEmbed{} -> CGround
CActor _ cstore -> cstore
CTrunk{} -> error $ "" `showFailure` c
aidFromC :: Container -> Maybe ActorId
aidFromC CFloor{} = Nothing
aidFromC CEmbed{} = Nothing
aidFromC (CActor aid _) = Just aid
aidFromC c@CTrunk{} = error $ "" `showFailure` c
lidFromC :: Container -> State -> LevelId
lidFromC (CFloor lid _) _ = lid
lidFromC (CEmbed lid _) _ = lid
lidFromC (CActor aid _) s = blid $ getActorBody aid s
lidFromC c@CTrunk{} _ = error $ "" `showFailure` c
posFromC :: Container -> State -> Point
posFromC (CFloor _ pos) _ = pos
posFromC (CEmbed _ pos) _ = pos
posFromC (CActor aid _) s = bpos $ getActorBody aid s
posFromC c@CTrunk{} _ = error $ "" `showFailure` c
isEscape :: LevelId -> Point -> State -> Bool
isEscape lid p s =
let bag = getEmbedBag lid p s
is = map (`getItemBody` s) $ EM.keys bag
isE Item{jname} = jname == "escape"
in any isE is
isStair :: LevelId -> Point -> State -> Bool
isStair lid p s =
let bag = getEmbedBag lid p s
is = map (`getItemBody` s) $ EM.keys bag
isE Item{jname} = jname == "staircase up" || jname == "staircase down"
in any isE is
anyFoeAdj :: ActorId -> State -> Bool
anyFoeAdj aid s =
let body = getActorBody aid s
lvl = (EM.! blid body) . sdungeon $ s
fact = (EM.! bfid body) . sfactionD $ s
f !mv = case posToAidsLvl (shift (bpos body) mv) lvl of
[] -> False
aid2 : _ -> g $ getActorBody aid2 s
g !b = isAtWar fact (bfid b) && bhp b > 0
in any f moves
actorAdjacentAssocs :: Actor -> State -> [(ActorId, Actor)]
{-# INLINE actorAdjacentAssocs #-}
actorAdjacentAssocs body s =
let lvl = (EM.! blid body) . sdungeon $ s
f !mv = posToAidsLvl (shift (bpos body) mv) lvl
g !aid = (aid, getActorBody aid s)
in map g $ concatMap f moves
armorHurtBonus :: ActorAspect -> ActorId -> ActorId -> State -> Int
armorHurtBonus actorAspect source target s =
let sb = getActorBody source s
tb = getActorBody target s
trim200 n = min 200 $ max (-200) n
block200 b n = min 200 $ max (-200) $ n + if braced tb then b else 0
sar = actorAspect EM.! source
tar = actorAspect EM.! target
itemBonus = trim200 (aHurtMelee sar) - if bproj sb
then block200 25 (aArmorRanged tar)
else block200 50 (aArmorMelee tar)
in 100 + min 99 (max (-99) itemBonus)