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

module AOC.Challenge.Day20 (
    day20a
  , day20b
  ) where

import           AOC.Common                (mapMaybeSet)
import           AOC.Common.Point          (Point, FinPoint, Dir(..), allDir, orientFin, rotPoint, orientPoint, shiftToZero, D8(..), allD8, boundingBox', parseAsciiSet)
import           AOC.Solver                ((:~>)(..))
import           Control.Lens hiding       (uncons)
import           Control.Monad             ((<=<))
import           Data.Bit                  (Bit(..))
import           Data.Char                 (isDigit)
import           Data.Distributive         (distribute)
import           Data.Finitary             (toFinite, fromFinite)
import           Data.Finite               (strengthen, unshift, packFinite)
import           Data.Foldable             (toList, find)
import           Data.Group                (invert)
import           Data.IntMap               (IntMap)
import           Data.IntMap.NonEmpty      (NEIntMap)
import           Data.IntSet               (IntSet)
import           Data.Ix                   (range)
import           Data.List                 (foldl', uncons)
import           Data.List.NonEmpty        (NonEmpty(..))
import           Data.List.Split           (splitOn)
import           Data.Map                  (Map)
import           Data.Map.NonEmpty         (NEMap)
import           Data.Maybe                (mapMaybe, listToMaybe)
import           Data.Set                  (Set)
import           Data.Set.NonEmpty         (NESet)
import           Linear                    (V2(..))
import           Text.Read                 (readMaybe)
import qualified Data.IntMap.NonEmpty      as NEIM
import qualified Data.IntMap.Strict        as IM
import qualified Data.IntSet               as IS
import qualified Data.List.NonEmpty        as NE
import qualified Data.Map                  as M
import qualified Data.Map.NonEmpty         as NEM
import qualified Data.Set                  as S
import qualified Data.Set.NonEmpty         as NES
import qualified Data.Vector.Sized         as V
import qualified Data.Vector.Unboxed.Sized as VU

type Edge = VU.Vector 10 Bit
type Core = Set (FinPoint 8)

-- | Convert a set of points into all the orientations of tiles it could
-- be, indexed by the north edge of that orientation.
toTiles :: NESet (FinPoint 10) -> ((Core, V.Vector 8 Edge), NEMap Edge D8)
toTiles :: NESet (FinPoint 10) -> ((Core, Vector 8 Edge), NEMap Edge D8)
toTiles NESet (FinPoint 10)
ps = ((Core
core, Vector 8 Edge
edges), NEMap Edge D8
edgeMap)
  where
    core :: Core
core   = [V2 (Finite 8)] -> Core
forall a. [a] -> Set a
S.fromDistinctAscList ([V2 (Finite 8)] -> Core)
-> (NESet (FinPoint 10) -> [V2 (Finite 8)])
-> NESet (FinPoint 10)
-> Core
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FinPoint 10 -> Maybe (V2 (Finite 8)))
-> [FinPoint 10] -> [V2 (Finite 8)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Finite 10 -> Maybe (Finite 8))
-> FinPoint 10 -> Maybe (V2 (Finite 8))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Finite 9 -> Maybe (Finite 8)
forall (n :: Nat). KnownNat n => Finite (n + 1) -> Maybe (Finite n)
strengthen (Finite 9 -> Maybe (Finite 8))
-> (Finite 10 -> Maybe (Finite 9)) -> Finite 10 -> Maybe (Finite 8)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Finite 10 -> Maybe (Finite 9)
forall (n :: Nat). Finite (n + 1) -> Maybe (Finite n)
unshift)) ([FinPoint 10] -> [V2 (Finite 8)])
-> (NESet (FinPoint 10) -> [FinPoint 10])
-> NESet (FinPoint 10)
-> [V2 (Finite 8)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NESet (FinPoint 10) -> [FinPoint 10]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NESet (FinPoint 10) -> Core) -> NESet (FinPoint 10) -> Core
forall a b. (a -> b) -> a -> b
$ NESet (FinPoint 10)
ps
    edges :: Vector 8 Edge
