{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Client.BfsM
( invalidateBfsAid, invalidateBfsPathAid
, invalidateBfsLid, invalidateBfsPathLid
, invalidateBfsAll, invalidateBfsPathAll
, createBfs, getCacheBfsAndPath, getCacheBfs
, getCachePath, createPath, condBFS
, furthestKnown, closestUnknown, closestSmell
, FleeViaStairsOrEscape(..)
, embedBenefit, closestTriggers, condEnoughGearM, closestItems, closestFoes
#ifdef EXPOSE_INTERNAL
, unexploredDepth, updatePathFromBfs
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Ord
import Data.Word
import Game.LambdaHack.Client.Bfs
import Game.LambdaHack.Client.CommonM
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
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.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind (isUknownSpace)
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
invalidateBfsAid :: MonadClient m => ActorId -> m ()
invalidateBfsAid aid =
modifyClient $ \cli -> cli {sbfsD = EM.insert aid BfsInvalid (sbfsD cli)}
invalidateBfsPathAid :: MonadClient m => ActorId -> m ()
invalidateBfsPathAid aid = do
let f BfsInvalid = BfsInvalid
f (BfsAndPath bfsArr _) = BfsAndPath bfsArr EM.empty
modifyClient $ \cli -> cli {sbfsD = EM.adjust f aid (sbfsD cli)}
invalidateBfsLid :: MonadClient m => LevelId -> m ()
invalidateBfsLid lid = do
side <- getsClient sside
let f (_, b) = blid b == lid && bfid b == side && not (bproj b)
as <- getsState $ filter f . EM.assocs . sactorD
mapM_ (invalidateBfsAid . fst) as
invalidateBfsPathLid :: MonadClient m => LevelId -> Point -> m ()
invalidateBfsPathLid lid pos = do
side <- getsClient sside
let f (_, b) = blid b == lid && bfid b == side && not (bproj b)
&& chessDist pos (bpos b) < actorsAvoidedDist
as <- getsState $ filter f . EM.assocs . sactorD
mapM_ (invalidateBfsPathAid . fst) as
invalidateBfsAll :: MonadClient m => m ()
invalidateBfsAll =
modifyClient $ \cli -> cli {sbfsD = EM.map (const BfsInvalid) (sbfsD cli)}
invalidateBfsPathAll :: MonadClient m => m ()
invalidateBfsPathAll = do
let f BfsInvalid = BfsInvalid
f (BfsAndPath bfsArr _) = BfsAndPath bfsArr EM.empty
modifyClient $ \cli -> cli {sbfsD = EM.map f (sbfsD cli)}
createBfs :: MonadClientRead m
=> Bool -> Word8 -> ActorId -> m (PointArray.Array BfsDistance)
createBfs canMove alterSkill0 aid =
if canMove then do
b <- getsState $ getActorBody aid
salter <- getsClient salter
let source = bpos b
lalter = salter EM.! blid b
alterSkill = max 1 alterSkill0
stabs <- getsClient stabs
return $! fillBfs lalter alterSkill source stabs
else return PointArray.empty
updatePathFromBfs :: MonadClient m
=> Bool -> BfsAndPath -> ActorId -> Point
-> m (PointArray.Array BfsDistance, Maybe AndPath)
updatePathFromBfs canMove bfsAndPathOld aid !target = do
COps{coTileSpeedup} <- getsState scops
let (oldBfsArr, oldBfsPath) = case bfsAndPathOld of
(BfsAndPath bfsArr bfsPath) -> (bfsArr, bfsPath)
BfsInvalid -> error $ "" `showFailure` (bfsAndPathOld, aid, target)
let bfsArr = oldBfsArr
if not canMove
then return (bfsArr, Nothing)
else do
b <- getsState $ getActorBody aid
let lid = blid b
seps <- getsClient seps
salter <- getsClient salter
lvl <- getLevel lid
let !lalter = salter EM.! lid
fovLit p = Tile.isLit coTileSpeedup $ PointArray.fromUnboxRep
$ ltile lvl `PointArray.accessI` p
!source = bpos b
!mpath =
findPathBfs (EM.delete source $ lbig lvl)
lalter fovLit source target seps bfsArr
!bfsPath =
maybe oldBfsPath (\path -> EM.insert target path oldBfsPath) mpath
bap = BfsAndPath bfsArr bfsPath
modifyClient $ \cli -> cli {sbfsD = EM.insert aid bap $ sbfsD cli}
return (bfsArr, mpath)
getCacheBfsAndPath :: forall m. MonadClient m
=> ActorId -> Point
-> m (PointArray.Array BfsDistance, Maybe AndPath)
getCacheBfsAndPath aid target = do
mbfs <- getsClient $ EM.lookup aid . sbfsD
case mbfs of
Just bap@(BfsAndPath bfsArr bfsPath) ->
case EM.lookup target bfsPath of
Nothing -> do
(!canMove, _) <- condBFS aid
updatePathFromBfs canMove bap aid target
mpath@Just{} -> return (bfsArr, mpath)
_ -> do
(canMove, alterSkill) <- condBFS aid
!bfsArr <- createBfs canMove alterSkill aid
let bfsPath = EM.empty
updatePathFromBfs canMove (BfsAndPath bfsArr bfsPath) aid target
getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)
getCacheBfs aid = do
mbfs <- getsClient $ EM.lookup aid . sbfsD
case mbfs of
Just (BfsAndPath bfsArr _) -> return bfsArr
_ -> do
(canMove, alterSkill) <- condBFS aid
!bfsArr <- createBfs canMove alterSkill aid
let bfsPath = EM.empty
modifyClient $ \cli ->
cli {sbfsD = EM.insert aid (BfsAndPath bfsArr bfsPath) (sbfsD cli)}
return bfsArr
getCachePath :: MonadClient m => ActorId -> Point -> m (Maybe AndPath)
getCachePath aid target = do
b <- getsState $ getActorBody aid
let source = bpos b
if | source == target ->
return $ Just $ AndPath (bpos b) [] target 0
| otherwise -> snd <$> getCacheBfsAndPath aid target
createPath :: MonadClient m => ActorId -> Target -> m TgtAndPath
createPath aid tapTgt = do
COps{coTileSpeedup} <- getsState scops
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
let stopAtUnwalkable tapPath@(Just AndPath{..}) =
let (walkable, rest) =
span (Tile.isWalkable coTileSpeedup . at lvl) pathList
in case rest of
[] -> TgtAndPath{..}
[g] | g == pathGoal -> TgtAndPath{..}
newGoal : _ ->
let newTgt = TPoint TBlock (blid b) newGoal
newPath = AndPath{ pathSource = bpos b
, pathList = walkable ++ [newGoal]
, pathGoal = newGoal
, pathLen = length walkable + 1 }
in TgtAndPath{tapTgt = newTgt, tapPath = Just newPath}
stopAtUnwalkable Nothing = TgtAndPath{tapTgt, tapPath=Nothing}
mpos <- getsState $ aidTgtToPos aid (blid b) (Just tapTgt)
case mpos of
Nothing -> return TgtAndPath{tapTgt, tapPath=Nothing}
Just p -> do
path <- getCachePath aid p
return $! stopAtUnwalkable path
condBFS :: MonadClientRead m => ActorId -> m (Bool, Word8)
condBFS aid = do
side <- getsClient sside
actorMaxSk <- getsState $ getActorMaxSkills aid
let alterSkill =
min (maxBound - 1)
(toEnum $ max 0 $ Ability.getSk Ability.SkAlter actorMaxSk)
canMove = Ability.getSk Ability.SkMove actorMaxSk > 0
|| Ability.getSk Ability.SkDisplace actorMaxSk > 0
|| Ability.getSk Ability.SkProject actorMaxSk > 0
smarkSuspect <- getsClient smarkSuspect
fact <- getsState $ (EM.! side) . sfactionD
let underAI = isAIFact fact
enterSuspect = smarkSuspect > 0 || underAI
skill | enterSuspect = alterSkill
| otherwise = 0
return (canMove, skill)
furthestKnown :: MonadClient m => ActorId -> m Point
furthestKnown aid = do
bfs <- getCacheBfs aid
getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA
, PointArray.maxLastIndexA ]
let furthestPos = getMaxIndex bfs
dist = bfs PointArray.! furthestPos
return $! assert (dist > apartBfs `blame` (aid, furthestPos, dist))
furthestPos
closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)
closestUnknown aid = do
body <- getsState $ getActorBody aid
lvl <- getLevel $ blid body
bfs <- getCacheBfs aid
let closestPoss = PointArray.minIndexesA bfs
dist = bfs PointArray.! head closestPoss
!_A = assert (lexpl lvl >= lseen lvl) ()
return $!
if lexpl lvl <= lseen lvl
|| dist >= apartBfs
then Nothing
else let unknownAround pos =
let vic = vicinityUnsafe pos
countUnknown :: Int -> Point -> Int
countUnknown c p =
if isUknownSpace $ lvl `at` p then c + 1 else c
in foldl' countUnknown 0 vic
cmp = comparing unknownAround
in Just $ maximumBy cmp closestPoss
closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Time))]
closestSmell aid = do
body <- getsState $ getActorBody aid
Level{lsmell, ltime} <- getLevel $ blid body
let smells = filter (\(p, sm) -> sm > ltime && p /= bpos body)
(EM.assocs lsmell)
case smells of
[] -> return []
_ -> do
bfs <- getCacheBfs aid
let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells
return $! sortBy (comparing (fst &&& absoluteTimeNegate . snd . snd)) ts
data FleeViaStairsOrEscape =
ViaStairs
| ViaStairsUp
| ViaStairsDown
| ViaEscape
| ViaExit
| ViaNothing
| ViaAnything
deriving (Show, Eq)
embedBenefit :: MonadClientRead m
=> FleeViaStairsOrEscape -> ActorId
-> [(Point, ItemBag)]
-> m [(Double, (Point, ItemBag))]
embedBenefit fleeVia aid pbags = do
COps{coTileSpeedup} <- getsState scops
dungeon <- getsState sdungeon
explored <- getsClient sexplored
b <- getsState $ getActorBody aid
actorSk <- if fleeVia `elem` [ViaAnything, ViaExit]
then getsState $ getActorMaxSkills aid
else currentSkillsClient aid
let alterSkill = Ability.getSk Ability.SkAlter actorSk
fact <- getsState $ (EM.! bfid b) . sfactionD
lvl <- getLevel (blid b)
unexploredTrue <- unexploredDepth True (blid b)
unexploredFalse <- unexploredDepth False (blid b)
condEnoughGear <- condEnoughGearM aid
discoBenefit <- getsClient sdiscoBenefit
getKind <- getsState $ flip getIidKind
let alterMinSkill p = Tile.alterMinSkill coTileSpeedup $ lvl `at` p
lidExplored = ES.member (blid b) explored
allExplored = ES.size explored == EM.size dungeon
iidToEffs iid = IK.ieffects $ getKind iid
feats bag = concatMap iidToEffs $ EM.keys bag
bens (_, bag) = case find IK.isEffEscapeOrAscend $ feats bag of
Just IK.Escape{} ->
let escapeOrGuard =
fcanEscape (gplayer fact)
|| fleeVia `elem` [ViaExit]
in if fleeVia `elem` [ViaAnything, ViaEscape, ViaExit]
&& escapeOrGuard
&& allExplored
then 10
else 0
Just (IK.Ascend up) ->
let easier = up /= (fromEnum (blid b) > 0)
unexpForth = if up then unexploredTrue else unexploredFalse
unexpBack = if not up then unexploredTrue else unexploredFalse
aiCond = if unexpForth
then easier && condEnoughGear
|| (not unexpBack || easier) && lidExplored
else easier && allExplored && null (lescape lvl)
v = if aiCond then if easier then 10 else 1 else 0
in case fleeVia of
ViaStairsUp | up -> 1
ViaStairsDown | not up -> 1
ViaStairs -> v
ViaExit -> v
ViaAnything -> v
_ -> 0
_ ->
if fleeVia `elem` [ViaNothing, ViaAnything]
then
let sacrificeForExperiment = 101
sumBen = sum $ map (\iid ->
benApply $ discoBenefit EM.! iid) (EM.keys bag)
in min 1000 $ sacrificeForExperiment + sumBen
else 0
underFeet p = p == bpos b
f (p, _) = underFeet p || alterSkill >= fromEnum (alterMinSkill p)
benFeats = map (\pbag -> (bens pbag, pbag)) $ filter f pbags
considered (benefitAndSacrifice, (p, _bag)) =
benefitAndSacrifice > 0
&& Tile.consideredByAI coTileSpeedup (lvl `at` p)
return $! filter considered benFeats
closestTriggers :: MonadClient m => FleeViaStairsOrEscape -> ActorId
-> m [(Int, (Point, (Point, ItemBag)))]
closestTriggers fleeVia aid = do
COps{corule=RuleContent{rXmax, rYmax}} <- getsState scops
b <- getsState $ getActorBody aid
lvl <- getLevel (blid b)
let pbags = EM.assocs $ lembed lvl
efeat <- embedBenefit fleeVia aid pbags
bfs <- getCacheBfs aid
let vicTrigger (cid, (p0, bag)) =
map (\p -> (cid, (p, (p0, bag)))) $ vicinityBounded rXmax rYmax p0
vicAll = concatMap vicTrigger efeat
return $!
let mix (benefit, ppbag) dist =
let maxd = subtractBfsDistance maxBfsDistance apartBfs
v = fromIntegral $ (1 + maxd - dist) ^ (2 :: Int)
in (ceiling $ benefit * v, ppbag)
in mapMaybe (\bpp@(_, (p, _)) ->
mix bpp <$> accessBfs bfs p) vicAll
condEnoughGearM :: MonadClientRead m => ActorId -> m Bool
condEnoughGearM aid = do
b <- getsState $ getActorBody aid
fact <- getsState $ (EM.! bfid b) . sfactionD
let followTactic = ftactic (gplayer fact)
`elem` [Ability.TFollow, Ability.TFollowNoItems]
eqpAssocs <- getsState $ fullAssocs aid [CEqp]
invAssocs <- getsState $ getActorAssocs aid CInv
return $ not followTactic
&& (any (IA.checkFlag Ability.Meleeable
. aspectRecordFull . snd) eqpAssocs
|| length eqpAssocs + length invAssocs >= 5)
unexploredDepth :: MonadClientRead m => Bool -> LevelId -> m Bool
unexploredDepth !up !lidCurrent = do
dungeon <- getsState sdungeon
explored <- getsClient sexplored
let allExplored = ES.size explored == EM.size dungeon
unexploredD =
let unex !lid = allExplored
&& not (null $ lescape $ dungeon EM.! lid)
|| ES.notMember lid explored
|| unexploredD lid
in any unex . ascendInBranch dungeon up
return $ unexploredD lidCurrent
closestItems :: MonadClient m => ActorId -> m [(Int, (Point, ItemBag))]
closestItems aid = do
actorMaxSk <- getsState $ getActorMaxSkills aid
if Ability.getSk Ability.SkMoveItem actorMaxSk <= 0 then return []
else do
body <- getsState $ getActorBody aid
Level{lfloor} <- getLevel $ blid body
if EM.null lfloor then return [] else do
bfs <- getCacheBfs aid
let mix pbag dist =
let maxd = subtractBfsDistance maxBfsDistance apartBfs
v = (maxd * 10) `div` (dist + 1)
in (v, pbag)
return $! mapMaybe (\(p, bag) ->
mix (p, bag) <$> accessBfs bfs p) (EM.assocs lfloor)
closestFoes :: MonadClient m
=> [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]
closestFoes foes aid =
case foes of
[] -> return []
_ -> do
bfs <- getCacheBfs aid
let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes
return $! sortBy (comparing fst) ds