{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, RankNTypes,
TypeFamilies #-}
module Game.LambdaHack.Client.Bfs
( BfsDistance, MoveLegal(..)
, subtractBfsDistance, minKnownBfs, apartBfs, maxBfsDistance, fillBfs
, AndPath(..), findPathBfs, accessBfs
#ifdef EXPOSE_INTERNAL
, succBfsDistance, predBfsDistance, abortedUnknownBfs, maskBfs, distanceBfs
#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.EnumSet as ES
import qualified Data.IntSet as IS
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.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Definition.Defs
type DistanceWord = Word16
newtype BfsDistance = BfsDistance {BfsDistance -> DistanceWord
bfsDistance :: DistanceWord}
deriving (Int -> BfsDistance -> ShowS
[BfsDistance] -> ShowS
BfsDistance -> String
(Int -> BfsDistance -> ShowS)
-> (BfsDistance -> String)
-> ([BfsDistance] -> ShowS)
-> Show BfsDistance
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BfsDistance] -> ShowS
$cshowList :: [BfsDistance] -> ShowS
show :: BfsDistance -> String
$cshow :: BfsDistance -> String
showsPrec :: Int -> BfsDistance -> ShowS
$cshowsPrec :: Int -> BfsDistance -> ShowS
Show, BfsDistance -> BfsDistance -> Bool
(BfsDistance -> BfsDistance -> Bool)
-> (BfsDistance -> BfsDistance -> Bool) -> Eq BfsDistance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BfsDistance -> BfsDistance -> Bool
$c/= :: BfsDistance -> BfsDistance -> Bool
== :: BfsDistance -> BfsDistance -> Bool
$c== :: BfsDistance -> BfsDistance -> Bool
Eq, Eq BfsDistance
Eq BfsDistance =>
(BfsDistance -> BfsDistance -> Ordering)
-> (BfsDistance -> BfsDistance -> Bool)
-> (BfsDistance -> BfsDistance -> Bool)
-> (BfsDistance -> BfsDistance -> Bool)
-> (BfsDistance -> BfsDistance -> Bool)
-> (BfsDistance -> BfsDistance -> BfsDistance)
-> (BfsDistance -> BfsDistance -> BfsDistance)
-> Ord BfsDistance
BfsDistance -> BfsDistance -> Bool
BfsDistance -> BfsDistance -> Ordering
BfsDistance -> BfsDistance -> BfsDistance
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BfsDistance -> BfsDistance -> BfsDistance
$cmin :: BfsDistance -> BfsDistance -> BfsDistance
max :: BfsDistance -> BfsDistance -> BfsDistance
$cmax :: BfsDistance -> BfsDistance -> BfsDistance
>= :: BfsDistance -> BfsDistance -> Bool
$c>= :: BfsDistance -> BfsDistance -> Bool
> :: BfsDistance -> BfsDistance -> Bool
$c> :: BfsDistance -> BfsDistance -> Bool
<= :: BfsDistance -> BfsDistance -> Bool
$c<= :: BfsDistance -> BfsDistance -> Bool
< :: BfsDistance -> BfsDistance -> Bool
$c< :: BfsDistance -> BfsDistance -> Bool
compare :: BfsDistance -> BfsDistance -> Ordering
$ccompare :: BfsDistance -> BfsDistance -> Ordering
$cp1Ord :: Eq BfsDistance
Ord, Eq BfsDistance
BfsDistance
Eq BfsDistance =>
(BfsDistance -> BfsDistance -> BfsDistance)
-> (BfsDistance -> BfsDistance -> BfsDistance)
-> (BfsDistance -> BfsDistance -> BfsDistance)
-> (BfsDistance -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> BfsDistance
-> (Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> Bool)
-> (BfsDistance -> Maybe Int)
-> (BfsDistance -> Int)
-> (BfsDistance -> Bool)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int -> BfsDistance)
-> (BfsDistance -> Int)
-> Bits BfsDistance
Int -> BfsDistance
BfsDistance -> Bool
BfsDistance -> Int
BfsDistance -> Maybe Int
BfsDistance -> BfsDistance
BfsDistance -> Int -> Bool
BfsDistance -> Int -> BfsDistance
BfsDistance -> BfsDistance -> BfsDistance
forall a.
Eq a =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> a
-> (Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> Bool)
-> (a -> Maybe Int)
-> (a -> Int)
-> (a -> Bool)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int)
-> Bits a
popCount :: BfsDistance -> Int
$cpopCount :: BfsDistance -> Int
rotateR :: BfsDistance -> Int -> BfsDistance
$crotateR :: BfsDistance -> Int -> BfsDistance
rotateL :: BfsDistance -> Int -> BfsDistance
$crotateL :: BfsDistance -> Int -> BfsDistance
unsafeShiftR :: BfsDistance -> Int -> BfsDistance
$cunsafeShiftR :: BfsDistance -> Int -> BfsDistance
shiftR :: BfsDistance -> Int -> BfsDistance
$cshiftR :: BfsDistance -> Int -> BfsDistance
unsafeShiftL :: BfsDistance -> Int -> BfsDistance
$cunsafeShiftL :: BfsDistance -> Int -> BfsDistance
shiftL :: BfsDistance -> Int -> BfsDistance
$cshiftL :: BfsDistance -> Int -> BfsDistance
isSigned :: BfsDistance -> Bool
$cisSigned :: BfsDistance -> Bool
bitSize :: BfsDistance -> Int
$cbitSize :: BfsDistance -> Int
bitSizeMaybe :: BfsDistance -> Maybe Int
$cbitSizeMaybe :: BfsDistance -> Maybe Int
testBit :: BfsDistance -> Int -> Bool
$ctestBit :: BfsDistance -> Int -> Bool
complementBit :: BfsDistance -> Int -> BfsDistance
$ccomplementBit :: BfsDistance -> Int -> BfsDistance
clearBit :: BfsDistance -> Int -> BfsDistance
$cclearBit :: BfsDistance -> Int -> BfsDistance
setBit :: BfsDistance -> Int -> BfsDistance
$csetBit :: BfsDistance -> Int -> BfsDistance
bit :: Int -> BfsDistance
$cbit :: Int -> BfsDistance
zeroBits :: BfsDistance
$czeroBits :: BfsDistance
rotate :: BfsDistance -> Int -> BfsDistance
$crotate :: BfsDistance -> Int -> BfsDistance
shift :: BfsDistance -> Int -> BfsDistance
$cshift :: BfsDistance -> Int -> BfsDistance
complement :: BfsDistance -> BfsDistance
$ccomplement :: BfsDistance -> BfsDistance
xor :: BfsDistance -> BfsDistance -> BfsDistance
$cxor :: BfsDistance -> BfsDistance -> BfsDistance
.|. :: BfsDistance -> BfsDistance -> BfsDistance
$c.|. :: BfsDistance -> BfsDistance -> BfsDistance
.&. :: BfsDistance -> BfsDistance -> BfsDistance
$c.&. :: BfsDistance -> BfsDistance -> BfsDistance
$cp1Bits :: Eq BfsDistance
Bits)
instance PointArray.UnboxRepClass BfsDistance where
type UnboxRep BfsDistance = DistanceWord
toUnboxRepUnsafe :: BfsDistance -> UnboxRep BfsDistance
toUnboxRepUnsafe = BfsDistance -> DistanceWord
BfsDistance -> UnboxRep BfsDistance
bfsDistance
fromUnboxRep :: UnboxRep BfsDistance -> BfsDistance
fromUnboxRep = DistanceWord -> BfsDistance
UnboxRep BfsDistance -> BfsDistance
BfsDistance
data MoveLegal = MoveBlocked | MoveToOpen | MoveToClosed | MoveToUnknown
deriving MoveLegal -> MoveLegal -> Bool
(MoveLegal -> MoveLegal -> Bool)
-> (MoveLegal -> MoveLegal -> Bool) -> Eq MoveLegal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MoveLegal -> MoveLegal -> Bool
$c/= :: MoveLegal -> MoveLegal -> Bool
== :: MoveLegal -> MoveLegal -> Bool
$c== :: MoveLegal -> MoveLegal -> Bool
Eq
succBfsDistance :: BfsDistance -> BfsDistance
succBfsDistance :: BfsDistance -> BfsDistance
succBfsDistance d :: BfsDistance
d = DistanceWord -> BfsDistance
BfsDistance (DistanceWord -> BfsDistance) -> DistanceWord -> BfsDistance
forall a b. (a -> b) -> a -> b
$ BfsDistance -> DistanceWord
bfsDistance BfsDistance
d DistanceWord -> DistanceWord -> DistanceWord
forall a. Num a => a -> a -> a
+ 1
predBfsDistance :: BfsDistance -> BfsDistance
predBfsDistance :: BfsDistance -> BfsDistance
predBfsDistance d :: BfsDistance
d = DistanceWord -> BfsDistance
BfsDistance (DistanceWord -> BfsDistance) -> DistanceWord -> BfsDistance
forall a b. (a -> b) -> a -> b
$ BfsDistance -> DistanceWord
bfsDistance BfsDistance
d DistanceWord -> DistanceWord -> DistanceWord
forall a. Num a => a -> a -> a
- 1
subtractBfsDistance :: BfsDistance -> BfsDistance -> Int
subtractBfsDistance :: BfsDistance -> BfsDistance -> Int
subtractBfsDistance d1 :: BfsDistance
d1 d2 :: BfsDistance
d2 = DistanceWord -> Int
forall a. Enum a => a -> Int
fromEnum (DistanceWord -> Int) -> DistanceWord -> Int
forall a b. (a -> b) -> a -> b
$ BfsDistance -> DistanceWord
bfsDistance BfsDistance
d1 DistanceWord -> DistanceWord -> DistanceWord
forall a. Num a => a -> a -> a
- BfsDistance -> DistanceWord
bfsDistance BfsDistance
d2
minKnownBfs :: BfsDistance
minKnownBfs :: BfsDistance
minKnownBfs = DistanceWord -> BfsDistance
BfsDistance (DistanceWord -> BfsDistance) -> DistanceWord -> BfsDistance
forall a b. (a -> b) -> a -> b
$ 1 DistanceWord -> DistanceWord -> DistanceWord
forall a. Num a => a -> a -> a
+ DistanceWord
forall a. Bounded a => a
maxBound DistanceWord -> DistanceWord -> DistanceWord
forall a. Integral a => a -> a -> a
`div` 2
apartBfs :: BfsDistance
apartBfs :: BfsDistance
apartBfs = BfsDistance -> BfsDistance
predBfsDistance BfsDistance
minKnownBfs
maxBfsDistance :: BfsDistance
maxBfsDistance :: BfsDistance
maxBfsDistance = DistanceWord -> BfsDistance
BfsDistance (DistanceWord
forall a. Bounded a => a
maxBound :: DistanceWord)
abortedUnknownBfs :: BfsDistance
abortedUnknownBfs :: BfsDistance
abortedUnknownBfs = BfsDistance -> BfsDistance
predBfsDistance BfsDistance
apartBfs
maskBfs :: BfsDistance -> BfsDistance
{-# INLINE maskBfs #-}
maskBfs :: BfsDistance -> BfsDistance
maskBfs distance :: BfsDistance
distance = BfsDistance
distance BfsDistance -> BfsDistance -> BfsDistance
forall a. Bits a => a -> a -> a
.&. BfsDistance -> BfsDistance
forall a. Bits a => a -> a
complement BfsDistance
minKnownBfs
fillBfs :: PointArray.Array Word8
-> Word8
-> Point
-> (PA.PrimArray PointI, PA.PrimArray PointI)
-> PointArray.Array BfsDistance
fillBfs :: Array Word8
-> Word8
-> Point
-> (PrimArray Int, PrimArray Int)
-> Array BfsDistance
fillBfs !Array Word8
lalter !Word8
alterSkill !Point
source (!PrimArray Int
tabA, !PrimArray Int
tabB) = (forall s. ST s (Array BfsDistance)) -> Array BfsDistance
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Array BfsDistance)) -> Array BfsDistance)
-> (forall s. ST s (Array BfsDistance)) -> Array BfsDistance
forall a b. (a -> b) -> a -> b
$ do
let arr :: Array BfsDistance
arr = Int -> Int -> BfsDistance -> Array BfsDistance
forall c. UnboxRepClass c => Int -> Int -> c -> Array c
PointArray.replicateA
(Array Word8 -> Int
forall c. Array c -> Int
PointArray.axsize Array Word8
lalter) (Array Word8 -> Int
forall c. Array c -> Int
PointArray.aysize Array Word8
lalter) BfsDistance
apartBfs
MVector s DistanceWord
vThawed <- Vector DistanceWord -> ST s (MVector s DistanceWord)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
U.unsafeThaw (Vector DistanceWord -> ST s (MVector s DistanceWord))
-> Vector DistanceWord -> ST s (MVector s DistanceWord)
forall a b. (a -> b) -> a -> b
$ Array BfsDistance -> Vector (UnboxRep BfsDistance)
forall c. Array c -> Vector (UnboxRep c)
PointArray.avector Array BfsDistance
arr
MutablePrimArray s Int
tabAThawed <- PrimArray Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: * -> *) a.
PrimMonad m =>
PrimArray a -> m (MutablePrimArray (PrimState m) a)
PA.unsafeThawPrimArray PrimArray Int
tabA
MutablePrimArray s Int
tabBThawed <- PrimArray Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: * -> *) a.
PrimMonad m =>
PrimArray a -> m (MutablePrimArray (PrimState m) a)
PA.unsafeThawPrimArray PrimArray Int
tabB
Array Word8
-> Word8
-> Int
-> (MutablePrimArray s Int, MutablePrimArray s Int)
-> MVector s DistanceWord
-> ST s ()
forall s.
Array Word8
-> Word8
-> Int
-> (MutablePrimArray s Int, MutablePrimArray s Int)
-> MVector s DistanceWord
-> ST s ()
fillBfsThawed Array Word8
lalter Word8
alterSkill (Point -> Int
forall a. Enum a => a -> Int
fromEnum Point
source)
(MutablePrimArray s Int
tabAThawed, MutablePrimArray s Int
tabBThawed) MVector s DistanceWord
vThawed
ST s (PrimArray Int) -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s (PrimArray Int) -> ST s ())
-> ST s (PrimArray Int) -> ST s ()
forall a b. (a -> b) -> a -> b
$ MutablePrimArray (PrimState (ST s)) Int -> ST s (PrimArray Int)
forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
PA.unsafeFreezePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
tabAThawed
ST s (PrimArray Int) -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s (PrimArray Int) -> ST s ())
-> ST s (PrimArray Int) -> ST s ()
forall a b. (a -> b) -> a -> b
$ MutablePrimArray (PrimState (ST s)) Int -> ST s (PrimArray Int)
forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
PA.unsafeFreezePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
tabBThawed
ST s (Vector DistanceWord) -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s (Vector DistanceWord) -> ST s ())
-> ST s (Vector DistanceWord) -> ST s ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState (ST s)) DistanceWord
-> ST s (Vector DistanceWord)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
U.unsafeFreeze MVector s DistanceWord
MVector (PrimState (ST s)) DistanceWord
vThawed
Array BfsDistance -> ST s (Array BfsDistance)
forall (m :: * -> *) a. Monad m => a -> m a
return Array BfsDistance
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 DistanceWord
-> ST s ()
fillBfsThawed :: Array Word8
-> Word8
-> Int
-> (MutablePrimArray s Int, MutablePrimArray s Int)
-> MVector s DistanceWord
-> ST s ()
fillBfsThawed !Array Word8
lalter !Word8
alterSkill !Int
sourceI
(!MutablePrimArray s Int
tabAThawed, !MutablePrimArray s Int
tabBThawed) !MVector s DistanceWord
vThawed = do
let unsafeReadI :: PointI -> ST s BfsDistance
{-# INLINE unsafeReadI #-}
unsafeReadI :: Int -> ST s BfsDistance
unsafeReadI p :: Int
p = DistanceWord -> BfsDistance
BfsDistance (DistanceWord -> BfsDistance)
-> ST s DistanceWord -> ST s BfsDistance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) DistanceWord -> Int -> ST s DistanceWord
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
VM.unsafeRead MVector s DistanceWord
MVector (PrimState (ST s)) DistanceWord
vThawed Int
p
unsafeWriteI :: PointI -> BfsDistance -> ST s ()
{-# INLINE unsafeWriteI #-}
unsafeWriteI :: Int -> BfsDistance -> ST s ()
unsafeWriteI p :: Int
p c :: BfsDistance
c = MVector (PrimState (ST s)) DistanceWord
-> Int -> DistanceWord -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite MVector s DistanceWord
MVector (PrimState (ST s)) DistanceWord
vThawed Int
p (BfsDistance -> DistanceWord
bfsDistance BfsDistance
c)
bfs :: PA.MutablePrimArray s PointI
-> PA.MutablePrimArray s PointI
-> BfsDistance
-> QueueIx
-> ST s ()
bfs :: MutablePrimArray s Int
-> MutablePrimArray s Int -> BfsDistance -> Int -> ST s ()
bfs !MutablePrimArray s Int
tabReadThawed !MutablePrimArray s Int
tabWriteThawed !BfsDistance
distance !Int
prevQueueIx = do
let unsafeReadCurrent :: QueueIx -> ST s PointI
{-# INLINE unsafeReadCurrent #-}
unsafeReadCurrent :: Int -> ST s Int
unsafeReadCurrent = MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
PA.readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
tabReadThawed
unsafeWriteNext :: QueueIx -> PointI -> ST s ()
{-# INLINE unsafeWriteNext #-}
unsafeWriteNext :: Int -> Int -> ST s ()
unsafeWriteNext = MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PA.writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
tabWriteThawed
processQueue :: QueueIx -> NextQueueIx -> ST s NextQueueIx
processQueue :: Int -> Int -> ST s Int
processQueue !Int
currentQueueIx !Int
acc1 =
if Int
currentQueueIx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -1
then Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
acc1
else do
Int
pos <- Int -> ST s Int
unsafeReadCurrent Int
currentQueueIx
let processMove :: (X, Y) -> NextQueueIx -> ST s NextQueueIx
{-# INLINE processMove #-}
processMove :: (Int, Int) -> Int -> ST s Int
processMove move :: (Int, Int)
move acc2 :: Int
acc2 = do
let p :: Int
p = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Vector -> Int) -> Vector -> Int
forall a. a -> a
inline Vector -> Int
forall a. Enum a => a -> Int
fromEnum ((Int -> Int -> Vector) -> (Int, Int) -> Vector
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Vector
Vector (Int, Int)
move)
BfsDistance
pDist <- Int -> ST s BfsDistance
unsafeReadI Int
p
if BfsDistance
pDist BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
/= BfsDistance
apartBfs
then Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
acc2
else do
let alter :: Word8
!alter :: Word8
alter = Array Word8
lalter Array Word8 -> Int -> UnboxRep Word8
forall c. UnboxRepClass c => Array c -> Int -> UnboxRep c
`PointArray.accessI` Int
p
if | Word8
alterSkill Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
alter -> Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
acc2
| Word8
alter Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 -> do
let distCompl :: BfsDistance
distCompl = BfsDistance -> BfsDistance
maskBfs BfsDistance
distance
Int -> BfsDistance -> ST s ()
unsafeWriteI Int
p BfsDistance
distCompl
Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
acc2
| Bool
otherwise -> do
Int -> BfsDistance -> ST s ()
unsafeWriteI Int
p BfsDistance
distance
Int -> Int -> ST s ()
unsafeWriteNext Int
acc2 Int
p
Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$! Int
acc2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
acc1
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int, Int) -> Int -> ST s Int
processMove (-1, -1)
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int, Int) -> Int -> ST s Int
processMove (0, -1)
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int, Int) -> Int -> ST s Int
processMove (1, -1)
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int, Int) -> Int -> ST s Int
processMove (1, 0)
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int, Int) -> Int -> ST s Int
processMove (1, 1)
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int, Int) -> Int -> ST s Int
processMove (0, 1)
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int, Int) -> Int -> ST s Int
processMove (-1, 1)
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int, Int) -> Int -> ST s Int
processMove (-1, 0)
ST s Int -> (Int -> ST s Int) -> ST s Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> ST s Int
processQueue (Int
currentQueueIx Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
Int
acc3 <- Int -> Int -> ST s Int
processQueue (Int
prevQueueIx Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) 0
let distanceNew :: BfsDistance
distanceNew = BfsDistance -> BfsDistance
succBfsDistance BfsDistance
distance
if Int
acc3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| BfsDistance
distanceNew BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
== BfsDistance
maxBfsDistance
then () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else MutablePrimArray s Int
-> MutablePrimArray s Int -> BfsDistance -> Int -> ST s ()
bfs MutablePrimArray s Int
tabWriteThawed MutablePrimArray s Int
tabReadThawed BfsDistance
distanceNew Int
acc3
MVector (PrimState (ST s)) DistanceWord
-> Int -> DistanceWord -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite MVector s DistanceWord
MVector (PrimState (ST s)) DistanceWord
vThawed Int
sourceI (BfsDistance -> DistanceWord
bfsDistance BfsDistance
minKnownBfs)
MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PA.writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
tabAThawed 0 Int
sourceI
MutablePrimArray s Int
-> MutablePrimArray s Int -> BfsDistance -> Int -> ST s ()
bfs MutablePrimArray s Int
tabAThawed MutablePrimArray s Int
tabBThawed (BfsDistance -> BfsDistance
succBfsDistance BfsDistance
minKnownBfs) 1
data AndPath = AndPath
{ AndPath -> Point
pathSource :: Point
, AndPath -> [Point]
pathList :: [Point]
, AndPath -> Point
pathGoal :: Point
, AndPath -> Int
pathLen :: Int
}
deriving (Int -> AndPath -> ShowS
[AndPath] -> ShowS
AndPath -> String
(Int -> AndPath -> ShowS)
-> (AndPath -> String) -> ([AndPath] -> ShowS) -> Show AndPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AndPath] -> ShowS
$cshowList :: [AndPath] -> ShowS
show :: AndPath -> String
$cshow :: AndPath -> String
showsPrec :: Int -> AndPath -> ShowS
$cshowsPrec :: Int -> AndPath -> ShowS
Show, (forall x. AndPath -> Rep AndPath x)
-> (forall x. Rep AndPath x -> AndPath) -> Generic AndPath
forall x. Rep AndPath x -> AndPath
forall x. AndPath -> Rep AndPath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AndPath x -> AndPath
$cfrom :: forall x. AndPath -> Rep AndPath x
Generic)
instance Binary AndPath
findPathBfs :: ES.EnumSet Point -> PointArray.Array Word8 -> (PointI -> Bool)
-> Point -> Point -> Int
-> PointArray.Array BfsDistance
-> Maybe AndPath
{-# INLINE findPathBfs #-}
findPathBfs :: EnumSet Point
-> Array Word8
-> (Int -> Bool)
-> Point
-> Point
-> Int
-> Array BfsDistance
-> Maybe AndPath
findPathBfs lbig :: EnumSet Point
lbig lalter :: Array Word8
lalter fovLit :: Int -> Bool
fovLit pathSource :: Point
pathSource pathGoal :: Point
pathGoal sepsRaw :: Int
sepsRaw arr :: Array BfsDistance
arr =
let !pathGoalI :: Int
pathGoalI = Point -> Int
forall a. Enum a => a -> Int
fromEnum Point
pathGoal
!pathSourceI :: Int
pathSourceI = Point -> Int
forall a. Enum a => a -> Int
fromEnum Point
pathSource
eps :: Int
eps = Int
sepsRaw Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 4
(mc1 :: [Int]
mc1, mc2 :: [Int]
mc2) = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
eps [Int]
movesCardinalI
(md1 :: [Int]
md1, md2 :: [Int]
md2) = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
eps [Int]
movesDiagonalI
prefMoves :: [Int]
prefMoves = [Int]
mc2 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
mc1 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
md2 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
md1
track :: PointI -> BfsDistance -> [Point] -> [Point]
track :: Int -> BfsDistance -> [Point] -> [Point]
track !Int
pos !BfsDistance
oldDist ![Point]
suffix | BfsDistance
oldDist BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
== BfsDistance
minKnownBfs =
Bool -> [Point] -> [Point]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
pathSourceI) [Point]
suffix
track pos :: Int
pos oldDist :: BfsDistance
oldDist suffix :: [Point]
suffix | BfsDistance
oldDist BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
== BfsDistance -> BfsDistance
succBfsDistance BfsDistance
minKnownBfs =
let !posP :: Point
posP = Int -> Point
forall a. Enum a => Int -> a
toEnum Int
pos
in Point
posP Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point]
suffix
track pos :: Int
pos oldDist :: BfsDistance
oldDist suffix :: [Point]
suffix =
let !dist :: BfsDistance
dist = BfsDistance -> BfsDistance
predBfsDistance BfsDistance
oldDist
minChild :: PointI -> Bool -> Word8 -> [VectorI] -> PointI
minChild :: Int -> Bool -> Word8 -> [Int] -> Int
minChild !Int
minP _ _ [] = Int
minP
minChild minP :: Int
minP maxDark :: Bool
maxDark minAlter :: Word8
minAlter (mv :: Int
mv : mvs :: [Int]
mvs) =
let !p :: Int
p = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mv
backtrackingMove :: Bool
backtrackingMove =
DistanceWord -> BfsDistance
BfsDistance (Array BfsDistance
arr Array BfsDistance -> Int -> UnboxRep BfsDistance
forall c. UnboxRepClass c => Array c -> Int -> UnboxRep c
`PointArray.accessI` Int
p) BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
/= BfsDistance
dist
in if Bool
backtrackingMove
then Int -> Bool -> Word8 -> [Int] -> Int
minChild Int
minP Bool
maxDark Word8
minAlter [Int]
mvs
else let free :: Bool
free = Int
p Int -> IntSet -> Bool
`IS.notMember` EnumSet Point -> IntSet
forall k. EnumSet k -> IntSet
ES.enumSetToIntSet EnumSet Point
lbig
alter :: Word8
alter | Bool
free = Array Word8
lalter Array Word8 -> Int -> UnboxRep Word8
forall c. UnboxRepClass c => Array c -> Int -> UnboxRep c
`PointArray.accessI` Int
p
| Bool
otherwise = Word8
forall a. Bounded a => a
maxBoundWord8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
-1
dark :: Bool
dark = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Bool
fovLit Int
p
in if | Word8
alter Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Bool
dark -> Int
p
| Word8
alter Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
minAlter -> Int -> Bool -> Word8 -> [Int] -> Int
minChild Int
p Bool
dark Word8
alter [Int]
mvs
| Bool
dark Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
> Bool
maxDark Bool -> Bool -> Bool
&& Word8
alter Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
minAlter ->
Int -> Bool -> Word8 -> [Int] -> Int
minChild Int
p Bool
dark Word8
alter [Int]
mvs
| Bool
otherwise -> Int -> Bool -> Word8 -> [Int] -> Int
minChild Int
minP Bool
maxDark Word8
minAlter [Int]
mvs
!newPos :: Int
newPos = Int -> Bool -> Word8 -> [Int] -> Int
minChild Int
pos Bool
False Word8
forall a. Bounded a => a
maxBound [Int]
prefMoves
#ifdef WITH_EXPENSIVE_ASSERTIONS
!_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
newPos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
pos) ()
#endif
!posP :: Point
posP = Int -> Point
forall a. Enum a => Int -> a
toEnum Int
pos
in Int -> BfsDistance -> [Point] -> [Point]
track Int
newPos BfsDistance
dist (Point
posP Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point]
suffix)
!goalDist :: BfsDistance
goalDist = DistanceWord -> BfsDistance
BfsDistance (DistanceWord -> BfsDistance) -> DistanceWord -> BfsDistance
forall a b. (a -> b) -> a -> b
$ Array BfsDistance
arr Array BfsDistance -> Int -> UnboxRep BfsDistance
forall c. UnboxRepClass c => Array c -> Int -> UnboxRep c
`PointArray.accessI` Int
pathGoalI
pathLen :: Int
pathLen = DistanceWord -> Int
forall a. Enum a => a -> Int
fromEnum (DistanceWord -> Int) -> DistanceWord -> Int
forall a b. (a -> b) -> a -> b
$ BfsDistance -> DistanceWord
bfsDistance (BfsDistance -> DistanceWord) -> BfsDistance -> DistanceWord
forall a b. (a -> b) -> a -> b
$ BfsDistance -> BfsDistance
maskBfs BfsDistance
goalDist
pathList :: [Point]
pathList = Int -> BfsDistance -> [Point] -> [Point]
track Int
pathGoalI (BfsDistance
goalDist BfsDistance -> BfsDistance -> BfsDistance
forall a. Bits a => a -> a -> a
.|. BfsDistance
minKnownBfs) []
andPath :: AndPath
andPath = $WAndPath :: Point -> [Point] -> Point -> Int -> AndPath
AndPath{..}
in Bool -> Maybe AndPath -> Maybe AndPath
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (DistanceWord -> BfsDistance
BfsDistance (Array BfsDistance
arr Array BfsDistance -> Int -> UnboxRep BfsDistance
forall c. UnboxRepClass c => Array c -> Int -> UnboxRep c
`PointArray.accessI` Int
pathSourceI)
BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
== BfsDistance
minKnownBfs) (Maybe AndPath -> Maybe AndPath) -> Maybe AndPath -> Maybe AndPath
forall a b. (a -> b) -> a -> b
$
if BfsDistance
goalDist BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
/= BfsDistance
apartBfs Bool -> Bool -> Bool
&& Int
pathLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Point -> Point -> Int
chessDist Point
pathSource Point
pathGoal
then AndPath -> Maybe AndPath
forall a. a -> Maybe a
Just AndPath
andPath
else let f :: (Point, Int, Int, Int) -> Point -> BfsDistance
-> (Point, Int, Int, Int)
f :: (Point, Int, Int, Int)
-> Point -> BfsDistance -> (Point, Int, Int, Int)
f acc :: (Point, Int, Int, Int)
acc@(pAcc :: Point
pAcc, dAcc :: Int
dAcc, chessAcc :: Int
chessAcc, sumAcc :: Int
sumAcc) p :: Point
p d :: BfsDistance
d =
if BfsDistance
d BfsDistance -> BfsDistance -> Bool
forall a. Ord a => a -> a -> Bool
<= BfsDistance
abortedUnknownBfs
Bool -> Bool -> Bool
|| BfsDistance
d BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
/= BfsDistance
apartBfs Bool -> Bool -> Bool
&& Point -> Point -> Bool
adjacent Point
p Point
pathGoal
then let dist :: Int
dist = DistanceWord -> Int
forall a. Enum a => a -> Int
fromEnum (DistanceWord -> Int) -> DistanceWord -> Int
forall a b. (a -> b) -> a -> b
$ BfsDistance -> DistanceWord
bfsDistance (BfsDistance -> DistanceWord) -> BfsDistance -> DistanceWord
forall a b. (a -> b) -> a -> b
$ BfsDistance -> BfsDistance
maskBfs BfsDistance
d
chessNew :: Int
chessNew = Point -> Point -> Int
chessDist Point
p Point
pathGoal
sumNew :: Int
sumNew = Int
dist Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
chessNew
resNew :: (Point, Int, Int, Int)
resNew = (Point
p, Int
dist, Int
chessNew, Int
sumNew)
in case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
sumNew Int
sumAcc of
LT -> (Point, Int, Int, Int)
resNew
EQ -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
chessNew Int
chessAcc of
LT -> (Point, Int, Int, Int)
resNew
EQ -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
dist Int
dAcc of
LT -> (Point, Int, Int, Int)
resNew
EQ | Point -> Point -> Int
euclidDistSq Point
p Point
pathGoal
Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Point -> Point -> Int
euclidDistSq Point
pAcc Point
pathGoal -> (Point, Int, Int, Int)
resNew
_ -> (Point, Int, Int, Int)
acc
_ -> (Point, Int, Int, Int)
acc
_ -> (Point, Int, Int, Int)
acc
else (Point, Int, Int, Int)
acc
initAcc :: (Point, Int, Int, Int)
initAcc = (Point
originPoint, Int
forall a. Bounded a => a
maxBound, Int
forall a. Bounded a => a
maxBound, Int
forall a. Bounded a => a
maxBound)
(pRes :: Point
pRes, dRes :: Int
dRes, _, sumRes :: Int
sumRes) = ((Point, Int, Int, Int)
-> Point -> BfsDistance -> (Point, Int, Int, Int))
-> (Point, Int, Int, Int)
-> Array BfsDistance
-> (Point, Int, Int, Int)
forall c a.
UnboxRepClass c =>
(a -> Point -> c -> a) -> a -> Array c -> a
PointArray.ifoldlA' (Point, Int, Int, Int)
-> Point -> BfsDistance -> (Point, Int, Int, Int)
f (Point, Int, Int, Int)
initAcc Array BfsDistance
arr
in if Int
sumRes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Bounded a => a
maxBound
Bool -> Bool -> Bool
|| BfsDistance
goalDist BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
/= BfsDistance
apartBfs Bool -> Bool -> Bool
&& Int
pathLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sumRes
then if BfsDistance
goalDist BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
/= BfsDistance
apartBfs then AndPath -> Maybe AndPath
forall a. a -> Maybe a
Just AndPath
andPath else Maybe AndPath
forall a. Maybe a
Nothing
else let pathList2 :: [Point]
pathList2 =
Int -> BfsDistance -> [Point] -> [Point]
track (Point -> Int
forall a. Enum a => a -> Int
fromEnum Point
pRes)
(DistanceWord -> BfsDistance
BfsDistance (Int -> DistanceWord
forall a. Enum a => Int -> a
toEnum Int
dRes) BfsDistance -> BfsDistance -> BfsDistance
forall a. Bits a => a -> a -> a
.|. BfsDistance
minKnownBfs) []
in AndPath -> Maybe AndPath
forall a. a -> Maybe a
Just $WAndPath :: Point -> [Point] -> Point -> Int -> AndPath
AndPath{pathList :: [Point]
pathList = [Point]
pathList2, pathLen :: Int
pathLen = Int
sumRes, ..}
accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int
accessBfs :: Array BfsDistance -> Point -> Maybe Int
accessBfs bfs :: Array BfsDistance
bfs p :: Point
p = if Array BfsDistance -> Int
forall c. Array c -> Int
PointArray.axsize Array BfsDistance
bfs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then Maybe Int
forall a. Maybe a
Nothing
else BfsDistance -> Maybe Int
distanceBfs (BfsDistance -> Maybe Int) -> BfsDistance -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Array BfsDistance
bfs Array BfsDistance -> Point -> BfsDistance
forall c. UnboxRepClass c => Array c -> Point -> c
PointArray.! Point
p
distanceBfs :: BfsDistance -> Maybe Int
{-# INLINE distanceBfs #-}
distanceBfs :: BfsDistance -> Maybe Int
distanceBfs dist :: BfsDistance
dist = if BfsDistance
dist BfsDistance -> BfsDistance -> Bool
forall a. Eq a => a -> a -> Bool
== BfsDistance
apartBfs
then Maybe Int
forall a. Maybe a
Nothing
else Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ DistanceWord -> Int
forall a. Enum a => a -> Int
fromEnum (DistanceWord -> Int) -> DistanceWord -> Int
forall a b. (a -> b) -> a -> b
$ BfsDistance -> DistanceWord
bfsDistance (BfsDistance -> DistanceWord) -> BfsDistance -> DistanceWord
forall a b. (a -> b) -> a -> b
$ BfsDistance -> BfsDistance
maskBfs BfsDistance
dist