edges  = (Finite 8 -> Edge) -> Vector 8 Edge
forall (n :: Nat) a. KnownNat n => (Finite n -> a) -> Vector n a
V.generate ((Finite 8 -> Edge) -> Vector 8 Edge)
-> (Finite 8 -> Edge) -> Vector 8 Edge
forall a b. (a -> b) -> a -> b
$ \Finite 8
i ->
        let ps' :: NESet (FinPoint 10)
ps' = D8 -> FinPoint 10 -> FinPoint 10
forall (n :: Nat). KnownNat n => D8 -> FinPoint n -> FinPoint n
orientFin (D8 -> D8
forall m. Group m => m -> m
invert (Finite (Cardinality D8) -> D8
forall a. Finitary a => Finite (Cardinality a) -> a
fromFinite Finite 8
Finite (Cardinality D8)
i)) (FinPoint 10 -> FinPoint 10)
-> NESet (FinPoint 10) -> NESet (FinPoint 10)
forall b a. Ord b => (a -> b) -> NESet a -> NESet b
`NES.map` NESet (FinPoint 10)
ps
        in  (Finite 10 -> Bit) -> Edge
forall (n :: Nat) a.
(KnownNat n, Unbox a) =>
(Finite n -> a) -> Vector n a
VU.generate ((Finite 10 -> Bit) -> Edge) -> (Finite 10 -> Bit) -> Edge
forall a b. (a -> b) -> a -> b
$ \Finite 10
j -> Bool -> Bit
Bit (Bool -> Bit) -> Bool -> Bit
forall a b. (a -> b) -> a -> b
$ Finite 10 -> Finite 10 -> FinPoint 10
forall a. a -> a -> V2 a
V2 Finite 10
j Finite 10
0 FinPoint 10 -> NESet (FinPoint 10) -> Bool
forall a. Ord a => a -> NESet a -> Bool
`NES.member` NESet (FinPoint 10)
ps'
    edgeMap :: NEMap Edge D8
edgeMap = NonEmpty (Edge, D8) -> NEMap Edge D8
forall k a. Ord k => NonEmpty (k, a) -> NEMap k a
NEM.fromList (NonEmpty (Edge, D8) -> NEMap Edge D8)
-> NonEmpty (Edge, D8) -> NEMap Edge D8
forall a b. (a -> b) -> a -> b
$
      NonEmpty D8
allD8 NonEmpty D8 -> (D8 -> (Edge, D8)) -> NonEmpty (Edge, D8)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \D8
o -> (Vector 8 Edge
edges Vector 8 Edge -> Finite 8 -> Edge
forall (n :: Nat) a. Vector n a -> Finite n -> a
`V.index` D8 -> Finite (Cardinality D8)
forall a. Finitary a => a -> Finite (Cardinality a)
toFinite D8
o,D8
o)

type Placement = (Int, D8)

assembleMap
    :: NEIntMap (V.Vector 8 Edge)
    -> NEIntMap (NEMap Edge Placement)
    -> Map Point Placement
assembleMap :: NEIntMap (Vector 8 Edge)
-> NEIntMap (NEMap Edge Placement) -> Map (V2 Key) Placement
assembleMap NEIntMap (Vector 8 Edge)
tileMap NEIntMap (NEMap Edge Placement)
tiles0 =
        Map Edge (V2 Key, Dir)
-> IntSet -> Map (V2 Key) Placement -> Map (V2 Key) Placement
go (V2 Key -> D8 -> Key -> NonEmpty Dir -> Map Edge (V2 Key, Dir)
forall (f :: * -> *).
Foldable f =>
V2 Key -> D8 -> Key -> f Dir -> Map Edge (V2 Key, Dir)
toQueue V2 Key
0 D8
forall a. Monoid a => a
mempty Key
t0id NonEmpty Dir
allDir)
           (IntMap (NEMap Edge Placement) -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet IntMap (NEMap Edge Placement)
tiles1)
           (V2 Key -> Placement -> Map (V2 Key) Placement
forall k a. k -> a -> Map k a
M.singleton V2 Key
0 (Key
t0id, D8
forall a. Monoid a => a
mempty))
  where
    ((Key
_   , NEMap Edge Placement
t0Map), IntMap (NEMap Edge Placement)
tiles1)  = NEIntMap (NEMap Edge Placement)
-> ((Key, NEMap Edge Placement), IntMap (NEMap Edge Placement))
forall a. NEIntMap a -> ((Key, a), IntMap a)
NEIM.deleteFindMin NEIntMap (NEMap Edge Placement)
tiles0
    ((Edge
_, (Key
t0id, D8
_)), Map Edge Placement
_     ) = NEMap Edge Placement -> ((Edge, Placement), Map Edge Placement)
forall k a. NEMap k a -> ((k, a), Map k a)
NEM.deleteFindMin  NEMap Edge Placement
t0Map
    tileCache :: NEMap Edge [Placement]
    tileCache :: NEMap Edge [Placement]
