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

module AOC.Challenge.Day24 (
    day24a
  , day24b
  ) where

import           AOC.Common                           ((!!!), foldMapParChunk)
import           AOC.Common.Point                     (Point)
import           AOC.Solver                           ((:~>)(..))
import           Control.DeepSeq                      (NFData)
import           Data.Coerce                          (coerce)
import           Data.Map                             (Map)
import           Data.Semigroup                       (Sum(..))
import           Data.Set                             (Set)
import           GHC.Generics                         (Generic)
import           Linear.V2                            (V2(..))
import           Math.Geometry.Grid.HexagonalInternal (HexDirection(..))
import qualified Data.Map.Monoidal.Strict             as MM
import qualified Data.Map.Strict                      as M
import qualified Data.Set                             as S

neighbors :: Point -> Set Point
neighbors :: Point -> Set Point
neighbors (V2 Int
x Int
y) = [Point] -> Set Point
forall a. [a] -> Set a
S.fromDistinctAscList
    [ Int -> Int -> Point
forall a. a -> a -> V2 a
V2 (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
y
    , Int -> Int -> Point
forall a. a -> a -> V2 a
V2 (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    , Int -> Int -> Point
forall a. a -> a -> V2 a
V2 Int
x     (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    , Int -> Int -> Point
forall a. a -> a -> V2 a
V2 Int
x     (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    , Int -> Int -> Point
forall a. a -> a -> V2 a
V2 (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    , Int -> Int -> Point
forall a. a -> a -> V2 a
V2 (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
y
    ]

toDirs :: String -> Maybe [HexDirection]
toDirs :: String -> Maybe [HexDirection]
toDirs = \case
    [] -> [HexDirection] -> Maybe [HexDirection]
forall a. a -> Maybe a
Just []
    Char
'w':String
ds -> (HexDirection
WestHexDirection -> [HexDirection] -> [HexDirection]
forall a. a -> [a] -> [a]
:) ([HexDirection] -> [HexDirection])
-> Maybe [HexDirection] -> Maybe [HexDirection]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [HexDirection]
toDirs String
ds
    Char
'e':String
ds -> (HexDirection
EastHexDirection -> [HexDirection] -> [HexDirection]
forall a. a -> [a] -> [a]
:) ([HexDirection] -> [HexDirection])
-> Maybe [HexDirection] -> Maybe [HexDirection]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [HexDirection]
toDirs String
ds
    Char
'n':Char
'e':String
ds -> (HexDirection
NortheastHexDirection -> [HexDirection] -> [HexDirection]
forall a. a -> [a] -> [a]
:) ([HexDirection] -> [HexDirection])
-> Maybe [HexDirection] -> Maybe [HexDirection]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [HexDirection]
toDirs String
ds
    Char
'n':Char
'w':String
ds -> (HexDirection
NorthwestHexDirection -> [HexDirection] -> [HexDirection]
forall a. a -> [a] -> [a]
:) ([HexDirection] -> [HexDirection])
-> Maybe [HexDirection] -> Maybe [HexDirection]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [HexDirection]
toDirs String
ds
    Char
's':Char
'e':String
ds -> (HexDirection
SoutheastHexDirection -> [HexDirection] -> [HexDirection]
forall a. a -> [a] -> [a]
:) ([HexDirection] -> [HexDirection])
-> Maybe [HexDirection] -> Maybe [HexDirection]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [HexDirection]
toDirs String
ds
    Char
's':Char
'w':String
ds -> (HexDirection
SouthwestHexDirection -> [HexDirection] -> [HexDirection]
forall a. a -> [a] -> [a]
:) ([HexDirection] -> [HexDirection])
-> Maybe [HexDirection] -> Maybe [HexDirection]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [HexDirection]
toDirs String
ds
    String
_ -> Maybe [HexDirection]
forall a. Maybe a
Nothing

hexOffset :: HexDirection -> Point
hexOffset :: HexDirection -> Point
hexOffset = \case
    HexDirection
West      -> Int -> Int -> Point
forall a. a -> a -> V2 a
V2 (-Int
1)  Int
0
    HexDirection
Northwest -> Int -> Int -> Point
forall a. a -> a -> V2 a
V2 (-Int
1)  Int
1
    HexDirection
Northeast -> Int -> Int -> Point
forall a. a -> a -> V2 a
V2   Int
0   Int
1
    HexDirection
East      -> Int -> Int -> Point
forall a. a -> a -> V2 a
V2   Int
1   Int
0
    HexDirection
Southeast -> Int -> Int -> Point
forall a. a -> a -> V2 a
V2   Int
1 (-Int
1)
    HexDirection
Southwest -> Int -> Int -> Point
forall a. a -> a -> V2 a
V2   Int
0 (-Int
1)

newtype Xor = Xor { Xor -> Bool
getXor :: Bool }
  deriving (forall x. Xor -> Rep Xor x)
-> (forall x. Rep Xor x -> Xor) -> Generic Xor
forall x. Rep Xor x -> Xor
forall x. Xor -> Rep Xor x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Xor x -> Xor
$cfrom :: forall x. Xor -> Rep Xor x
Generic
instance NFData Xor
instance Semigroup Xor where
    Xor Bool
x <> :: Xor -> Xor -> Xor
<> Xor Bool
y = Bool -> Xor
Xor (Bool
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
y)
instance Monoid Xor where
    mempty :: Xor
mempty = Bool -> Xor
Xor Bool
False

initialize :: [[HexDirection]] -> Set Point
initialize :: [[HexDirection]] -> Set Point
initialize = Map Point Xor -> Set Point
forall k a. Map k a -> Set k
M.keysSet (Map Point Xor -> Set Point)
-> ([[HexDirection]] -> Map Point Xor)
-> [[HexDirection]]
-> Set Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Xor -> Bool) -> Map Point Xor -> Map Point Xor
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Xor -> Bool
getXor (Map Point Xor -> Map Point Xor)
-> ([[HexDirection]] -> Map Point Xor)
-> [[HexDirection]]
-> Map Point Xor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonoidalMap Point Xor -> Map Point Xor
coerce
           (MonoidalMap Point Xor -> Map Point Xor)
-> ([[HexDirection]] -> MonoidalMap Point Xor)
-> [[HexDirection]]
-> Map Point Xor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> ([HexDirection] -> MonoidalMap Point Xor)
-> [[HexDirection]]
-> MonoidalMap Point Xor
forall a m. (NFData m, Monoid m) => Int -> (a -> m) -> [a] -> m
foldMapParChunk Int
125 [HexDirection] -> MonoidalMap Point Xor
go
  where
    go :: [HexDirection] -> MonoidalMap Point Xor
go = Map Point Xor -> MonoidalMap Point Xor
forall k a. Map k a -> MonoidalMap k a
MM.MonoidalMap (Map Point Xor -> MonoidalMap Point Xor)
-> ([HexDirection] -> Map Point Xor)
-> [HexDirection]
-> MonoidalMap Point Xor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Xor -> Map Point Xor
forall k a. k -> a -> Map k a
`M.singleton` Bool -> Xor
Xor Bool
True) (Point -> Map Point Xor)
-> ([HexDirection] -> Point) -> [HexDirection] -> Map Point Xor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Point
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Point] -> Point)
-> ([HexDirection] -> [Point]) -> [HexDirection] -> Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HexDirection -> Point) -> [HexDirection] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map HexDirection -> Point
hexOffset

day24a :: [[HexDirection]] :~> Int
day24a :: [[HexDirection]] :~> Int
day24a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe [[HexDirection]]
sParse = (String -> Maybe [HexDirection])
-> [String] -> Maybe [[HexDirection]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Maybe [HexDirection]
toDirs ([String] -> Maybe [[HexDirection]])
-> (String -> [String]) -> String -> Maybe [[HexDirection]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => [[HexDirection]] -> Maybe Int
sSolve = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ([[HexDirection]] -> Int) -> [[HexDirection]] -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Point -> Int
forall a. Set a -> Int
S.size (Set Point -> Int)
-> ([[HexDirection]] -> Set Point) -> [[HexDirection]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[HexDirection]] -> Set Point
initialize
    }

day24b :: [[HexDirection]] :~> Int
day24b :: [[HexDirection]] :~> Int
day24b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe [[HexDirection]]
sParse = (String -> Maybe [HexDirection])
-> [String] -> Maybe [[HexDirection]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Maybe [HexDirection]
toDirs ([String] -> Maybe [[HexDirection]])
-> (String -> [String]) -> String -> Maybe [[HexDirection]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    , sShow :: Int -> String
sShow  = Int -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => [[HexDirection]] -> Maybe Int
sSolve = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ([[HexDirection]] -> Int) -> [[HexDirection]] -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Point -> Int
forall a. Set a -> Int
S.size (Set Point -> Int)
-> ([[HexDirection]] -> Set Point) -> [[HexDirection]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Set Point] -> Int -> Set Point
forall a. [a] -> Int -> a
!!! Int
100) ([Set Point] -> Set Point)
-> ([[HexDirection]] -> [Set Point])
-> [[HexDirection]]
-> Set Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Point -> Set Point) -> Set Point -> [Set Point]
forall a. (a -> a) -> a -> [a]
iterate Set Point -> Set Point
step (Set Point -> [Set Point])
-> ([[HexDirection]] -> Set Point)
-> [[HexDirection]]
-> [Set Point]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[HexDirection]] -> Set Point
initialize
    }

