module Game.LambdaHack.Client.BfsClient
( invalidateBfs, getCacheBfsAndPath, getCacheBfs, accessCacheBfs
, unexploredDepth, closestUnknown, closestSuspect, closestSmell, furthestKnown
, closestTriggers, closestItems, closestFoes
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.List
import Data.Maybe
import Data.Ord
import Game.LambdaHack.Client.Bfs
import Game.LambdaHack.Client.CommonClient
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Frequency
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.MonadStateRead
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Common.Random
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.TileKind (TileKind)
invalidateBfs :: ActorId
-> EM.EnumMap ActorId
( Bool, PointArray.Array BfsDistance
, Point, Int, Maybe [Point])
-> EM.EnumMap ActorId
( Bool, PointArray.Array BfsDistance
, Point, Int, Maybe [Point])
invalidateBfs =
EM.adjust
(\(_, bfs, target, seps, mpath) -> (False, bfs, target, seps, mpath))
getCacheBfsAndPath :: forall m. MonadClient m
=> ActorId -> Point
-> m (PointArray.Array BfsDistance, Maybe [Point])
getCacheBfsAndPath aid target = do
seps <- getsClient seps
b <- getsState $ getActorBody aid
let origin = bpos b
(isEnterable, passUnknown) <- condBFS aid
let pathAndStore :: PointArray.Array BfsDistance
-> m (PointArray.Array BfsDistance, Maybe [Point])
pathAndStore bfs = do
let mpath = findPathBfs isEnterable passUnknown origin target seps bfs
modifyClient $ \cli ->
cli {sbfsD = EM.insert aid (True, bfs, target, seps, mpath)
(sbfsD cli)}
return (bfs, mpath)
mbfs <- getsClient $ EM.lookup aid . sbfsD
case mbfs of
Just (True, bfs, targetOld, sepsOld, mpath)
| bfs PointArray.! bpos b == succ apartBfs ->
if targetOld == target && sepsOld == seps
then return (bfs, mpath)
else pathAndStore bfs
_ -> do
modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}
Level{lxsize, lysize} <- getLevel $ blid b
let vInitial = case mbfs of
Just (_, bfsInvalid, _, _, _) ->
PointArray.safeSetA apartBfs bfsInvalid
_ ->
PointArray.replicateA lxsize lysize apartBfs
bfs = fillBfs isEnterable passUnknown origin vInitial
pathAndStore bfs
getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)
getCacheBfs aid = do
mbfs <- getsClient $ EM.lookup aid . sbfsD
case mbfs of
Just (True, bfs, _, _, _) -> return bfs
_ -> fst <$> getCacheBfsAndPath aid (Point 0 0)
condBFS :: MonadClient m
=> ActorId
-> m (Point -> Point -> MoveLegal,
Point -> Point -> Bool)
condBFS aid = do
cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops
b <- getsState $ getActorBody aid
activeItems <- activeItemsClient aid
let actorMaxSk = sumSkills activeItems
lvl <- getLevel $ blid b
smarkSuspect <- getsClient smarkSuspect
fact <- getsState $ (EM.! bfid b) . sfactionD
let underAI = isAIFact fact
enterSuspect = smarkSuspect || underAI
isPassable | enterSuspect = Tile.isPassable
| otherwise = Tile.isPassableNoSuspect
let unknownId = ouniqGroup "unknown space"
chAccess = checkAccess cops lvl
canOpenDoors = EM.findWithDefault 0 Ability.AbAlter actorMaxSk > 0
chDoorAccess = [checkDoorAccess cops lvl | canOpenDoors]
conditions = catMaybes $ chAccess : chDoorAccess
isEnterable :: Point -> Point -> MoveLegal
isEnterable spos tpos =
let st = lvl `at` spos
tt = lvl `at` tpos
allOK = all (\f -> f spos tpos) conditions
in if tt == unknownId
then if not (Tile.isSuspect cotile st) && allOK
then MoveToUnknown
else MoveBlocked
else if isPassable cotile tt
&& not (Tile.isChangeable cotile st)
&& allOK
then MoveToOpen
else MoveBlocked
passUnknown :: Point -> Point -> Bool
passUnknown = case chAccess of
Nothing -> \_ tpos -> let tt = lvl `at` tpos
in tt == unknownId
Just ch -> \spos tpos -> let tt = lvl `at` tpos
in tt == unknownId
&& ch spos tpos
return (isEnterable, passUnknown)
accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int)
accessCacheBfs aid target = do
bfs <- getCacheBfs aid
return $! accessBfs bfs target
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 $! if dist <= apartBfs
then assert `failure` (aid, furthestPos, dist)
else furthestPos
closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)
closestUnknown aid = do
body <- getsState $ getActorBody aid
lvl@Level{lxsize, lysize} <- getLevel $ blid body
bfs <- getCacheBfs aid
let closestPoss = PointArray.minIndexesA bfs
dist = bfs PointArray.! head closestPoss
if dist >= apartBfs then do
when (lclear lvl == lseen lvl) $ do
let !_A = assert (lclear lvl >= lseen lvl) ()
modifyClient $ \cli ->
cli {sexplored = ES.insert (blid body) (sexplored cli)}
return Nothing
else do
let unknownAround p =
let vic = vicinity lxsize lysize p
posUnknown pos = bfs PointArray.! pos < apartBfs
vicUnknown = filter posUnknown vic
in length vicUnknown
cmp = comparing unknownAround
return $ Just $ maximumBy cmp closestPoss
closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Tile.SmellTime))]
closestSmell aid = do
body <- getsState $ getActorBody aid
Level{lsmell, ltime} <- getLevel $ blid body
let smells = filter ((> ltime) . snd) $ EM.assocs lsmell
case smells of
[] -> return []
_ -> do
bfs <- getCacheBfs aid
let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells
ds = filter (\(d, _) -> d /= 0) ts
return $! sortBy (comparing (fst &&& absoluteTimeNegate . snd . snd)) ds
closestSuspect :: MonadClient m => ActorId -> m [Point]
closestSuspect aid = do
Kind.COps{cotile} <- getsState scops
body <- getsState $ getActorBody aid
lvl <- getLevel $ blid body
let f :: [Point] -> Point -> Kind.Id TileKind -> [Point]
f acc p t = if Tile.isSuspect cotile t then p : acc else acc
suspect = PointArray.ifoldlA f [] $ ltile lvl
case suspect of
[] -> do
modifyClient $ \cli ->
cli {sexplored = ES.insert (blid body) (sexplored cli)}
return []
_ -> do
bfs <- getCacheBfs aid
let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) suspect
return $! map snd $ sortBy (comparing fst) ds
closestTriggers :: MonadClient m => Maybe Bool -> ActorId -> m (Frequency Point)
closestTriggers onlyDir aid = do
Kind.COps{cotile} <- getsState scops
body <- getsState $ getActorBody aid
explored <- getsClient sexplored
let lid = blid body
lvl <- getLevel lid
dungeon <- getsState sdungeon
let escape = any (not . null . lescape) $ EM.elems dungeon
unexploredD <- unexploredDepth
let allExplored = ES.size explored == EM.size dungeon
lidExplored = ES.member (blid body) explored
f :: [(Int, Point)] -> Point -> Kind.Id TileKind -> [(Int, Point)]
f acc p t =
if Tile.isWalkable cotile t && not (null $ Tile.causeEffects cotile t)
then case Tile.ascendTo cotile t of
[] ->
if isNothing onlyDir && allExplored
then (9999999, p) : acc
else acc
l ->
if not escape && allExplored
then map (,p) l ++ acc
else let g k =
let easier = signum k /= signum (fromEnum lid)
unexpForth = unexploredD (signum k) lid
unexpBack = unexploredD ( signum k) lid
aiCond = if unexpForth
then easier
|| not unexpBack && lidExplored
else not unexpBack && lidExplored
&& (null $ lescape lvl)
in maybe aiCond (\d -> d == (k > 0)) onlyDir
in map (,p) (filter g l) ++ acc
else acc
triggersAll = PointArray.ifoldlA f [] $ ltile lvl
triggers = filter ((/= bpos body) . snd) triggersAll
bfs <- getCacheBfs aid
return $ case triggers of
[] -> mzero
_ | isNothing onlyDir && not escape && allExplored ->
toFreq "closestTriggers when allExplored" triggers
_ ->
let mix (k, p) dist =
let easier = signum k /= signum (fromEnum lid)
depthDelta = if easier then 2 else 1
distDelta = fromEnum (maxBound :: BfsDistance)
fromEnum apartBfs
dist
in (depthDelta * distDelta * distDelta, p)
ds = mapMaybe (\(k, p) -> mix (k, p) <$> accessBfs bfs p) triggers
in toFreq "closestTriggers" ds
unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)
unexploredDepth = do
dungeon <- getsState sdungeon
explored <- getsClient sexplored
let allExplored = ES.size explored == EM.size dungeon
unexploredD p =
let unex lid = allExplored
&& (not $ null $ lescape $ dungeon EM.! lid)
|| ES.notMember lid explored
|| unexploredD p lid
in any unex . ascendInBranch dungeon p
return unexploredD
closestItems :: MonadClient m => ActorId -> m [(Int, (Point, Maybe ItemBag))]
closestItems aid = do
Kind.COps{cotile} <- getsState scops
body <- getsState $ getActorBody aid
lvl@Level{lfloor} <- getLevel $ blid body
let items = EM.assocs lfloor
f :: [Point] -> Point -> Kind.Id TileKind -> [Point]
f acc p t = if Tile.isChangeable cotile t then p : acc else acc
changeable = PointArray.ifoldlA f [] $ ltile lvl
if null items && null changeable then return []
else do
bfs <- getCacheBfs aid
let is = mapMaybe (\(p, bag) ->
fmap (, (p, Just bag)) (accessBfs bfs p)) items
cs = mapMaybe (\p ->
fmap (, (p, Nothing)) (accessBfs bfs p)) changeable
return $! sortBy (comparing fst) $ is ++ cs
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