tileCache = ([Placement] -> [Placement] -> [Placement])
-> NonEmpty (Edge, [Placement]) -> NEMap Edge [Placement]
forall k a. Ord k => (a -> a -> a) -> NonEmpty (k, a) -> NEMap k a
NEM.fromListWith [Placement] -> [Placement] -> [Placement]
forall a. [a] -> [a] -> [a]
(++)
      [ (Edge
edge, [Placement
placement])
      | (Key
_   , NEMap Edge Placement
tileEdges) <- NEIntMap (NEMap Edge Placement)
-> NonEmpty (Key, NEMap Edge Placement)
forall a. NEIntMap a -> NonEmpty (Key, a)
NEIM.toList NEIntMap (NEMap Edge Placement)
tiles0
      , (Edge
edge, Placement
placement) <- NEMap Edge Placement -> NonEmpty (Edge, Placement)
forall k a. NEMap k a -> NonEmpty (k, a)
NEM.toList NEMap Edge Placement
tileEdges
      ]
    go  :: Map Edge (Point, Dir)     -- ^ queue: edge -> place, orientation
        -> IntSet                    -- ^ leftover points
        -> Map Point Placement       -- ^ current map
        -> Map Point Placement       -- ^ sweet tail rescursion
    go :: Map Edge (V2 Key, Dir)
-> IntSet -> Map (V2 Key) Placement -> Map (V2 Key) Placement
go !Map Edge (V2 Key, Dir)
queue !IntSet
tiles !Map (V2 Key) Placement
mp = case Map Edge (V2 Key, Dir)
-> Maybe ((Edge, (V2 Key, Dir)), Map Edge (V2 Key, Dir))
forall k a. Map k a -> Maybe ((k, a), Map k a)
M.minViewWithKey Map Edge (V2 Key, Dir)
queue of
      Maybe ((Edge, (V2 Key, Dir)), Map Edge (V2 Key, Dir))
Nothing -> Map (V2 Key) Placement
mp
      Just ((Edge
edge, (V2 Key
pos, Dir
d)), Map Edge (V2 Key, Dir)
queue') ->
        case (Placement -> Bool) -> [Placement] -> Maybe Placement
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Key -> IntSet -> Bool
`IS.member` IntSet
tiles) (Key -> Bool) -> (Placement -> Key) -> Placement -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Placement -> Key
forall a b. (a, b) -> a
fst) (NEMap Edge [Placement]
tileCache NEMap Edge [Placement] -> Edge -> [Placement]
forall k a. Ord k => NEMap k a -> k -> a
NEM.! Edge
edge) of
          Maybe Placement
Nothing          -> Map Edge (V2 Key, Dir)
-> IntSet -> Map (V2 Key) Placement -> Map (V2 Key) Placement
go Map Edge (V2 Key, Dir)
queue' IntSet
tiles Map (V2 Key) Placement
mp
          Just (Key
tileId, D8
o) ->
            let o' :: D8
o'       = D8
o D8 -> D8 -> D8
forall a. Semigroup a => a -> a -> a
<> Dir -> Bool -> D8
D8 (Dir
d Dir -> Dir -> Dir
forall a. Semigroup a => a -> a -> a
<> Dir
South) Bool
True
                newQueue :: Map Edge (V2 Key, Dir)
newQueue = V2 Key -> D8 -> Key -> [Dir] -> Map Edge (V2 Key, Dir)
forall (f :: * -> *).
Foldable f =>
V2 Key -> D8 -> Key -> f Dir -> Map Edge (V2 Key, Dir)
toQueue V2 Key
pos D8
o'
                    Key
