module AOC.Challenge.Day11 (
day11a
, day11b
) where
import AOC.Common (countTrue)
import AOC.Common.Point (Point, boundingBox', inBoundingBox, fullNeighbs, fullNeighbsSet, parseAsciiMap)
import AOC.Solver ((:~>)(..))
import Control.Monad.Loops (whileM_)
import Control.Monad.Primitive (PrimMonad, PrimState)
import Control.Monad.ST (runST)
import Control.Monad.State.Strict (execStateT, StateT(..))
import Data.Bit (Bit(..))
import Data.Bits (popCount)
import Data.Finite (Finite, finites)
import Data.Foldable (find, toList, traverse_)
import Data.Map (Map)
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import GHC.TypeNats (KnownNat)
import Linear (V2(..))
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Vector.Generic.Sized as VG
import qualified Data.Vector.Sized as V
import qualified Data.Vector.Unboxed.Mutable.Sized as MVU
import qualified Data.Vector.Unboxed.Sized as VU
parseSeatMap :: String -> Map Point Bool
parseSeatMap :: String -> Map Point Bool
parseSeatMap = (Char -> Maybe Bool) -> String -> Map Point Bool
forall a. (Char -> Maybe a) -> String -> Map Point a
parseAsciiMap ((Char -> Maybe Bool) -> String -> Map Point Bool)
-> (Char -> Maybe Bool) -> String -> Map Point Bool
forall a b. (a -> b) -> a -> b
$ \case
Char
'L' -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
Char
'#' -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Char
_ -> Maybe Bool
forall a. Maybe a
Nothing
compile
:: Map Point (Set Point, Bool)
-> (forall n. KnownNat n => V.Vector n [Finite n] -> VU.Vector n Bit -> r)
-> r
compile :: forall r.
Map Point (Set Point, Bool)
-> (forall (n :: Nat).
KnownNat n =>
Vector n [Finite n] -> Vector n Bit -> r)
-> r
compile Map Point (Set Point, Bool)
mp forall (n :: Nat).
KnownNat n =>
Vector n [Finite n] -> Vector n Bit -> r
f = [(Set Point, Bool)]
-> (forall (n :: Nat).
KnownNat n =>
Vector n (Set Point, Bool) -> r)
-> r
forall a r.
[a] -> (forall (n :: Nat). KnownNat n => Vector n a -> r) -> r
V.withSizedList (Map Point (Set Point, Bool) -> [(Set Point, Bool)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Point (Set Point, Bool)
mp) ((forall (n :: Nat). KnownNat n => Vector n (Set Point, Bool) -> r)
-> r)
-> (forall (n :: Nat).
KnownNat n =>
Vector n (Set Point, Bool) -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \Vector n (Set Point, Bool)
xs ->
Vector n [Finite n] -> Vector n Bit -> r
forall (n :: Nat).
KnownNat n =>
Vector n [Finite n] -> Vector n Bit -> r
f ((Point -> Finite n) -> [Point] -> [Finite n]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Finite n
forall (n :: Nat). KnownNat n => Point -> Finite n
go ([Point] -> [Finite n])
-> ((Set Point, Bool) -> [Point])
-> (Set Point, Bool)
-> [Finite n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Point -> [Point]
forall a. Set a -> [a]
S.toList (Set Point -> [Point])
-> ((Set Point, Bool) -> Set Point) -> (Set Point, Bool) -> [Point]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Point, Bool) -> Set Point
forall a b. (a, b) -> a
fst ((Set Point, Bool) -> [Finite n])
-> Vector n (Set Point, Bool) -> Vector n [Finite n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector n (Set Point, Bool)
xs)
(Vector Vector n Bit -> Vector n Bit
forall (v :: * -> *) a (w :: * -> *) (n :: Nat).
(Vector v a, Vector w a) =>
Vector v n a -> Vector w n a
VG.convert (Bool -> Bit
Bit (Bool -> Bit)
-> ((Set Point, Bool) -> Bool) -> (Set Point, Bool) -> Bit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Point, Bool) -> Bool
forall a b. (a, b) -> b
snd ((Set Point, Bool) -> Bit)
-> Vector n (Set Point, Bool) -> Vector Vector n Bit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector n (Set Point, Bool)
xs))
where
go :: KnownNat n => Point -> Finite n
go :: forall (n :: Nat). KnownNat n => Point -> Finite n
go = Int -> Finite n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Finite n) -> (Point -> Int) -> Point -> Finite n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Map Point (Set Point, Bool) -> Int
forall k a. Ord k => k -> Map k a -> Int
`M.findIndex` Map Point (Set Point, Bool)
mp)
seatRule
:: forall n m s. (KnownNat n, PrimMonad m, s ~ PrimState m)
=> Int
-> V.Vector n [Finite n]
-> MVU.MVector n s Bit
-> MVU.MVector n s Bit
-> StateT Bool m ()
seatRule :: forall (n :: Nat) (m :: * -> *) s.
(KnownNat n, PrimMonad m, s ~ PrimState m) =>
Int
-> Vector n [Finite n]
-> MVector n s Bit
-> MVector n s Bit
-> StateT Bool m ()
seatRule Int
thr Vector n [Finite n]
ns MVector n s Bit
src MVector n s Bit
targ = (Finite n -> StateT Bool m ()) -> [Finite n] -> StateT Bool m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Finite n -> StateT Bool m ()
go [Finite n]
forall (n :: Nat). KnownNat n => [Finite n]
finites
where
go :: Finite n -> StateT Bool m ()
go :: Finite n -> StateT Bool m ()
go Finite n
i = (Bool -> m ((), Bool)) -> StateT Bool m ()
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((Bool -> m ((), Bool)) -> StateT Bool m ())
-> (Bool -> m ((), Bool)) -> StateT Bool m ()
forall a b. (a -> b) -> a -> b
$ \Bool
changed -> do
Bit Bool
x <- MVector n (PrimState m) Bit -> Finite n -> m Bit
forall (n :: Nat) (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector n (PrimState m) a -> Finite n -> m a
MVU.read MVector n s Bit
MVector n (PrimState m) Bit
src Finite n
i
Int
n <- (Bit -> Bool) -> [Bit] -> Int
forall (f :: * -> *) a. Foldable f => (a -> Bool) -> f a -> Int
countTrue Bit -> Bool
unBit ([Bit] -> Int) -> m [Bit] -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Finite n -> m Bit) -> [Finite n] -> m [Bit]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (MVector n (PrimState m) Bit -> Finite n -> m Bit
forall (n :: Nat) (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector n (PrimState m) a -> Finite n -> m a
MVU.read MVector n s Bit
MVector n (PrimState m) Bit
src) (Vector n [Finite n]
ns Vector n [Finite n] -> Finite n -> [Finite n]
forall (n :: Nat) a. Vector n a -> Finite n -> a
`V.index` Finite n
i)
let x' :: Bool
x' = case Bool
x of
Bool
False -> Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
Bool
True -> Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
thr
MVector n (PrimState m) Bit -> Finite n -> Bit -> m ()
forall (n :: Nat) (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector n (PrimState m) a -> Finite n -> a -> m ()
MVU.write MVector n s Bit
MVector n (PrimState m) Bit
targ Finite n
i (Bool -> Bit
Bit Bool
x')
pure ((), Bool
changed Bool -> Bool -> Bool
|| Bool
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
x')
{-# INLINE go #-}
{-# INLINE seatRule #-}
solveWith
:: KnownNat n
=> Int
-> V.Vector n [Finite n]
-> VU.Vector n Bit
-> Int
solveWith :: forall (n :: Nat).
KnownNat n =>
Int -> Vector n [Finite n] -> Vector n Bit -> Int
solveWith Int
thr Vector n [Finite n]
ns Vector n Bit
xs = (forall s. ST s Int) -> Int
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Int) -> Int) -> (forall s. ST s Int) -> Int
forall a b. (a -> b) -> a -> b
$ do
MVector n s Bit
xs0 <- Vector n Bit -> ST s (MVector n (PrimState (ST s)) Bit)
forall (m :: * -> *) a (n :: Nat).
(PrimMonad m, Unbox a) =>
Vector n a -> m (MVector n (PrimState m) a)
VU.thaw Vector n Bit
xs
MVector n s Bit
xs1 <- ST s (MVector n s Bit)
forall (n :: Nat) (m :: * -> *) a.
(KnownNat n, PrimMonad m, Unbox a) =>
m (MVector n (PrimState m) a)
MVU.unsafeNew
(ST s Bool -> ST s () -> ST s ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m ()
`whileM_` () -> ST s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (ST s Bool -> ST s ())
-> (StateT Bool (ST s) () -> ST s Bool)
-> StateT Bool (ST s) ()
-> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT Bool (ST s) () -> Bool -> ST s Bool)
-> Bool -> StateT Bool (ST s) () -> ST s Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Bool (ST s) () -> Bool -> ST s Bool
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Bool
False (StateT Bool (ST s) () -> ST s ())
-> StateT Bool (ST s) () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
Int
-> Vector n [Finite n]
-> MVector n s Bit
-> MVector n s Bit
-> StateT Bool (ST s) ()
forall (n :: Nat) (m :: * -> *) s.
(KnownNat n, PrimMonad m, s ~ PrimState m) =>
Int
-> Vector n [Finite n]
-> MVector n s Bit
-> MVector n s Bit
-> StateT Bool m ()
seatRule Int
thr Vector n [Finite n]
ns MVector n s Bit
xs0 MVector n s Bit
xs1
Int
-> Vector n [Finite n]
-> MVector n s Bit
-> MVector n s Bit
-> StateT Bool (ST s) ()
forall (n :: Nat) (m :: * -> *) s.
(KnownNat n, PrimMonad m, s ~ PrimState m) =>
Int
-> Vector n [Finite n]
-> MVector n s Bit
-> MVector n s Bit
-> StateT Bool m ()
seatRule Int
thr Vector n [Finite n]
ns MVector n s Bit
xs1 MVector n s Bit
xs0
Vector n Bit -> Int
forall a. Bits a => a -> Int
popCount (Vector n Bit -> Int) -> ST s (Vector n Bit) -> ST s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector n (PrimState (ST s)) Bit -> ST s (Vector n Bit)
forall (m :: * -> *) a (n :: Nat).
(PrimMonad m, Unbox a) =>
MVector n (PrimState m) a -> m (Vector n a)
VU.unsafeFreeze MVector n s Bit
MVector n (PrimState (ST s)) Bit
xs0
lineOfSights1
:: Set Point
-> Map Point (Set Point)
lineOfSights1 :: Set Point -> Map Point (Set Point)
lineOfSights1 Set Point
pts = (Point -> Set Point) -> Set Point -> Map Point (Set Point)
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet Point -> Set Point
go Set Point
pts
where
go :: Point -> Set Point
go Point
p = Point -> Set Point
forall (f :: * -> *) a.
(Applicative f, Num a, Ord (f a), Traversable f) =>
f a -> Set (f a)
fullNeighbsSet Point
p Set Point -> Set Point -> Set Point
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set Point
pts
day11a :: Map Point Bool :~> Int
day11a :: Map Point Bool :~> Int
day11a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
{ sParse :: String -> Maybe (Map Point Bool)
sParse = Map Point Bool -> Maybe (Map Point Bool)
forall a. a -> Maybe a
Just (Map Point Bool -> Maybe (Map Point Bool))
-> (String -> Map Point Bool) -> String -> Maybe (Map Point Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map Point Bool
parseSeatMap
, sShow :: Int -> String
sShow = Int -> String
forall a. Show a => a -> String
show
, sSolve :: (?dyno::DynoMap) => Map Point Bool -> Maybe Int
sSolve = \Map Point Bool
mp -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$
let los :: Map Point (Set Point)
los = Set Point -> Map Point (Set Point)
lineOfSights1 (Map Point Bool -> Set Point
forall k a. Map k a -> Set k
M.keysSet Map Point Bool
mp)
in Map Point (Set Point, Bool)
-> (forall (n :: Nat).
KnownNat n =>
Vector n [Finite n] -> Vector n Bit -> Int)
-> Int
forall r.
Map Point (Set Point, Bool)
-> (forall (n :: Nat).
KnownNat n =>
Vector n [Finite n] -> Vector n Bit -> r)
-> r
compile ((Set Point -> Bool -> (Set Point, Bool))
-> Map Point (Set Point)
-> Map Point Bool
-> Map Point (Set Point, Bool)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (,) Map Point (Set Point)
los Map Point Bool
mp) (Int -> Vector n [Finite n] -> Vector n Bit -> Int
forall (n :: Nat).
KnownNat n =>
Int -> Vector n [Finite n] -> Vector n Bit -> Int
solveWith Int
4)
}
lineOfSights2
:: V2 Point
-> Set Point
-> Map Point (Set Point)
lineOfSights2 :: V2 Point -> Set Point -> Map Point (Set Point)
lineOfSights2 V2 Point
bb Set Point
pts = (Point -> Set Point) -> Set Point -> Map Point (Set Point)
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet Point -> Set Point
go Set Point
pts
where
go :: Point -> Set Point
go Point
p = [Point] -> Set Point
forall a. Ord a => [a] -> Set a
S.fromList
([Point] -> Set Point)
-> ([Point] -> [Point]) -> [Point] -> Set Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Maybe Point) -> [Point] -> [Point]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Point -> Point -> Maybe Point
los Point
p)
([Point] -> Set Point) -> [Point] -> Set Point
forall a b. (a -> b) -> a -> b
$ Point -> [Point]
forall (f :: * -> *) a.
(Applicative f, Num a, Traversable f) =>
f a -> [f a]
fullNeighbs Point
0
los :: Point -> Point -> Maybe Point
los Point
p Point
d = (Point -> Bool) -> [Point] -> Maybe Point
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Point -> Set Point -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Point
pts)
([Point] -> Maybe Point)
-> ([Point] -> [Point]) -> [Point] -> Maybe Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Bool) -> [Point] -> [Point]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (V2 Point -> Point -> Bool
forall (g :: * -> *) a.
(Applicative g, Foldable g, Ord a) =>
V2 (g a) -> g a -> Bool
inBoundingBox V2 Point
bb)
([Point] -> [Point]) -> ([Point] -> [Point]) -> [Point] -> [Point]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> [Point]
forall a. [a] -> [a]
tail
([Point] -> Maybe Point) -> [Point] -> Maybe Point
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> Point -> [Point]
forall a. (a -> a) -> a -> [a]
iterate (Point -> Point -> Point
forall a. Num a => a -> a -> a
+ Point
d) Point
p
day11b :: Map Point Bool :~> Int
day11b :: Map Point Bool :~> Int
day11b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
{ sParse :: String -> Maybe (Map Point Bool)
sParse = Map Point Bool -> Maybe (Map Point Bool)
forall a. a -> Maybe a
Just (Map Point Bool -> Maybe (Map Point Bool))
-> (String -> Map Point Bool) -> String -> Maybe (Map Point Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map Point Bool
parseSeatMap
, sShow :: Int -> String
sShow = Int -> String
forall a. Show a => a -> String
show
, sSolve :: (?dyno::DynoMap) => Map Point Bool -> Maybe Int
sSolve = \Map Point Bool
mp -> do
V2 Point
bb <- [Point] -> Maybe (V2 Point)
forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Applicative g, Ord a) =>
f (g a) -> Maybe (V2 (g a))
boundingBox' (Map Point Bool -> [Point]
forall k a. Map k a -> [k]
M.keys Map Point Bool
mp)
let los :: Map Point (Set Point)
los = V2 Point -> Set Point -> Map Point (Set Point)
lineOfSights2 V2 Point
bb (Map Point Bool -> Set Point
forall k a. Map k a -> Set k
M.keysSet Map Point Bool
mp)
Int -> Maybe Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Map Point (Set Point, Bool)
-> (forall (n :: Nat).
KnownNat n =>
Vector n [Finite n] -> Vector n Bit -> Int)
-> Int
forall r.
Map Point (Set Point, Bool)
-> (forall (n :: Nat).
KnownNat n =>
Vector n [Finite n] -> Vector n Bit -> r)
-> r
compile ((Set Point -> Bool -> (Set Point, Bool))
-> Map Point (Set Point)
-> Map Point Bool
-> Map Point (Set Point, Bool)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (,) Map Point (Set Point)
los Map Point Bool
mp) (Int -> Vector n [Finite n] -> Vector n Bit -> Int
forall (n :: Nat).
KnownNat n =>
Int -> Vector n [Finite n] -> Vector n Bit -> Int
solveWith Int
5)
}