From 415055dcc2783078570e0f4cea121521026bf1ad Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 16 Dec 2025 16:15:11 +0000 Subject: [PATCH] Allow output types to vary for different parts of same day For now this applies to Haskell only, and it may turn out to be tricky for the Rust implementation. In practice, the limitation hasn't turned out to be important, and we could even go the other way and use `Integer` everywhere. This does however at least help with debugging, as well as just being conceptually right. The `nil` and `(/\)` functions are intended to be overloaded to work for other list-like things in a later commit, and from there we will investigate using `OverloadedLists` and `RebindableSyntax` to recover standard list syntax, although there are probably limitations due to `(:)` being special. --- haskell/Main.hs | 2 +- haskell/Pre.hs | 44 +++++++++++++++++++++++++++++++++++++--- haskell/Puzzles/Day1.hs | 43 +++++++++++++++++++++------------------ haskell/Puzzles/Day10.hs | 5 +++-- haskell/Puzzles/Day2.hs | 12 ++++++----- haskell/Puzzles/Day3.hs | 10 +++++---- haskell/Puzzles/Day4.hs | 10 +++++---- haskell/Puzzles/Day5.hs | 16 ++++++++------- haskell/Puzzles/Day6.hs | 22 +++++++++++--------- haskell/Puzzles/Day7.hs | 28 +++++++++++++------------ haskell/Puzzles/Day8.hs | 18 ++++++++-------- haskell/Puzzles/Day9.hs | 32 +++++++++++++++-------------- haskell/aoc.cabal | 1 + 13 files changed, 151 insertions(+), 92 deletions(-) diff --git a/haskell/Main.hs b/haskell/Main.hs index 623e79c..092304d 100644 --- a/haskell/Main.hs +++ b/haskell/Main.hs @@ -45,7 +45,7 @@ main = in withResource (parseFile $ "../inputs/" <> t <> "/" <> pt) mempty \input -> testGroup pt $ - ( zip (map show [1 :: Int ..]) parts <&> \(n, pp) -> + ( flip mapWithIndexOutputParameterisedFunctionList parts \(show . succ -> n) pp -> goldenVsStringDiff n diffCommand ("../outputs/" <> t <> "/" <> pt <> "/" <> n) $ TL.encodeUtf8 . (<> "\n") . TL.show . pp <$> input ) diff --git a/haskell/Pre.hs b/haskell/Pre.hs index 577eaac..badace2 100644 --- a/haskell/Pre.hs +++ b/haskell/Pre.hs @@ -42,6 +42,11 @@ module Pre ( adjacentPairs, sortPair, diffCommand, + OutputParameterisedFunctionList, + mapOutputParameterisedFunctionList, + mapWithIndexOutputParameterisedFunctionList, + (/\), + nil, ) where @@ -69,7 +74,8 @@ import Data.Foldable hiding (foldl1, foldr1, maximum, maximumBy, minimum, minimu import Data.Foldable1 import Data.Function import Data.Functor -import Data.List (sortOn, transpose) +import Data.Kind (Constraint, 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) import Data.Maybe @@ -91,10 +97,10 @@ import Text.Megaparsec hiding (Pos, State, Stream, many, some) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer (decimal) -data Puzzle = forall input output. (Show output) => Puzzle +data Puzzle = forall input outputs. Puzzle { number :: Word , parser :: Bool -> Parsec Void Text input - , parts :: [input -> output] + , parts :: OutputParameterisedFunctionList Show input outputs , extraTests :: Bool -> FilePath -> IO input -> [TestTree] } @@ -125,3 +131,35 @@ sortPair (a, b) = if a <= b then (a, b) else (b, a) diffCommand :: FilePath -> FilePath -> [String] diffCommand a b = ["diff", "--color=always", a, b] + +infixr 9 /\ +(/\) :: (c output) => (input -> output) -> OutputParameterisedFunctionList c input outputs -> OutputParameterisedFunctionList c input (output : outputs) +(/\) = OutputParameterisedFunctionListCons +nil :: OutputParameterisedFunctionList c input '[] +nil = OutputParameterisedFunctionListNil + +data OutputParameterisedFunctionList (c :: Type -> Constraint) (input :: Type) (outputs :: List Type) :: Type where + OutputParameterisedFunctionListNil :: OutputParameterisedFunctionList c input '[] + OutputParameterisedFunctionListCons :: + (c output) => + (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 diff --git a/haskell/Puzzles/Day1.hs b/haskell/Puzzles/Day1.hs index de8002a..2dc3120 100644 --- a/haskell/Puzzles/Day1.hs +++ b/haskell/Puzzles/Day1.hs @@ -8,26 +8,29 @@ puzzle = { number = 1 , parser = const $ ((,) <$> ((char 'L' $> L) <|> (char 'R' $> R)) <*> (Inc <$> decimal)) `sepEndBy` newline , parts = - [ sum - . flip evalState 50 - . traverse \(d, i) -> do - modify $ snd . step i d - p' <- get - pure $ Count if p' == 0 then 1 else 0 - , sum - . flip evalState 50 - . traverse \(d, i) -> do - p <- get - c <- state $ step i d - p' <- get - pure case d of - R -> abs c - L -> - if - | p == 0 -> abs c - 1 - | p' == 0 -> abs c + 1 - | otherwise -> abs c - ] + ( sum + . ( flip evalState 50 + . traverse \(d, i) -> do + modify $ snd . step i d + p' <- get + pure $ Count if p' == 0 then 1 else 0 + ) + ) + /\ ( sum + . flip evalState 50 + . traverse \(d, i) -> do + p <- get + c <- state $ step i d + p' <- get + pure case d of + R -> abs c + L -> + if + | p == 0 -> abs c - 1 + | p' == 0 -> abs c + 1 + | otherwise -> abs c + ) + /\ nil , extraTests = mempty } diff --git a/haskell/Puzzles/Day10.hs b/haskell/Puzzles/Day10.hs index e57cf35..510dee8 100644 --- a/haskell/Puzzles/Day10.hs +++ b/haskell/Puzzles/Day10.hs @@ -23,12 +23,13 @@ puzzle = void $ single '}' pure (Lights $ IM.fromList $ zip [0 ..] lights, switches) , parts = - [ sum . map \(lights, switches) -> + ( sum . map \(lights, switches) -> maybe (error "no solution") length . firstJust (firstJust (\(s, ls) -> guard (allOff ls) $> s)) $ flip iterate [([], lights)] \ls -> concatMap (\s -> map (\(ss, l) -> (s : ss, applySwitch s l)) ls) switches - ] + ) + /\ nil , extraTests = mempty } diff --git a/haskell/Puzzles/Day2.hs b/haskell/Puzzles/Day2.hs index f8192f1..cb3e44b 100644 --- a/haskell/Puzzles/Day2.hs +++ b/haskell/Puzzles/Day2.hs @@ -10,13 +10,15 @@ puzzle = { number = 2 , parser = const $ (<* newline) $ ((,) <$> (decimal <* char '-') <*> decimal) `sepBy` (char ',') , parts = - [ sum + ( sum . concatMap (mapMaybe (\n -> guard (isRepetition2 n) $> n) . uncurry enumFromTo) - , sum - . concatMap - (mapMaybe (\n -> guard (isRepetitionN n) $> n) . uncurry enumFromTo) - ] + ) + /\ ( sum + . concatMap + (mapMaybe (\n -> guard (isRepetitionN n) $> n) . uncurry enumFromTo) + ) + /\ nil , extraTests = mempty } diff --git a/haskell/Puzzles/Day3.hs b/haskell/Puzzles/Day3.hs index 2f991a7..6abafa1 100644 --- a/haskell/Puzzles/Day3.hs +++ b/haskell/Puzzles/Day3.hs @@ -10,11 +10,13 @@ puzzle = { number = 3 , parser = const $ (Bank <$> some1 digit) `sepEndBy` newline , parts = - [ sum + ( sum . map (digitsToInt . fromMaybe (error "battery list too short") . maxBatteries 2) - , sum - . map (digitsToInt . fromMaybe (error "battery list too short") . maxBatteries 12) - ] + ) + /\ ( sum + . map (digitsToInt . fromMaybe (error "battery list too short") . maxBatteries 12) + ) + /\ nil , extraTests = mempty } diff --git a/haskell/Puzzles/Day4.hs b/haskell/Puzzles/Day4.hs index 902bb2e..25f409b 100644 --- a/haskell/Puzzles/Day4.hs +++ b/haskell/Puzzles/Day4.hs @@ -14,11 +14,13 @@ puzzle = { number = 4 , parser = const $ (some $ asum $ enumerate <&> \t -> char (inToChar t) $> t) `sepEndBy` newline , parts = - [ (\g -> countRolls g - countRolls (removeAccessibleRolls $ findAccessible g)) + ( (\g -> countRolls g - countRolls (removeAccessibleRolls $ findAccessible g)) . mkGrid - , (\g -> countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) $ generateFrames g)) - . mkGrid - ] + ) + /\ ( (\g -> countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) $ generateFrames g)) + . mkGrid + ) + /\ nil , extraTests = \isRealData path input -> [ testCase "round trip" do t <- TL.readFile if isRealData then "../inputs/real/4" else "../inputs/examples/4" diff --git a/haskell/Puzzles/Day5.hs b/haskell/Puzzles/Day5.hs index c5fd252..729b4ee 100644 --- a/haskell/Puzzles/Day5.hs +++ b/haskell/Puzzles/Day5.hs @@ -12,16 +12,18 @@ puzzle = vals <- decimal `sepEndBy` newline pure (ranges, vals) , parts = - [ \(ranges, vals) -> + ( \(ranges, vals) -> length . filter (flip any ranges . isInRange) $ vals - , sum - . map rangeLength - . foldr addInterval [] - . sortOn (Down . (.lower)) - . fst - ] + ) + /\ ( sum + . map rangeLength + . foldr addInterval [] + . sortOn (Down . (.lower)) + . fst + ) + /\ nil , extraTests = mempty } diff --git a/haskell/Puzzles/Day6.hs b/haskell/Puzzles/Day6.hs index caa69ea..7d75a52 100644 --- a/haskell/Puzzles/Day6.hs +++ b/haskell/Puzzles/Day6.hs @@ -12,18 +12,20 @@ puzzle = void newline pure (ops, ints) , parts = - [ sum + ( sum . uncurry (zipWith applyToList) . second (transpose . map (map (digitsToInt @Int . catMaybes) . filter notNull . splitOn [Nothing])) - , sum - . uncurry (zipWith applyToList) - . second - ( map catMaybes - . splitOn [Nothing] - . map (\l -> if all isNothing l then Nothing else Just $ digitsToInt @Int $ catMaybes l) - . transpose - ) - ] + ) + /\ ( sum + . uncurry (zipWith applyToList) + . second + ( map catMaybes + . splitOn [Nothing] + . map (\l -> if all isNothing l then Nothing else Just $ digitsToInt @Int $ catMaybes l) + . transpose + ) + ) + /\ nil , extraTests = mempty } diff --git a/haskell/Puzzles/Day7.hs b/haskell/Puzzles/Day7.hs index b1e44cf..d2da4aa 100644 --- a/haskell/Puzzles/Day7.hs +++ b/haskell/Puzzles/Day7.hs @@ -17,7 +17,7 @@ puzzle = let splitters = map (IS.fromList . map fst . filter snd . zip [0 ..]) rows pure (start, splitters) , parts = - [ uncurry \start -> + ( uncurry \start -> flip execState (0 :: Int) . foldlM ( \beams splitters -> @@ -27,17 +27,19 @@ puzzle = pure if hit then [x - 1, x + 1] else [x] ) (IS.singleton start) - , uncurry \start -> - sum - . map snd - . IM.toList - . foldl - ( \beams splitters -> - IM.fromListWith (+) . concat $ flip map (IM.toList beams) \(x, n) -> do - let hit = x `IS.member` splitters - zip (if hit then [x - 1, x + 1] else [x]) (repeat n) - ) - (IM.singleton start (1 :: Int)) - ] + ) + /\ ( uncurry \start -> + sum + . map snd + . IM.toList + . foldl + ( \beams splitters -> + IM.fromListWith (+) . concat $ flip map (IM.toList beams) \(x, n) -> do + let hit = x `IS.member` splitters + zip (if hit then [x - 1, x + 1] else [x]) (repeat n) + ) + (IM.singleton start (1 :: Int)) + ) + /\ nil , extraTests = mempty } diff --git a/haskell/Puzzles/Day8.hs b/haskell/Puzzles/Day8.hs index 9a5a88c..3785944 100644 --- a/haskell/Puzzles/Day8.hs +++ b/haskell/Puzzles/Day8.hs @@ -15,7 +15,7 @@ puzzle = (if isRealData then 1000 else 10,) <$> (V3 <$> decimal <* single ',' <*> decimal <* single ',' <*> decimal) `sepEndBy` newline , parts = - [ uncurry \n -> + ( uncurry \n -> product . take 3 . sortOn Down @@ -24,13 +24,15 @@ puzzle = . maybe (error "not enough boxes") snd . listIndex n . connectBoxes - , uncurry . const $ - uncurry ((*) `on` view _x) - . maybe (error "sets never unified") fst - . lastMay - . takeWhile ((> 1) . DS.sets . snd) - . connectBoxes - ] + ) + /\ ( uncurry . const $ + uncurry ((*) `on` view _x) + . maybe (error "sets never unified") fst + . lastMay + . takeWhile ((> 1) . DS.sets . snd) + . connectBoxes + ) + /\ nil , extraTests = mempty } diff --git a/haskell/Puzzles/Day9.hs b/haskell/Puzzles/Day9.hs index 5e952c9..ed21332 100644 --- a/haskell/Puzzles/Day9.hs +++ b/haskell/Puzzles/Day9.hs @@ -8,25 +8,27 @@ puzzle = { number = 9 , parser = const $ (V2 <$> decimal <* single ',' <*> decimal) `sepEndBy1` newline , parts = - [ maximum + ( maximum . fmap (squareSize . uncurry Rectangle) . fromMaybe (error "input too small") . nonEmpty . allUnorderedPairs False - , \points -> - let path = - fromMaybe (error "malformed line") - . traverse mkLine - $ (last points', head points') :| adjacentPairs points - where - points' = fromMaybe (error "empty input") $ nonEmpty points - in snd - . fromMaybe (error "no solutions") - . find (not . flip any path . lineIntersectsSquare . fst) - . sortOn (Down . snd) - . fmap ((id &&& squareSize) . uncurry Rectangle) - $ allUnorderedPairs False points - ] + ) + /\ ( \points -> + let path = + fromMaybe (error "malformed line") + . traverse mkLine + $ (last points', head points') :| adjacentPairs points + where + points' = fromMaybe (error "empty input") $ nonEmpty points + in snd + . fromMaybe (error "no solutions") + . find (not . flip any path . lineIntersectsSquare . fst) + . sortOn (Down . snd) + . fmap ((id &&& squareSize) . uncurry Rectangle) + $ allUnorderedPairs False points + ) + /\ nil , extraTests = mempty } diff --git a/haskell/aoc.cabal b/haskell/aoc.cabal index 517115c..8975c94 100644 --- a/haskell/aoc.cabal +++ b/haskell/aoc.cabal @@ -24,6 +24,7 @@ executable aoc default-extensions: BlockArguments DuplicateRecordFields + ImpredicativeTypes LexicalNegation MultiWayIf NamedFieldPuns