tileId
                    ((Dir -> Bool) -> NonEmpty Dir -> [Dir]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (Dir -> Dir -> Bool
forall a. Eq a => a -> a -> Bool
/= Dir
d Dir -> Dir -> Dir
forall a. Semigroup a => a -> a -> a
<> Dir
South) NonEmpty Dir
allDir)
            in  Map Edge (V2 Key, Dir)
-> IntSet -> Map (V2 Key) Placement -> Map (V2 Key) Placement
go  (Map Edge (V2 Key, Dir)
newQueue Map Edge (V2 Key, Dir)
-> Map Edge (V2 Key, Dir) -> Map Edge (V2 Key, Dir)
forall a. Semigroup a => a -> a -> a
<> Map Edge (V2 Key, Dir)
queue)
                    (Key -> IntSet -> IntSet
IS.delete Key
tileId IntSet
tiles)
                    (V2 Key
-> Placement -> Map (V2 Key) Placement -> Map (V2 Key) Placement
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert V2 Key
pos (Key
tileId, D8 -> D8
forall m. Group m => m -> m
invert D8
o') Map (V2 Key) Placement
mp)
    -- | For a given image, add the given edges into the queue
    toQueue
        :: Foldable f
        => Point            -- ^ location of corner
        -> D8               -- ^ orientation to insert
        -> Int              -- ^ tile id
        -> f Dir            -- ^ edges to insert
        -> Map Edge (Point, Dir)
    toQueue :: forall (f :: * -> *).
Foldable f =>
V2 Key -> D8 -> Key -> f Dir -> Map Edge (V2 Key, Dir)
toQueue V2 Key
p0 D8
o Key
tileId f Dir
ds = [(Edge, (V2 Key, Dir))] -> Map Edge (V2 Key, Dir)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Edge, (V2 Key, Dir))] -> Map Edge (V2 Key, Dir))
-> [(Edge, (V2 Key, Dir))] -> Map Edge (V2 Key, Dir)
forall a b. (a -> b) -> a -> b
$ f Dir -> [Dir]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f Dir
ds [Dir] -> (Dir -> (Edge, (V2 Key, Dir))) -> [(Edge, (V2 Key, Dir))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Dir
d ->
        ( (NEIntMap (Vector 8 Edge)
tileMap NEIntMap (Vector 8 Edge) -> Key -> Vector 8 Edge
forall a. NEIntMap a -> Key -> a
NEIM.! Key
tileId)
             Vector 8 Edge -> Finite 8 -> Edge
forall (n :: Nat) a. Vector n a -> Finite n -> a
`V.index` D8 -> Finite (Cardinality D8)
forall a. Finitary a => a -> Finite (Cardinality a)
toFinite (D8
o D8 -> D8 -> D8
forall a. Semigroup a => a -> a -> a
<> Dir -> Bool -> D8
D8 Dir
d Bool
False)
        , (V2 Key
p0 V2 Key -> V2 Key -> V2 Key
forall a. Num a => a -> a -> a
+ Dir -> V2 Key -> V2 Key
forall a. Num a => Dir -> V2 a -> V2 a
rotPoint Dir
d (Key -> Key -> V2 Key
forall a. a -> a -> V2 a
V2 Key
0 (-Key
1)), Dir
d)
        )

solve
    :: NEIntMap (NESet (FinPoint 10))
    -> (Map Point Placement, Set Point)
solve :: NEIntMap (NESet (FinPoint 10))
-> (Map (V2 Key) Placement, Set (V2 Key))
solve NEIntMap (NESet (FinPoint 10))
ts = (Map (V2 Key) Placement
mp, Set (V2 Key)
blitted)
  where
    info :: NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
info = NESet (FinPoint 10) -> ((Core, Vector 8 Edge), NEMap Edge D8)
toTiles (NESet (FinPoint 10) -> ((Core, Vector 8 Edge), NEMap Edge D8))
-> NEIntMap (NESet (FinPoint 10))
-> NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NEIntMap (NESet (FinPoint 10))
ts
    edgeMap :: NEIntMap (NEMap Edge Placement)
edgeMap = ((Key
  -> ((Core, Vector 8 Edge), NEMap Edge D8) -> NEMap Edge Placement)
 -> NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
 -> NEIntMap (NEMap Edge Placement))
-> NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
-> (Key
    -> ((Core, Vector 8 Edge), NEMap Edge D8) -> NEMap Edge Placement)
-> NEIntMap (NEMap Edge Placement)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Key
 -> ((Core, Vector 8 Edge), NEMap Edge D8) -> NEMap Edge Placement)
-> NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
-> NEIntMap (NEMap Edge Placement)
forall a b. (Key -> a -> b) -> NEIntMap a -> NEIntMap b
NEIM.mapWithKey NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
info \Key
i ((Core, Vector 8 Edge)
_, NEMap Edge D8
e) -> (Key
i,) (D8 -> Placement) -> NEMap Edge D8 -> NEMap Edge Placement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NEMap Edge D8
e
    edges :: NEIntMap (Vector 8 Edge)
edges   = (Core, Vector 8 Edge) -> Vector 8 Edge
forall a b. (a, b) -> b
snd ((Core, Vector 8 Edge) -> Vector 8 Edge)
-> (((Core, Vector 8 Edge), NEMap Edge D8)
    -> (Core, Vector 8 Edge))
-> ((Core, Vector 8 Edge), NEMap Edge D8)
-> Vector 8 Edge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Core, Vector 8 Edge), NEMap Edge D8) -> (Core, Vector 8 Edge)
forall a b. (a, b) -> a
fst (((Core, Vector 8 Edge), NEMap Edge D8) -> Vector 8 Edge)
-> NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
-> NEIntMap (Vector 8 Edge)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
info
    mp :: Map (V2 Key) Placement
mp      = NEIntMap (Vector 8 Edge)
-> NEIntMap (NEMap Edge Placement) -> Map (V2 Key) Placement
assembleMap NEIntMap (Vector 8 Edge)
edges NEIntMap (NEMap Edge Placement)
edgeMap
    blitted :: Set (V2 Key)
blitted = ((V2 Key -> Placement -> Set (V2 Key))
 -> Map (V2 Key) Placement -> Set (V2 Key))
-> Map (V2 Key) Placement
-> (V2 Key -> Placement -> Set (V2 Key))
-> Set (V2 Key)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (V2 Key -> Placement -> Set (V2 Key))
-> Map (V2 Key) Placement -> Set (V2 Key)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
M.foldMapWithKey Map (V2 Key) Placement
mp ((V2 Key -> Placement -> Set (V2 Key)) -> Set (V2 Key))
-> (V2 Key -> Placement -> Set (V2 Key)) -> Set (V2 Key)
forall a b. (a -> b) -> a -> b
$ \V2 Key
p (Key
tileId, D8
o) ->
      let core :: Core
core = (Core, Vector 8 Edge) -> Core
forall a b. (a, b) -> a
fst ((Core, Vector 8 Edge) -> Core)
-> (((Core, Vector 8 Edge), NEMap Edge D8)
    -> (Core, Vector 8 Edge))
-> ((Core, Vector 8 Edge), NEMap Edge D8)
-> Core
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Core, Vector 8 Edge), NEMap Edge D8) -> (Core, Vector 8 Edge)
forall a b. (a, b) -> a
fst (((Core, Vector 8 Edge), NEMap Edge D8) -> Core)
-> ((Core, Vector 8 Edge), NEMap Edge D8) -> Core
forall a b. (a -> b) -> a -> b
$ NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
info NEIntMap ((Core, Vector 8 Edge), NEMap Edge D8)
-> Key -> ((Core, Vector 8 Edge), NEMap Edge D8)
forall a. NEIntMap a -> Key -> a
NEIM.! Key
tileId
      in  (V2 (Finite 8) -> V2 Key) -> Core -> Set (V2 Key)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ((V2 Key -> V2 Key -> V2 Key
forall a. Num a => a -> a -> a
+ (V2 Key
p V2 Key -> V2 Key -> V2 Key
forall a. Num a => a -> a -> a
* V2 Key
8)) (V2 Key -> V2 Key)
-> (V2 (Finite 8) -> V2 Key) -> V2 (Finite 8) -> V2 Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Finite 8 -> Key) -> V2 (Finite 8) -> V2 Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Finite 8 -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral (V2 (Finite 8) -> V2 Key)
-> (V2 (Finite 8) -> V2 (Finite 8)) -> V2 (Finite 8) -> V2 Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D8 -> V2 (Finite 8) -> V2 (Finite 8)
forall (n :: Nat). KnownNat n => D8 -> FinPoint n -> FinPoint n
orientFin D8
o) Core
core

