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)
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)
-> IntSet
-> Map Point Placement
-> Map Point Placement
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)
toQueue
:: Foldable f
=> Point
-> D8
-> Int
-> f Dir
-> 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)