patrickaldis/garnet
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Allow output types to vary for different parts of same day

Browse Source 
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.
This commit is contained in:
George Thomas 2025-12-16 16:15:11 +00:00
parent 6ca7b4eac8
commit 415055dcc2
13 changed files with 151 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
haskell/Main.hs
View File

@ -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
)

44
haskell/Pre.hs
View File

@ -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

43
haskell/Puzzles/Day1.hs
View File

@ -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
}

5
haskell/Puzzles/Day10.hs
View File

@ -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
}

12
haskell/Puzzles/Day2.hs
View File

@ -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
}

10
haskell/Puzzles/Day3.hs
View File

@ -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
}

10
haskell/Puzzles/Day4.hs
View File

@ -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"

16
haskell/Puzzles/Day5.hs
View File

@ -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
}

22
haskell/Puzzles/Day6.hs
View File

@ -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
}

28
haskell/Puzzles/Day7.hs
View File

@ -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
}

18
haskell/Puzzles/Day8.hs
View File

@ -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
}

32
haskell/Puzzles/Day9.hs
View File

@ -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
}

1
haskell/aoc.cabal
View File

@ -24,6 +24,7 @@ executable aoc
default-extensions:
BlockArguments
DuplicateRecordFields
ImpredicativeTypes
LexicalNegation
MultiWayIf
NamedFieldPuns