day20a :: IntMap (NESet (FinPoint 10)) :~> Int
day20a :: IntMap (NESet (FinPoint 10)) :~> Key
day20a = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (IntMap (NESet (FinPoint 10)))
sParse = String -> Maybe (IntMap (NESet (FinPoint 10)))
parseTiles
    , sShow :: Key -> String
sShow  = Key -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => IntMap (NESet (FinPoint 10)) -> Maybe Key
sSolve = \IntMap (NESet (FinPoint 10))
ts -> do
        (Map (V2 Key) Placement
mp, Set (V2 Key)
_) <- NEIntMap (NESet (FinPoint 10))
-> (Map (V2 Key) Placement, Set (V2 Key))
solve (NEIntMap (NESet (FinPoint 10))
 -> (Map (V2 Key) Placement, Set (V2 Key)))
-> Maybe (NEIntMap (NESet (FinPoint 10)))
-> Maybe (Map (V2 Key) Placement, Set (V2 Key))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap (NESet (FinPoint 10))
-> Maybe (NEIntMap (NESet (FinPoint 10)))
forall a. IntMap a -> Maybe (NEIntMap a)
NEIM.nonEmptyMap IntMap (NESet (FinPoint 10))
ts
        V2 (V2 Key)
bb      <- V2 (V2 Key) -> V2 (V2 Key)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
distribute (V2 (V2 Key) -> V2 (V2 Key))
-> Maybe (V2 (V2 Key)) -> Maybe (V2 (V2 Key))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [V2 Key] -> Maybe (V2 (V2 Key))
forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Applicative g, Ord a) =>
f (g a) -> Maybe (V2 (g a))
boundingBox' (Map (V2 Key) Placement -> [V2 Key]
forall k a. Map k a -> [k]
M.keys Map (V2 Key) Placement
mp)
        pure $ [Key] -> Key
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product
          [ Placement -> Key
forall a b. (a, b) -> a
fst (Placement -> Key) -> Placement -> Key
forall a b. (a -> b) -> a -> b
$ Map (V2 Key) Placement
mp Map (V2 Key) Placement -> V2 Key -> Placement
forall k a. Ord k => Map k a -> k -> a
M.! V2 Key
p
          | V2 Key
p <- (V2 Key -> [Key]) -> V2 (V2 Key) -> [V2 Key]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse V2 Key -> [Key]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList V2 (V2 Key)
bb
          ]
    }

