module Game.LambdaHack.Common.ActorState
( fidActorNotProjAssocs, fidActorNotProjList
, actorAssocsLvl, actorAssocs, actorList
, actorRegularAssocsLvl, actorRegularAssocs, actorRegularList
, bagAssocs, bagAssocsK, calculateTotal
, mergeItemQuant, sharedAllOwnedFid, findIid
, getCBag, getActorBag, getBodyActorBag, mapActorItems_, getActorAssocs
, nearbyFreePoints, whereTo, getCarriedAssocs, getCarriedIidCStore
, posToActors, getItemBody, memActor, getActorBody
, tryFindHeroK, getLocalTime, itemPrice, regenCalmDelta
, actorInAmbient, actorSkills, dispEnemy, fullAssocs, itemToFull
, goesIntoEqp, goesIntoInv, goesIntoSha, eqpOverfull, eqpFreeN
, storeFromC, lidFromC, aidFromC, hasCharge
, strongestMelee, isMelee, isMeleeEqp
) where
import Control.Applicative
import Control.Exception.Assert.Sugar
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import Data.Int (Int64)
import Data.List
import Data.Maybe
import qualified Data.Ord as Ord
import qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Actor
import qualified Game.LambdaHack.Common.Dice as Dice
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import Game.LambdaHack.Common.ItemStrongest
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 qualified Game.LambdaHack.Content.ItemKind as IK
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
fidActorNotProjList :: FactionId -> State -> [Actor]
fidActorNotProjList fid s = map snd $ fidActorNotProjAssocs fid s
actorAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict
-> [(ActorId, Actor)]
actorAssocsLvl p lvl actorD =
mapMaybe (\aid -> let b = actorD EM.! aid
in if p (bfid b)
then Just (aid, b)
else Nothing)
$ concat $ EM.elems $ lprio lvl
actorAssocs :: (FactionId -> Bool) -> LevelId -> State
-> [(ActorId, Actor)]
actorAssocs p lid s =
actorAssocsLvl p (sdungeon s EM.! lid) (sactorD s)
actorList :: (FactionId -> Bool) -> LevelId -> State
-> [Actor]
actorList p lid s = map snd $ actorAssocs p lid s
actorRegularAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict
-> [(ActorId, Actor)]
actorRegularAssocsLvl p lvl actorD =
mapMaybe (\aid -> let b = actorD EM.! aid
in if not (bproj b) && bhp b > 0 && p (bfid b)
then Just (aid, b)
else Nothing)
$ concat $ EM.elems $ lprio lvl
actorRegularAssocs :: (FactionId -> Bool) -> LevelId -> State
-> [(ActorId, Actor)]
actorRegularAssocs p lid s =
actorRegularAssocsLvl p (sdungeon s EM.! lid) (sactorD s)
actorRegularList :: (FactionId -> Bool) -> LevelId -> State
-> [Actor]
actorRegularList p lid s = map snd $ actorRegularAssocs p lid s
getItemBody :: ItemId -> State -> Item
getItemBody iid s =
let assFail = assert `failure` "item body not found" `twith` (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
posToActors :: Point -> LevelId -> State -> [(ActorId, Actor)]
posToActors pos lid s =
let as = actorAssocs (const True) lid s
l = filter (\(_, b) -> bpos b == pos) as
in assert (length l <= 1 || all (bproj . snd) l
`blame` "many actors at the same position" `twith` l)
l
nearbyFreePoints :: (Kind.Id TileKind -> Bool) -> Point -> LevelId -> State
-> [Point]
nearbyFreePoints f start lid s =
let Kind.COps{cotile} = scops s
lvl@Level{lxsize, lysize} = sdungeon s EM.! lid
as = actorList (const True) lid s
good p = f (lvl `at` p)
&& Tile.isWalkable cotile (lvl `at` p)
&& unoccupied as p
ps = nub $ start : concatMap (vicinity lxsize lysize) ps
in filter good ps
calculateTotal :: Actor -> State -> (ItemBag, Int)
calculateTotal body s =
let bag = sharedAllOwned body s
items = map (\(iid, (k, _)) -> (getItemBody iid s, k)) $ EM.assocs bag
in (bag, sum $ map itemPrice items)
mergeItemQuant :: ItemQuant -> ItemQuant -> ItemQuant
mergeItemQuant (k1, it1) (k2, it2) = (k1 + k2, it1 ++ it2)
sharedInv :: Actor -> State -> ItemBag
sharedInv body s =
let bs = fidActorNotProjList (bfid body) s
in EM.unionsWith mergeItemQuant
$ map binv $ if null bs then [body] else bs
sharedEqp :: Actor -> State -> ItemBag
sharedEqp body s =
let bs = fidActorNotProjList (bfid body) s
in EM.unionsWith mergeItemQuant
$ map beqp $ if null bs then [body] else bs
sharedAllOwned :: Actor -> State -> ItemBag
sharedAllOwned body s =
let shaBag = gsha $ sfactionD s EM.! bfid body
in EM.unionsWith mergeItemQuant [sharedEqp body s, sharedInv body s, shaBag]
sharedAllOwnedFid :: Bool -> FactionId -> State -> ItemBag
sharedAllOwnedFid onlyOrgans fid s =
let shaBag = gsha $ sfactionD s EM.! fid
bs = fidActorNotProjList 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 -> [(Actor, CStore)]
findIid leader fid iid s =
let actors = fidActorNotProjAssocs fid s
itemsOfActor (aid, b) =
let itemsOfCStore store =
let bag = getBodyActorBag b store s
in map (\iid2 -> (iid2, (b, store))) (EM.keys bag)
stores = [CInv, CEqp] ++ [CSha | aid == leader]
in concatMap itemsOfCStore stores
items = concatMap itemsOfActor actors
in map snd $ filter ((== iid) . fst) items
itemPrice :: (Item, Int) -> Int
itemPrice (item, jcount) =
case jsymbol item of
'$' -> jcount
'*' -> jcount * 100
_ -> 0
tryFindActor :: State -> (Actor -> Bool) -> Maybe (ActorId, Actor)
tryFindActor s p =
find (p . snd) $ EM.assocs $ sactorD s
tryFindHeroK :: FactionId -> Int -> State -> Maybe (ActorId, Actor)
tryFindHeroK fact k s =
let c | k == 0 = '@'
| k > 0 && k < 10 = Char.intToDigit k
| otherwise = assert `failure` "no digit" `twith` k
in tryFindActor s (\body -> bsymbol body == c
&& not (bproj body)
&& bfid body == fact)
whereTo :: LevelId
-> Point
-> Int
-> Dungeon
-> (LevelId, Point)
whereTo lid pos k dungeon = assert (k /= 0) $
let lvl = dungeon EM.! lid
stairs = (if k < 0 then snd else fst) (lstair lvl)
defaultStairs = 0
mindex = elemIndex pos stairs
i = fromMaybe defaultStairs mindex
in case ascendInBranch dungeon k lid of
[] | isNothing mindex -> (lid, pos)
[] -> assert `failure` "no dungeon level to go to" `twith` (lid, pos, k)
ln : _ -> let lvlTgt = dungeon EM.! ln
stairsTgt = (if k < 0 then fst else snd) (lstair lvlTgt)
in if length stairsTgt < i + 1
then assert `failure` "no stairs at index"
`twith` (lid, pos, k, ln, stairsTgt, i)
else (ln, stairsTgt !! i)
getActorBody :: ActorId -> State -> Actor
getActorBody aid s =
let assFail = assert `failure` "body not found" `twith` (aid, s)
in EM.findWithDefault assFail aid $ sactorD s
getCarriedAssocs :: Actor -> State -> [(ItemId, Item)]
getCarriedAssocs b s =
bagAssocs s $ EM.unionsWith const [binv b, beqp b, borgan b]
getCarriedIidCStore :: Actor -> [(ItemId, CStore)]
getCarriedIidCStore b =
let bagCarried (cstore, bag) = map (,cstore) $ EM.keys bag
in concatMap bagCarried
[(CInv, binv b), (CEqp, beqp b), (COrgan, borgan b)]
getCBag :: Container -> State -> ItemBag
getCBag c s = case c of
CFloor lid p -> EM.findWithDefault EM.empty p
$ lfloor (sdungeon s EM.! lid)
CEmbed lid p -> EM.findWithDefault EM.empty p
$ lembed (sdungeon s EM.! lid)
CActor aid cstore -> getActorBag aid cstore s
CTrunk{} -> assert `failure` c
getActorBag :: ActorId -> CStore -> State -> ItemBag
getActorBag aid cstore s =
let b = getActorBody aid s
in getBodyActorBag b cstore s
getBodyActorBag :: Actor -> CStore -> State -> ItemBag
getBodyActorBag b cstore s =
case cstore of
CGround -> EM.findWithDefault EM.empty (bpos b)
$ lfloor (sdungeon s EM.! blid b)
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 = getBodyActorBag b cstore s
mapM_ (uncurry $ f cstore) $ EM.assocs bag
mapM_ g sts
getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)]
getActorAssocs aid cstore s = bagAssocs s $ getActorBag aid cstore s
getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, ItemQuant))]
getActorAssocsK aid cstore s = bagAssocsK s $ getActorBag aid 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 -> [ItemFull] -> State -> Int64
regenCalmDelta b activeItems s =
let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems
calmIncr = oneM
maxDeltaCalm = xM calmMax bcalm b
fact = (EM.! bfid b) . sfactionD $ s
allFoes = actorRegularList (isAtWar fact) (blid b) s
isHeard body = not (waitedLastTurn body)
&& chessDist (bpos b) (bpos body) <= 3
noisyFoes = filter isHeard allFoes
in if null noisyFoes
then min calmIncr maxDeltaCalm
else minusM
actorInAmbient :: Actor -> State -> Bool
actorInAmbient b s =
let Kind.COps{cotile} = scops s
lvl = (EM.! blid b) . sdungeon $ s
in Tile.isLit cotile (lvl `at` bpos b)
actorSkills :: Maybe ActorId -> ActorId -> [ItemFull] -> State -> Ability.Skills
actorSkills mleader aid activeItems s =
let body = getActorBody aid s
player = gplayer . (EM.! bfid body) . sfactionD $ s
skillsFromTactic = tacticSkills $ ftactic player
factionSkills
| Just aid == mleader = Ability.zeroSkills
| otherwise = fskillsOther player `Ability.addSkills` skillsFromTactic
itemSkills = sumSkills activeItems
in itemSkills `Ability.addSkills` factionSkills
tacticSkills :: Tactic -> Ability.Skills
tacticSkills TExplore = Ability.zeroSkills
tacticSkills TFollow = Ability.zeroSkills
tacticSkills TFollowNoItems = Ability.ignoreItems
tacticSkills TMeleeAndRanged = Ability.meleeAndRanged
tacticSkills TMeleeAdjacent = Ability.meleeAdjacent
tacticSkills TBlock = Ability.blockOnly
tacticSkills TRoam = Ability.zeroSkills
tacticSkills TPatrol = Ability.zeroSkills
dispEnemy :: ActorId -> ActorId -> [ItemFull] -> State -> Bool
dispEnemy source target activeItems s =
let hasSupport b =
let fact = (EM.! bfid b) . sfactionD $ s
friendlyFid fid = fid == bfid b || isAllied fact fid
sup = actorRegularList friendlyFid (blid b) s
in any (adjacent (bpos b) . bpos) sup
actorMaxSk = sumSkills activeItems
sb = getActorBody source s
tb = getActorBody target s
in bproj tb
|| not (actorDying tb
|| braced tb
|| EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0
|| hasSupport sb && hasSupport tb)
fullAssocs :: Kind.COps -> DiscoveryKind -> DiscoveryEffect
-> ActorId -> [CStore] -> State
-> [(ItemId, ItemFull)]
fullAssocs cops disco discoEffect aid cstores s =
let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores
iToFull (iid, (item, kit)) =
(iid, itemToFull cops disco discoEffect iid item kit)
in map iToFull allAssocs
itemToFull :: Kind.COps -> DiscoveryKind -> DiscoveryEffect -> ItemId -> Item
-> ItemQuant
-> ItemFull
itemToFull Kind.COps{coitem=Kind.Ops{okind}}
disco discoEffect iid itemBase (itemK, itemTimer) =
let itemDisco = case EM.lookup (jkindIx itemBase) disco of
Nothing -> Nothing
Just itemKindId -> Just ItemDisco{ itemKindId
, itemKind = okind itemKindId
, itemAE = EM.lookup iid discoEffect }
in ItemFull {..}
goesIntoEqp :: ItemFull -> Bool
goesIntoEqp itemFull = isJust (strengthEqpSlot $ itemBase itemFull)
goesIntoInv :: ItemFull -> Bool
goesIntoInv itemFull = IK.Precious `notElem` jfeature (itemBase itemFull)
&& not (goesIntoEqp itemFull)
goesIntoSha :: ItemFull -> Bool
goesIntoSha itemFull = IK.Precious `elem` jfeature (itemBase itemFull)
&& not (goesIntoEqp itemFull)
eqpOverfull :: Actor -> Int -> Bool
eqpOverfull b n = let size = sum $ map fst $ EM.elems $ beqp b
in assert (size <= 10 `blame` (b, n, size))
$ size + n > 10
eqpFreeN :: Actor -> Int
eqpFreeN b = let size = sum $ map fst $ EM.elems $ beqp b
in assert (size <= 10 `blame` (b, size))
$ 10 size
storeFromC :: Container -> CStore
storeFromC c = case c of
CFloor{} -> CGround
CEmbed{} -> CGround
CActor _ cstore -> cstore
CTrunk{} -> assert `failure` c
lidFromC :: Container -> State -> LevelId
lidFromC (CFloor lid _) _ = lid
lidFromC (CEmbed lid _) _ = lid
lidFromC (CActor aid _) s = blid $ getActorBody aid s
lidFromC c@CTrunk{} _ = assert `failure` c
aidFromC :: Container -> Maybe ActorId
aidFromC CFloor{} = Nothing
aidFromC CEmbed{} = Nothing
aidFromC (CActor aid _) = Just aid
aidFromC c@CTrunk{} = assert `failure` c
hasCharge :: Time -> ItemFull -> Bool
hasCharge localTime itemFull@ItemFull{..} =
let it1 = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of
Nothing -> []
Just timeout ->
let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout
charging startT = timeShift startT timeoutTurns > localTime
in filter charging itemTimer
len = length it1
in len < itemK
strMelee :: Bool -> Time -> ItemFull -> Maybe Int
strMelee effectBonus localTime itemFull =
let durable = IK.Durable `elem` jfeature (itemBase itemFull)
recharged = hasCharge localTime itemFull
p (IK.Hurt d) = [Dice.meanDice d]
p (IK.Burn d) = [Dice.meanDice d]
p IK.NoEffect{} = []
p IK.OnSmash{} = []
p (IK.Recharging IK.Summon{}) = [999 | recharged && effectBonus]
p IK.Recharging{} = [100 | recharged && effectBonus]
p IK.Temporary{} = []
p _ = [100 | effectBonus]
psum = sum (strengthEffect p itemFull)
in if not (isMelee itemFull) || psum == 0
then Nothing
else Just $ psum + if durable then 1000 else 0
strongestMelee :: Bool -> Time -> [(ItemId, ItemFull)]
-> [(Int, (ItemId, ItemFull))]
strongestMelee effectBonus localTime is =
let f = strMelee effectBonus localTime
g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> f itemFull
in sortBy (flip $ Ord.comparing fst) $ mapMaybe g is
isMelee :: ItemFull -> Bool
isMelee itemFull =
let p IK.Hurt{} = True
p IK.Burn{} = True
p _ = False
in case itemDisco itemFull of
Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->
any p jeffects
Just ItemDisco{itemKind=IK.ItemKind{IK.ieffects}} ->
any p ieffects
Nothing -> False
isMeleeEqp :: ItemFull -> Bool
isMeleeEqp itemFull =
let durable = IK.Durable `elem` jfeature (itemBase itemFull)
in isMelee itemFull && durable