-- |
-- Module      : AOC.Challenge.Day11
-- License     : BSD3
--
-- Stability   : experimental
-- Portability : non-portable
--
-- Day 11.  See "AOC.Solver" for the types used in this module!

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    -- not in the input, but just for completion's sake
    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                          -- ^ exit seat threshold
    -> V.Vector n [Finite n]        -- ^ neighbors
    -> MVU.MVector n s Bit          -- ^ source
    -> MVU.MVector n s Bit          -- ^ target
    -> StateT Bool m ()             -- ^ changed
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                      -- ^ exit seat threshold
    -> V.Vector n [Finite n]    -- ^ neighbors
    -> VU.Vector n Bit
    -> Int                      -- ^ equilibrium size
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


-- | Get a map of points to all of those points' neighbors where there is
-- a seat. Should only need to be computed once.
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)
        -- compilation itself takes about 38ms
    }

-- | Get a map of points to all of those points' visible neighbors. Should
-- only need to be computed once.
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)
        -- compilation itself takes about 32ms
    }