day20b :: IntMap (NESet (FinPoint 10)) :~> Int
day20b :: IntMap (NESet (FinPoint 10)) :~> Key
day20b = MkSol :: forall a b.
(String -> Maybe a)
-> ((?dyno::DynoMap) => a -> Maybe b) -> (b -> String) -> a :~> b
MkSol
    { sParse :: String -> Maybe (IntMap (NESet (FinPoint 10)))
sParse = String -> Maybe (IntMap (NESet (FinPoint 10)))
parseTiles
    , sShow :: Key -> String
sShow  = Key -> String
forall a. Show a => a -> String
show
    , sSolve :: (?dyno::DynoMap) => IntMap (NESet (FinPoint 10)) -> Maybe Key
sSolve = \IntMap (NESet (FinPoint 10))
ts -> do
        (Map (V2 Key) Placement
_, Set (V2 Key)
blitted) <- NEIntMap (NESet (FinPoint 10))
-> (Map (V2 Key) Placement, Set (V2 Key))
solve (NEIntMap (NESet (FinPoint 10))
 -> (Map (V2 Key) Placement, Set (V2 Key)))
-> Maybe (NEIntMap (NESet (FinPoint 10)))
-> Maybe (Map (V2 Key) Placement, Set (V2 Key))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap (NESet (FinPoint 10))
-> Maybe (NEIntMap (NESet (FinPoint 10)))
forall a. IntMap a -> Maybe (NEIntMap a)
NEIM.nonEmptyMap IntMap (NESet (FinPoint 10))
ts
        [Key] -> Maybe Key
forall a. [a] -> Maybe a
listToMaybe
          [ Key
res
          | NESet (V2 Key)
drgn <- NonEmpty (NESet (V2 Key)) -> [NESet (V2 Key)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (NESet (V2 Key))
dragons
          , let res :: Key
res = Set (V2 Key) -> Key
forall a. Set a -> Key
S.size (Set (V2 Key) -> Key) -> Set (V2 Key) -> Key
forall a b. (a -> b) -> a -> b
$ Set (V2 Key) -> Set (V2 Key) -> Set (V2 Key)
pokePattern (NESet (V2 Key) -> Set (V2 Key)
forall a. NESet a -> Set a
NES.toSet NESet (V2 Key)
drgn) Set (V2 Key)
blitted
          , Key
res Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= Set (V2 Key) -> Key
forall a. Set a -> Key
S.size Set (V2 Key)
blitted
          ]
    }

pokePattern
    :: Set Point
    -> Set Point
    -> Set Point
pokePattern :: Set (V2 Key) -> Set (V2 Key) -> Set (V2 Key)
pokePattern Set (V2 Key)
pat Set (V2 Key)
ps0 = (Set (V2 Key) -> V2 Key -> Set (V2 Key))
-> Set (V2 Key) -> [V2 Key] -> Set (V2 Key)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set (V2 Key) -> V2 Key -> Set (V2 Key)
go Set (V2 Key)
ps0 ((V2 Key, V2 Key) -> [V2 Key]
forall a. Ix a => (a, a) -> [a]
range (V2 Key
mn, V2 Key
mx))
  where
    Just (V2 V2 Key
mn V2 Key
mx) = Set (V2 Key) -> Maybe (V2 (V2 Key))
forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Applicative g, Ord a) =>
f (g a) -> Maybe (V2 (g a))
boundingBox' Set (V2 Key)
ps0
    go :: Set (V2 Key) -> V2 Key -> Set (V2 Key)
go Set (V2 Key)
ps V2 Key
d
        | Set (V2 Key)
pat' Set (V2 Key) -> Set (V2 Key) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`S.isSubsetOf` Set (V2 Key)
ps = Set (V2 Key)
ps Set (V2 Key) -> Set (V2 Key) -> Set (V2 Key)
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set (V2 Key)
pat'
        | Bool
otherwise              = Set (V2 Key)
ps
      where
        pat' :: Set (V2 Key)
pat' = (V2 Key -> V2 Key) -> Set (V2 Key) -> Set (V2 Key)
forall a b. (a -> b) -> Set a -> Set b
S.mapMonotonic (V2 Key -> V2 Key -> V2 Key
forall a. Num a => a -> a -> a
+ V2 Key
d) Set (V2 Key)
pat

dragons :: NonEmpty (NESet Point)
dragons :: NonEmpty (NESet (V2 Key))
dragons = NonEmpty D8
allD8 NonEmpty D8 -> (D8 -> NESet (V2 Key)) -> NonEmpty (NESet (V2 Key))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \D8
o -> NESet (V2 Key) -> NESet (V2 Key)
forall (f :: * -> *) a.
(Applicative f, Num a, Ord a) =>
NESet (f a) -> NESet (f a)
shiftToZero (NESet (V2 Key) -> NESet (V2 Key))
-> NESet (V2 Key) -> NESet (V2 Key)
forall a b. (a -> b) -> a -> b
$ (V2 Key -> V2 Key) -> NESet (V2 Key) -> NESet (V2 Key)
forall b a. Ord b => (a -> b) -> NESet a -> NESet b
NES.map (D8 -> V2 Key -> V2 Key
forall a. Num a => D8 -> V2 a -> V2 a
orientPoint D8
o) NESet (V2 Key)
dragon

