LambdaHack-0.7.0.0: Game/LambdaHack/Client/Bfs.hs
{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
-- | Breadth first search algorithm.
module Game.LambdaHack.Client.Bfs
( BfsDistance, MoveLegal(..), minKnownBfs, apartBfs, fillBfs
, AndPath(..), findPathBfs
, accessBfs
#ifdef EXPOSE_INTERNAL
-- * Internal operations
, abortedKnownBfs, abortedUnknownBfs
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Control.Monad.ST.Strict
import Data.Binary
import Data.Bits (Bits, complement, (.&.), (.|.))
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as VM
import GHC.Generics (Generic)
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
-- | Weighted distance between points along shortest paths.
newtype BfsDistance = BfsDistance {bfsDistance :: Word8}
deriving (Show, Eq, Ord, Enum, Bounded, Bits)
-- | State of legality of moves between adjacent points.
data MoveLegal = MoveBlocked | MoveToOpen | MoveToClosed | MoveToUnknown
deriving Eq
-- | The minimal distance value assigned to paths that don't enter
-- any unknown tiles.
minKnownBfs :: BfsDistance
minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2
-- | The distance value that denotes no legal path between points,
-- either due to blocked tiles or pathfinding aborted at earlier tiles,
-- e.g., due to unknown tiles.
apartBfs :: BfsDistance
apartBfs = pred minKnownBfs
-- | The distance value that denotes that path search was aborted
-- at this tile due to too large actual distance
-- and that the tile was known and not blocked.
-- It is also a true distance value for this tile
-- (shifted by minKnownBfs, as all distances of known tiles).
abortedKnownBfs :: BfsDistance
abortedKnownBfs = pred maxBound
-- | The distance value that denotes that path search was aborted
-- at this tile due to too large actual distance
-- and that the tile was unknown.
-- It is also a true distance value for this tile.
abortedUnknownBfs :: BfsDistance
abortedUnknownBfs = pred apartBfs
type PointI = Int
type VectorI = Int
-- | Fill out the given BFS array.
-- Unsafe @PointArray@ operations are OK here, because the intermediate
-- values of the vector don't leak anywhere outside nor are kept unevaluated
-- and so they can't be overwritten by the unsafe side-effect.
--
-- When computing move cost, we assume doors openable at no cost,
-- because other actors use them, too, so the cost is shared and the extra
-- visiblity is valuable, too. We treat unknown tiles specially.
-- Whether suspect tiles are considered openable depends on @smarkSuspect@.
fillBfs :: PointArray.Array Word8
-> Word8
-> Point -- ^ starting position
-> PointArray.Array BfsDistance -- ^ initial array, with @apartBfs@
-> ()
{-# INLINE fillBfs #-}
fillBfs lalter alterSkill source arr@PointArray.Array{..} =
let vToI (x, y) = PointArray.pindex axsize (Point x y)
movesI :: [VectorI]
movesI = map vToI
[(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)]
unsafeWriteI :: Int -> BfsDistance -> ()
{-# INLINE unsafeWriteI #-}
unsafeWriteI p c = runST $ do
vThawed <- U.unsafeThaw avector
VM.unsafeWrite vThawed p (bfsDistance c)
void $ U.unsafeFreeze vThawed
bfs :: BfsDistance -> [PointI] -> () -- modifies the vector
bfs !distance !predK =
let processKnown :: PointI -> [PointI] -> [PointI]
processKnown !pos !succK2 =
-- Terrible hack trigger warning!
-- Unsafe ops inside @fKnown@ seem to be OK, for no particularly
-- clear reason. The array value given to each p depends on
-- array value only at p (it's not overwritten if already there).
-- So the only problem with the unsafe ops writing at p is
-- if one with higher depth (dist) is evaluated earlier
-- than another with lower depth. The particular pattern of
-- laziness and order of list elements below somehow
-- esures the lowest possible depth is always written first.
-- The code also doesn't keep a wholly evaluated list of all p
-- at a given depth, but generates them on demand, unlike a fully
-- strict version inside the ST monad. So it uses little memory
-- and is fast.
let fKnown :: [PointI] -> VectorI -> [PointI]
fKnown !l !move =
let !p = pos + move
visitedMove =
BfsDistance (arr `PointArray.accessI` p) /= apartBfs
in if visitedMove
then l
else let alter :: Word8
!alter = lalter `PointArray.accessI` p
in if | alterSkill < alter -> l
| alter == 1 ->
let distCompl =
distance .&. complement minKnownBfs
in unsafeWriteI p distCompl
`seq` l
| otherwise -> unsafeWriteI p distance
`seq` p : l
in foldl' fKnown succK2 movesI
succK4 = foldr processKnown [] predK
in if null succK4 || distance == abortedKnownBfs
then () -- no more dungeon positions to check, or we delved too deep
else bfs (succ distance) succK4
in bfs (succ minKnownBfs) [PointArray.pindex axsize source]
data AndPath =
AndPath { pathList :: [Point]
, pathGoal :: Point -- needn't be @last pathList@
, pathLen :: Int -- needn't be @length pathList@
}
| NoPath
deriving (Show, Generic)
instance Binary AndPath
-- | Find a path, without the source position, with the smallest length.
-- The @eps@ coefficient determines which direction (of the closest
-- directions available) that path should prefer, where 0 means north-west
-- and 1 means north.
findPathBfs :: PointArray.Array Word8 -> (Point -> Bool)
-> Point -> Point -> Int
-> PointArray.Array BfsDistance
-> AndPath
{-# INLINE findPathBfs #-}
findPathBfs lalter fovLit pathSource pathGoal sepsRaw
arr@PointArray.Array{..} =
let !pathGoalI = PointArray.pindex axsize pathGoal
!pathSourceI = PointArray.pindex axsize pathSource
eps = sepsRaw `mod` 4
(mc1, mc2) = splitAt eps [(0, -1), (1, 0), (0, 1), (-1, 0)]
(md1, md2) = splitAt eps [(-1, -1), (1, -1), (1, 1), (-1, 1)]
-- Prefer cardinal directions when closer to the target, so that
-- the enemy can't easily disengage (open/unknown below overrides that).
prefMoves = mc1 ++ reverse mc2 ++ md2 ++ reverse md1 -- fuzz
vToI (x, y) = PointArray.pindex axsize (Point x y)
movesI :: [VectorI]
movesI = map vToI prefMoves
track :: PointI -> BfsDistance -> [Point] -> [Point]
track !pos !oldDist !suffix | oldDist == minKnownBfs =
assert (pos == pathSourceI) suffix
track pos oldDist suffix | oldDist == succ minKnownBfs =
let !posP = PointArray.punindex axsize pos
in posP : suffix -- avoid calculating minP and dist for the last call
track pos oldDist suffix =
let !dist = pred oldDist
minChild !minP _ _ [] = minP
minChild minP maxDark minAlter (mv : mvs) =
let !p = pos + mv
backtrackingMove =
BfsDistance (arr `PointArray.accessI` p) /= dist
in if backtrackingMove
then minChild minP maxDark minAlter mvs
else let alter = lalter `PointArray.accessI` p
dark = not $ fovLit $ PointArray.punindex axsize p
-- Prefer paths through more easily opened tiles
-- and, secondly, in the ambient dark (even if light
-- carried, because it can be taken off at any moment).
in if | alter == 0 && dark -> p -- speedup
| alter < minAlter -> minChild p dark alter mvs
| dark > maxDark && alter == minAlter ->
minChild p dark alter mvs
| otherwise -> minChild minP maxDark minAlter mvs
-- @maxBound@ means not alterable, so some child will be lower
!newPos = minChild pos{-dummy-} False maxBound movesI
#ifdef WITH_EXPENSIVE_ASSERTIONS
!_A = assert (newPos /= pos) ()
#endif
!posP = PointArray.punindex axsize pos
in track newPos dist (posP : suffix)
!goalDist = BfsDistance $ arr `PointArray.accessI` pathGoalI
pathLen = fromEnum $ goalDist .&. complement minKnownBfs
pathList = track pathGoalI (goalDist .|. minKnownBfs) []
andPath = AndPath{..}
in assert (BfsDistance (arr `PointArray.accessI` pathSourceI)
== minKnownBfs) $
if goalDist /= apartBfs && pathLen < 2 * chessDist pathSource pathGoal
then andPath
else let f :: (Point, Int, Int, Int) -> Point -> BfsDistance
-> (Point, Int, Int, Int)
f acc@(pAcc, dAcc, chessAcc, sumAcc) p d =
if d <= abortedUnknownBfs -- works in visible secrets mode only
|| d /= apartBfs && adjacent p pathGoal -- works for stairs
then let dist = fromEnum $ d .&. complement minKnownBfs
chessNew = chessDist p pathGoal
sumNew = dist + 2 * chessNew
resNew = (p, dist, chessNew, sumNew)
in case compare sumNew sumAcc of
LT -> resNew
EQ -> case compare chessNew chessAcc of
LT -> resNew
EQ -> case compare dist dAcc of
LT -> resNew
EQ | euclidDistSq p pathGoal
< euclidDistSq pAcc pathGoal -> resNew
_ -> acc
_ -> acc
_ -> acc
else acc
initAcc = (originPoint, maxBound, maxBound, maxBound)
(pRes, dRes, _, sumRes) = PointArray.ifoldlA' f initAcc arr
in if sumRes == maxBound
|| goalDist /= apartBfs && pathLen < sumRes
then if goalDist /= apartBfs then andPath else NoPath
else let pathList2 = track (PointArray.pindex axsize pRes)
(toEnum dRes .|. minKnownBfs) []
in AndPath{pathList = pathList2, pathLen = sumRes, ..}
-- | Access a BFS array and interpret the looked up distance value.
accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int
accessBfs bfs p =
let dist = bfs PointArray.! p
in if dist == apartBfs
then Nothing
else Just $ fromEnum $ dist .&. complement minKnownBfs