{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, RankNTypes,
TypeFamilies #-}
module Game.LambdaHack.Client.Bfs
( BfsDistance, MoveLegal(..)
, subtractBfsDistance, minKnownBfs, apartBfs, maxBfsDistance, fillBfs
, AndPath(..), actorsAvoidedDist, findPathBfs
, accessBfs
#ifdef EXPOSE_INTERNAL
, succBfsDistance, predBfsDistance, abortedUnknownBfs
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.Monad.ST.Strict (ST, runST)
import Data.Binary
import Data.Bits (Bits, complement, (.&.), (.|.))
import qualified Data.EnumMap.Strict as EM
import qualified Data.IntMap.Strict as IM
import qualified Data.Primitive.PrimArray as PA
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as VM
import GHC.Exts (inline)
import GHC.Generics (Generic)
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Definition.Defs
newtype BfsDistance = BfsDistance {bfsDistance :: Word8}
deriving (Show, Eq, Ord, Bits)
instance PointArray.UnboxRepClass BfsDistance where
type UnboxRep BfsDistance = Word8
toUnboxRepUnsafe = bfsDistance
fromUnboxRep = BfsDistance
data MoveLegal = MoveBlocked | MoveToOpen | MoveToClosed | MoveToUnknown
deriving Eq
succBfsDistance :: BfsDistance -> BfsDistance
succBfsDistance d = BfsDistance $ bfsDistance d + 1
predBfsDistance :: BfsDistance -> BfsDistance
predBfsDistance d = BfsDistance $ bfsDistance d - 1
subtractBfsDistance :: BfsDistance -> BfsDistance -> Int
subtractBfsDistance d1 d2 = fromEnum $ bfsDistance d1 - bfsDistance d2
minKnownBfs :: BfsDistance
minKnownBfs = BfsDistance 128
apartBfs :: BfsDistance
apartBfs = predBfsDistance minKnownBfs
maxBfsDistance :: BfsDistance
maxBfsDistance = BfsDistance (maxBound :: Word8)
abortedUnknownBfs :: BfsDistance
abortedUnknownBfs = predBfsDistance apartBfs
fillBfs :: PointArray.Array Word8
-> Word8
-> Point
-> (PA.PrimArray PointI, PA.PrimArray PointI)
-> PointArray.Array BfsDistance
fillBfs !lalter !alterSkill !source (!tabA, !tabB) = runST $ do
let arr = PointArray.replicateA
(PointArray.axsize lalter) (PointArray.aysize lalter) apartBfs
vThawed <- U.unsafeThaw $ PointArray.avector arr
tabAThawed <- PA.unsafeThawPrimArray tabA
tabBThawed <- PA.unsafeThawPrimArray tabB
fillBfsThawed lalter alterSkill (fromEnum source)
(tabAThawed, tabBThawed) vThawed
void $ PA.unsafeFreezePrimArray tabAThawed
void $ PA.unsafeFreezePrimArray tabBThawed
void $ U.unsafeFreeze vThawed
return arr
type QueueIx = Int
type NextQueueIx = Int
fillBfsThawed :: forall s.
PointArray.Array Word8
-> Word8
-> PointI
-> (PA.MutablePrimArray s PointI, PA.MutablePrimArray s PointI)
-> U.MVector s Word8
-> ST s ()
fillBfsThawed !lalter !alterSkill !sourceI
(!tabAThawed, !tabBThawed) !vThawed = do
let unsafeReadI :: PointI -> ST s BfsDistance
{-# INLINE unsafeReadI #-}
unsafeReadI p = BfsDistance <$> VM.unsafeRead vThawed p
unsafeWriteI :: PointI -> BfsDistance -> ST s ()
{-# INLINE unsafeWriteI #-}
unsafeWriteI p c = VM.unsafeWrite vThawed p (bfsDistance c)
bfs :: PA.MutablePrimArray s PointI
-> PA.MutablePrimArray s PointI
-> BfsDistance
-> QueueIx
-> ST s ()
bfs !tabReadThawed !tabWriteThawed !distance !prevQueueIx = do
let unsafeReadCurrent :: QueueIx -> ST s PointI
{-# INLINE unsafeReadCurrent #-}
unsafeReadCurrent = PA.readPrimArray tabReadThawed
unsafeWriteNext :: QueueIx -> PointI -> ST s ()
{-# INLINE unsafeWriteNext #-}
unsafeWriteNext = PA.writePrimArray tabWriteThawed
processQueue :: QueueIx -> NextQueueIx -> ST s NextQueueIx
processQueue !currentQueueIx !acc1 =
if currentQueueIx == -1
then return acc1
else do
pos <- unsafeReadCurrent currentQueueIx
let processMove :: (X, Y) -> NextQueueIx -> ST s NextQueueIx
{-# INLINE processMove #-}
processMove move acc2 = do
let p = pos + inline fromEnum (uncurry Vector move)
pDist <- unsafeReadI p
if pDist /= apartBfs
then return acc2
else do
let alter :: Word8
!alter = lalter `PointArray.accessI` p
if | alterSkill < alter -> return acc2
| alter == 1 -> do
let distCompl = distance .&. complement minKnownBfs
unsafeWriteI p distCompl
return acc2
| otherwise -> do
unsafeWriteI p distance
unsafeWriteNext acc2 p
return $! acc2 + 1
return acc1
>>= processMove (-1, -1)
>>= processMove (0, -1)
>>= processMove (1, -1)
>>= processMove (1, 0)
>>= processMove (1, 1)
>>= processMove (0, 1)
>>= processMove (-1, 1)
>>= processMove (-1, 0)
>>= processQueue (currentQueueIx - 1)
acc3 <- processQueue (prevQueueIx - 1) 0
let distanceNew = succBfsDistance distance
if acc3 == 0 || distanceNew == maxBfsDistance
then return ()
else bfs tabWriteThawed tabReadThawed distanceNew acc3
VM.unsafeWrite vThawed sourceI (bfsDistance minKnownBfs)
PA.writePrimArray tabAThawed 0 sourceI
bfs tabAThawed tabBThawed (succBfsDistance minKnownBfs) 1
data AndPath = AndPath
{ pathSource :: Point
, pathList :: [Point]
, pathGoal :: Point
, pathLen :: Int
}
deriving (Show, Generic)
instance Binary AndPath
actorsAvoidedDist :: Int
actorsAvoidedDist = 5
findPathBfs :: BigActorMap -> PointArray.Array Word8 -> (PointI -> Bool)
-> Point -> Point -> Int
-> PointArray.Array BfsDistance
-> Maybe AndPath
{-# INLINE findPathBfs #-}
findPathBfs lbig lalter fovLit pathSource pathGoal sepsRaw
arr@PointArray.Array{..} =
let !pathGoalI = fromEnum pathGoal
!pathSourceI = fromEnum pathSource
eps = sepsRaw `mod` 4
(mc1, mc2) = splitAt eps movesCardinalI
(md1, md2) = splitAt eps movesDiagonalI
prefMoves = mc2 ++ reverse mc1 ++ md2 ++ reverse md1
track :: PointI -> BfsDistance -> [Point] -> [Point]
track !pos !oldDist !suffix | oldDist == minKnownBfs =
assert (pos == pathSourceI) suffix
track pos oldDist suffix | oldDist == succBfsDistance minKnownBfs =
let !posP = toEnum pos
in posP : suffix
track pos oldDist suffix =
let !dist = predBfsDistance oldDist
minChild :: PointI -> Bool -> Word8 -> [VectorI] -> PointI
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 free = fromEnum (bfsDistance dist) < actorsAvoidedDist
|| p `IM.notMember` EM.enumMapToIntMap lbig
alter | free = lalter `PointArray.accessI` p
| otherwise = maxBound-1
dark = not $ fovLit p
in if | alter == 0 && dark -> p
| alter < minAlter -> minChild p dark alter mvs
| dark > maxDark && alter == minAlter ->
minChild p dark alter mvs
| otherwise -> minChild minP maxDark minAlter mvs
!newPos = minChild pos False maxBound prefMoves
#ifdef WITH_EXPENSIVE_ASSERTIONS
!_A = assert (newPos /= pos) ()
#endif
!posP = toEnum pos
in track newPos dist (posP : suffix)
!goalDist = BfsDistance $ arr `PointArray.accessI` pathGoalI
pathLen = fromEnum $ bfsDistance $ 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 Just 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
|| d /= apartBfs && adjacent p pathGoal
then let dist = fromEnum $ bfsDistance
$ 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 Just andPath else Nothing
else let pathList2 =
track (fromEnum pRes)
(BfsDistance (toEnum dRes) .|. minKnownBfs) []
in Just AndPath{pathList = pathList2, pathLen = sumRes, ..}
accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int
accessBfs bfs p =
let dist = bfs PointArray.! p
in if PointArray.axsize bfs == 0 || dist == apartBfs
then Nothing
else Just $ fromEnum $ bfsDistance $ dist .&. complement minKnownBfs