step :: Set Point -> Set Point
step :: Set Point -> Set Point
step Set Point
ps = Set Point
stayAlive Set Point -> Set Point -> Set Point
forall a. Semigroup a => a -> a -> a
<> Set Point
comeAlive
  where
    neighborCounts :: Map Point Int
    neighborCounts :: Map Point Int
neighborCounts = MonoidalMap Point (Sum Int) -> Map Point Int
coerce (MonoidalMap Point (Sum Int) -> Map Point Int)
-> MonoidalMap Point (Sum Int) -> Map Point Int
forall a b. (a -> b) -> a -> b
$ Int
-> (Point -> MonoidalMap Point (Sum Int))
-> [Point]
-> MonoidalMap Point (Sum Int)
forall a m. (NFData m, Monoid m) => Int -> (a -> m) -> [a] -> m
foldMapParChunk Int
75
        (Map Point (Sum Int) -> MonoidalMap Point (Sum Int)
forall k a. Map k a -> MonoidalMap k a
MM.MonoidalMap (Map Point (Sum Int) -> MonoidalMap Point (Sum Int))
-> (Point -> Map Point (Sum Int))
-> Point
-> MonoidalMap Point (Sum Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Sum Int) -> Set Point -> Map Point (Sum Int)
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (Sum Int -> Point -> Sum Int
forall a b. a -> b -> a
const (Int -> Sum Int
forall a. a -> Sum a
Sum (Int
1 :: Int))) (Set Point -> Map Point (Sum Int))
-> (Point -> Set Point) -> Point -> Map Point (Sum Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Set Point
neighbors)
        (Set Point -> [Point]
forall a. Set a -> [a]
S.toList Set Point
ps)
    stayAlive :: Set Point
stayAlive = Map Point Int -> Set Point
forall k a. Map k a -> Set k
M.keysSet (Map Point Int -> Set Point)
-> (Map Point Int -> Map Point Int) -> Map Point Int -> Set Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> Map Point Int -> Map Point Int
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\Int
n -> Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Map Point Int -> Set Point) -> Map Point Int -> Set Point
forall a b. (a -> b) -> a -> b
$
                  Map Point Int
neighborCounts Map Point Int -> Set Point -> Map Point Int
forall k a. Ord k => Map k a -> Set k -> Map k a
`M.restrictKeys` Set Point
ps
    comeAlive :: Set Point
comeAlive = Map Point Int -> Set Point
forall k a. Map k a -> Set k
M.keysSet (Map Point Int -> Set Point)
-> (Map Point Int -> Map Point Int) -> Map Point Int -> Set Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> Map Point Int -> Map Point Int
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Map Point Int -> Set Point) -> Map Point Int -> Set Point
forall a b. (a -> b) -> a -> b
$
                  Map Point Int
neighborCounts Map Point Int -> Set Point -> Map Point Int
forall k a. Ord k => Map k a -> Set k -> Map k a
`M.withoutKeys`  Set Point
ps