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