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.
This commit is contained in:
George Thomas
parent
450d7e5240
commit
f7c9297a85
@ -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
|
||||
|
||||
@ -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
|
||||
(<>) = (>>)
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user