450d7e5240
There are some drawbacks: - No properly lazy golden tests. This would in principle be nice when e.g. using `pretty-simple`. - Because tests can be created dynamically, they can't be listed up front without running them. This presumably makes filtering slightly more annoying to use in practice. - Terminal output is less compact than tasty, both horizontally and vertically. There appears to be no way to change this. - We end up defining an orphan `Monoid (TestDefM '[] () ())` instance, to avoid changing much downstream code. Note though that this is not strictly necessary, and could potentially be contributed upstream. - There's a warning about threads in GHCI which we can't seem to disable. - The license forbids use in commercial projects without sponsoring. Thankfully that doesn't apply here. Anyway, it's generally very impressive. It simplifies a few things for us, and will particularly help when we come to want to specify dependencies between tests.
109 lines
3.8 KiB
Haskell
109 lines
3.8 KiB
Haskell
module Puzzles.Day4 (puzzle) where
|
|
|
|
import Pre
|
|
|
|
import Data.Sequence qualified as Seq
|
|
import Data.Stream.Infinite qualified as S
|
|
import Data.Text qualified as T
|
|
import Data.Text.IO qualified as T
|
|
|
|
puzzle :: Puzzle
|
|
puzzle =
|
|
Puzzle
|
|
{ number = 4
|
|
, parser = const $ (some $ asum $ enumerate <&> \t -> char (inToChar t) $> t) `sepEndBy` newline
|
|
, parts =
|
|
( (\g -> countRolls g - countRolls (removeAccessibleRolls $ findAccessible g))
|
|
. mkGrid
|
|
)
|
|
/\ ( (\g -> countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) $ generateFrames g))
|
|
. mkGrid
|
|
)
|
|
/\ nil
|
|
, extraTests = \isRealData path input -> do
|
|
it "round trip" do
|
|
t <- T.readFile if isRealData then "../inputs/real/4" else "../inputs/examples/4"
|
|
drawGrid (mkGrid input <&> \case InEmpty -> OutEmpty; InRoll -> OutRoll) `shouldBe` t
|
|
describe "frames" do
|
|
let frames = Seq.fromList . takeUntil noneAccessible . fmap snd . generateFrames $ mkGrid input
|
|
let nFrames = Seq.length frames - 1
|
|
for_ [0 .. nFrames] \n ->
|
|
it (show n) . pureGoldenTextFile (path <> "frames/" <> show n) $
|
|
maybe "frame list too short!" drawGrid (Seq.lookup n frames)
|
|
it "end" do
|
|
Just g <- pure $ Seq.lookup nFrames frames
|
|
(g `shouldSatisfyNamed` "accessible tile found") noneAccessible
|
|
}
|
|
|
|
newtype Grid a = Grid (Seq (Seq (V2 Int, a)))
|
|
deriving (Functor, Show)
|
|
|
|
data InTile
|
|
= InEmpty
|
|
| InRoll
|
|
deriving (Eq, Ord, Show, Enum, Bounded)
|
|
inToChar :: InTile -> Char
|
|
inToChar = \case
|
|
InEmpty -> '.'
|
|
InRoll -> '@'
|
|
|
|
data OutTile
|
|
= OutEmpty
|
|
| OutRoll
|
|
| OutAccessible
|
|
deriving (Eq, Ord, Show, Enum, Bounded)
|
|
outToChar :: OutTile -> Char
|
|
outToChar = \case
|
|
OutEmpty -> inToChar InEmpty
|
|
OutRoll -> inToChar InRoll
|
|
OutAccessible -> 'x'
|
|
|
|
drawGrid :: Grid OutTile -> T.Text
|
|
drawGrid (Grid g) = T.unlines . toList . fmap (T.pack . toList . fmap outToChar) $ snd <<$>> g
|
|
|
|
mkGrid :: [[a]] -> Grid a
|
|
mkGrid = Grid . Seq.fromList . map Seq.fromList . zipWith (map . first . V2) [0 ..] . map (zip [0 ..])
|
|
|
|
findAccessible :: Grid InTile -> Grid OutTile
|
|
findAccessible (Grid inGrid) =
|
|
Grid $
|
|
inGrid <<&>> \(v, t) -> (v,) case t of
|
|
InEmpty -> OutEmpty
|
|
InRoll ->
|
|
if length (filter ((== Just InRoll) . fmap snd) neighbours) < 4
|
|
then OutAccessible
|
|
else OutRoll
|
|
where
|
|
neighbours = do
|
|
x <- [-1 .. 1]
|
|
y <- [-1 .. 1]
|
|
guard $ not (x == 0 && y == 0)
|
|
let V2 x' y' = v + V2 x y
|
|
pure $ Seq.lookup x' inGrid >>= Seq.lookup y'
|
|
|
|
removeAccessibleRolls :: Grid OutTile -> Grid InTile
|
|
removeAccessibleRolls = fmap \case
|
|
OutEmpty -> InEmpty
|
|
OutRoll -> InRoll
|
|
OutAccessible -> InEmpty
|
|
|
|
generateFrames :: Grid InTile -> Stream (Grid InTile, Grid OutTile)
|
|
generateFrames = unfoldMutual findAccessible removeAccessibleRolls
|
|
|
|
noneAccessible :: Grid OutTile -> Bool
|
|
noneAccessible (Grid g) = not $ any (elem OutAccessible . fmap snd) g
|
|
|
|
countRolls :: Grid InTile -> Int
|
|
countRolls (Grid g) = length $ concatMap (filter (== InRoll) . toList . fmap snd) g
|
|
|
|
(<<$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)
|
|
(<<$>>) = fmap . fmap
|
|
(<<&>>) :: (Functor f1, Functor f2) => f1 (f2 a) -> (a -> b) -> f1 (f2 b)
|
|
(<<&>>) = flip (<<$>>)
|
|
|
|
takeUntil :: (Foldable t) => (a -> Bool) -> t a -> [a]
|
|
takeUntil p = foldr (\x xs -> x : if p x then [] else xs) []
|
|
|
|
unfoldMutual :: (a -> b) -> (b -> a) -> a -> Stream (a, b)
|
|
unfoldMutual f g a = let b = f a in (a, b) :> unfoldMutual f g (g b)
|