dragon :: NESet Point
Just NESet (V2 Key)
dragon = Set (V2 Key) -> Maybe (NESet (V2 Key))
forall a. Set a -> Maybe (NESet a)
NES.nonEmptySet (Set (V2 Key) -> Maybe (NESet (V2 Key)))
-> (String -> Set (V2 Key)) -> String -> Maybe (NESet (V2 Key))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Set (V2 Key)
parseAsciiSet (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') (String -> Maybe (NESet (V2 Key)))
-> String -> Maybe (NESet (V2 Key))
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
  [ String
"                  # "
  , String
"#    ##    ##    ###"
  , String
" #  #  #  #  #  #   "
  ]

parseTiles :: String -> Maybe (IntMap (NESet (FinPoint 10)))
parseTiles :: String -> Maybe (IntMap (NESet (FinPoint 10)))
parseTiles = ([(Key, NESet (FinPoint 10))] -> IntMap (NESet (FinPoint 10)))
-> Maybe [(Key, NESet (FinPoint 10))]
-> Maybe (IntMap (NESet (FinPoint 10)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Key, NESet (FinPoint 10))] -> IntMap (NESet (FinPoint 10))
forall a. [(Key, a)] -> IntMap a
IM.fromList
           (Maybe [(Key, NESet (FinPoint 10))]
 -> Maybe (IntMap (NESet (FinPoint 10))))
-> (String -> Maybe [(Key, NESet (FinPoint 10))])
-> String
-> Maybe (IntMap (NESet (FinPoint 10)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe (Key, NESet (FinPoint 10)))
-> [String] -> Maybe [(Key, NESet (FinPoint 10))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((String -> [String] -> Maybe (Key, NESet (FinPoint 10)))
-> (String, [String]) -> Maybe (Key, NESet (FinPoint 10))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> [String] -> Maybe (Key, NESet (FinPoint 10))
forall {a} {n :: Nat}.
(Read a, KnownNat n) =>
String -> [String] -> Maybe (a, NESet (V2 (Finite n)))
go ((String, [String]) -> Maybe (Key, NESet (FinPoint 10)))
-> (String -> Maybe (String, [String]))
-> String
-> Maybe (Key, NESet (FinPoint 10))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [String] -> Maybe (String, [String])
forall a. [a] -> Maybe (a, [a])
uncons ([String] -> Maybe (String, [String]))
-> (String -> [String]) -> String -> Maybe (String, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines)
           ([String] -> Maybe [(Key, NESet (FinPoint 10))])
-> (String -> [String])
-> String
-> Maybe [(Key, NESet (FinPoint 10))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"\n\n"
  where
    go :: String -> [String] -> Maybe (a, NESet (V2 (Finite n)))
go String
tname [String]
tiles =
      (,) (a -> NESet (V2 (Finite n)) -> (a, NESet (V2 (Finite n))))
-> Maybe a
-> Maybe (NESet (V2 (Finite n)) -> (a, NESet (V2 (Finite n))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit String
tname)
          Maybe (NESet (V2 (Finite n)) -> (a, NESet (V2 (Finite n))))
-> Maybe (NESet (V2 (Finite n)))
-> Maybe (a, NESet (V2 (Finite n)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set (V2 (Finite n)) -> Maybe (NESet (V2 (Finite n)))
forall a. Set a -> Maybe (NESet a)
NES.nonEmptySet ((V2 Key -> Maybe (V2 (Finite n)))
-> Set (V2 Key) -> Set (V2 (Finite n))
forall b a. Ord b => (a -> Maybe b) -> Set a -> Set b
mapMaybeSet ((Key -> Maybe (Finite n)) -> V2 Key -> Maybe (V2 (Finite n))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Integer -> Maybe (Finite n)
forall (n :: Nat). KnownNat n => Integer -> Maybe (Finite n)
packFinite (Integer -> Maybe (Finite n))
-> (Key -> Integer) -> Key -> Maybe (Finite n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral)) Set (V2 Key)
tileset)
      where
        tileset :: Set (V2 Key)
tileset = (Char -> Bool) -> String -> Set (V2 Key)
parseAsciiSet (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') ([String] -> String
unlines [String]
tiles)