From f7c9297a8571537ce62ca18dfd4c6cd4181c10e9 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 31 Dec 2025 01:18:05 +0000 Subject: [PATCH] Reuse expensive computation for day 4 extra tests Ideally we'd similarly add the ability for later tests to use the results of earlier ones. But this would probably require much heavier type family usage. --- haskell/Main.hs | 9 +++--- haskell/Pre.hs | 63 +++++++++++++++++++---------------------- haskell/Puzzles/Day4.hs | 15 ++++++---- 3 files changed, 42 insertions(+), 45 deletions(-) diff --git a/haskell/Main.hs b/haskell/Main.hs index 417a40a..efedafa 100644 --- a/haskell/Main.hs +++ b/haskell/Main.hs @@ -2,7 +2,6 @@ module Main (main) where import Pre -import Data.Text qualified as T import Data.Text.IO qualified as T import Puzzles.Day1 qualified as Day1 import Puzzles.Day10 qualified as Day10 @@ -40,7 +39,7 @@ main = in describe pt do input <- liftIO $ parseFile $ "../inputs/" <> t <> "/" <> pt - sequence_ $ flip mapWithIndexOutputParameterisedFunctionList parts \(show . succ -> n) pp -> - it n . pureGoldenTextFile ("../outputs/" <> t <> "/" <> pt <> "/" <> n) $ - T.show (pp input) <> "\n" - describe "extra" $ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/") input + let (os, rs) = applyPuzzleParts input parts + for_ (zip [1 :: Int ..] rs) $ uncurry $ \(show -> n) -> + it n . pureGoldenTextFile ("../outputs/" <> t <> "/" <> pt <> "/" <> n) . (<> "\n") + describe "extra" $ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/") input os diff --git a/haskell/Pre.hs b/haskell/Pre.hs index 4414c51..3ce4dd9 100644 --- a/haskell/Pre.hs +++ b/haskell/Pre.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Pre ( @@ -40,10 +41,10 @@ module Pre ( allUnorderedPairs, adjacentPairs, sortPair, - OutputParameterisedFunctionList, - mapOutputParameterisedFunctionList, - mapWithIndexOutputParameterisedFunctionList, + PuzzleParts, + applyPuzzleParts, (/\), + (/\\), nil, ) where @@ -72,7 +73,7 @@ import Data.Foldable hiding (foldl1, foldr1, maximum, maximumBy, minimum, minimu import Data.Foldable1 import Data.Function import Data.Functor -import Data.Kind (Constraint, Type) +import Data.Kind (Type) import Data.List (List, sortOn, transpose) import Data.List.Extra (dropEnd, enumerate, firstJust, notNull, splitOn) import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, some1, tail, tails) @@ -81,6 +82,7 @@ import Data.Ord import Data.Sequence (Seq) import Data.Stream.Infinite (Stream ((:>))) import Data.Text (Text) +import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Traversable import Data.Tuple.Extra ((&&&)) @@ -96,8 +98,8 @@ import Text.Megaparsec.Char.Lexer (decimal) data Puzzle = forall input outputs. Puzzle { number :: Word , parser :: Bool -> Parsec Void Text input - , parts :: OutputParameterisedFunctionList Show input outputs - , extraTests :: Bool -> FilePath -> input -> Spec + , parts :: PuzzleParts input outputs + , extraTests :: Bool -> FilePath -> input -> HList outputs -> Spec } digit :: (Token s ~ Char, Num b, MonadParsec e s f) => f b @@ -125,37 +127,30 @@ adjacentPairs = \case sortPair :: (Ord a) => (a, a) -> (a, a) sortPair (a, b) = if a <= b then (a, b) else (b, a) +infixr 9 /\\ +(/\\) :: (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs) +(/\\) = uncurry PuzzlePartsCons infixr 9 /\ -(/\) :: (c output) => (input -> output) -> OutputParameterisedFunctionList c input outputs -> OutputParameterisedFunctionList c input (output : outputs) -(/\) = OutputParameterisedFunctionListCons -nil :: OutputParameterisedFunctionList c input '[] -nil = OutputParameterisedFunctionListNil +(/\) :: (Show output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs) +(/\) = flip PuzzlePartsCons T.show +nil :: PuzzleParts input '[] +nil = PuzzlePartsNil -data OutputParameterisedFunctionList (c :: Type -> Constraint) (input :: Type) (outputs :: List Type) :: Type where - OutputParameterisedFunctionListNil :: OutputParameterisedFunctionList c input '[] - OutputParameterisedFunctionListCons :: - (c output) => +data PuzzleParts (input :: Type) (outputs :: List Type) :: Type where + PuzzlePartsNil :: PuzzleParts input '[] + PuzzlePartsCons :: (input -> output) -> - OutputParameterisedFunctionList c input outputs -> - OutputParameterisedFunctionList c input (output ': outputs) -mapOutputParameterisedFunctionList :: - (forall output. (c output) => (input -> output) -> a) -> - OutputParameterisedFunctionList c input outputs -> - [a] -mapOutputParameterisedFunctionList f = \case - OutputParameterisedFunctionListNil -> [] - OutputParameterisedFunctionListCons x xs -> f x : mapOutputParameterisedFunctionList f xs -mapWithIndexOutputParameterisedFunctionList :: - forall c input outputs a. - (forall output. (c output) => Int -> (input -> output) -> a) -> - OutputParameterisedFunctionList c input outputs -> - [a] -mapWithIndexOutputParameterisedFunctionList f = go 0 - where - go :: Int -> OutputParameterisedFunctionList c input outputs' -> [a] - go i = \case - OutputParameterisedFunctionListNil -> [] - OutputParameterisedFunctionListCons x xs -> f i x : go (i + 1) xs + (output -> Text) -> + PuzzleParts input outputs -> + PuzzleParts input (output ': outputs) +applyPuzzleParts :: + forall input outputs. + input -> + PuzzleParts input outputs -> + (HList outputs, [Text]) +applyPuzzleParts e = \case + PuzzlePartsNil -> (HNil, []) + PuzzlePartsCons f o ps -> let r = f e in bimap (HCons r) (o r :) $ applyPuzzleParts e ps instance Semigroup (TestDefM '[] () ()) where (<>) = (>>) diff --git a/haskell/Puzzles/Day4.hs b/haskell/Puzzles/Day4.hs index f6e1e24..3d03749 100644 --- a/haskell/Puzzles/Day4.hs +++ b/haskell/Puzzles/Day4.hs @@ -16,17 +16,20 @@ puzzle = ( (\g -> countRolls g - countRolls (removeAccessibleRolls $ findAccessible g)) . mkGrid ) - /\ ( (\g -> countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) $ generateFrames g)) - . mkGrid + /\ ( (id &&& generateFrames) . mkGrid + , \(g, fs) -> + T.show $ countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) fs) ) - /\ nil - , extraTests = \isRealData path input -> do + /\\ nil + , extraTests = \isRealData path input (HCons _ (HCons (_, fmap snd -> frameStream) HNil)) -> 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 + let frames = Seq.fromList $ takeUntil noneAccessible frameStream + -- note that `nFrames = Seq.length frames - 1`, but we don't define it as such + -- since that would force the expensive evaluation during test tree construction, messing up reporting + let nFrames = if isRealData then 58 else 9 for_ [0 .. nFrames] \n -> it (show n) . pureGoldenTextFile (path <> "frames/" <> show n) $ maybe "frame list too short!" drawGrid (Seq.lookup n frames)