oppi.li
advent of code solutions
aoc.oppi.li
haskell
aoc
more work on the book, 2025
Signed-off-by: oppiliappan <me@oppi.li>
+463
-47
+1
-1
book/build.sh
+1
-1
book/build.sh
+35
-16
book/filter.lua
+35
-16
book/filter.lua
···
1
1
function is_haskell(block)
2
-
return block and block.t == "CodeBlock" and block.classes[1] == "haskell"
2
+
if not block or block.t ~= "CodeBlock" then
3
+
return false
4
+
end
5
+
for _, class in ipairs(block.classes) do
6
+
if class == "haskell" or class == "haskell-top" or class:match("^haskell") then
7
+
return true
8
+
end
9
+
end
10
+
return false
3
11
end
4
12
5
13
function Pandoc(doc)
6
14
local new_blocks = {}
7
15
local i = 1
8
-
16
+
9
17
while i <= #doc.blocks do
10
18
local current = doc.blocks[i]
11
-
local next_block = doc.blocks[i + 1]
12
-
13
-
if current.t == "Para" and is_haskell(next_block) then
14
-
local code_div = pandoc.Div({next_block}, {class = "code"})
15
-
local row = pandoc.Div({current, code_div}, {class = "row"})
16
-
17
-
table.insert(new_blocks, row)
18
-
i = i + 2 -- skip the next block
19
-
elseif current.t == "Para" and not is_haskell(next_block) then
20
-
local empty_div = pandoc.Div({}, {class = "code"})
21
-
local row = pandoc.Div({current, empty_div}, {class = "row"})
22
-
table.insert(new_blocks, row)
23
-
i = i + 1
19
+
20
+
if current.t == "Para" then
21
+
-- Collect all consecutive Haskell code blocks following this paragraph
22
+
local code_blocks = {}
23
+
local j = i + 1
24
+
while j <= #doc.blocks and is_haskell(doc.blocks[j]) do
25
+
table.insert(code_blocks, doc.blocks[j])
26
+
j = j + 1
27
+
end
28
+
29
+
if #code_blocks > 0 then
30
+
-- Create a code div containing all the code blocks
31
+
local code_div = pandoc.Div(code_blocks, {class = "code"})
32
+
local row = pandoc.Div({current, code_div}, {class = "row"})
33
+
table.insert(new_blocks, row)
34
+
i = j -- skip past all the code blocks we just processed
35
+
else
36
+
-- No code blocks following, create empty code div
37
+
local empty_div = pandoc.Div({}, {class = "code"})
38
+
local row = pandoc.Div({current, empty_div}, {class = "row"})
39
+
table.insert(new_blocks, row)
40
+
i = i + 1
41
+
end
24
42
else
43
+
-- Not a paragraph, just pass through
25
44
table.insert(new_blocks, current)
26
45
i = i + 1
27
46
end
28
47
end
29
-
48
+
30
49
return pandoc.Pandoc(new_blocks, doc.meta)
31
50
end
+26
-26
src/2016/01.lhs
+26
-26
src/2016/01.lhs
···
1
-
= 2016
1
+
# 2016
2
2
3
-
== Day 1
3
+
## Day 1
4
4
5
-
=== Part 1
5
+
### Part 1
6
6
7
7
We start with some imports obviously:
8
8
9
-
\begin{code}
9
+
```haskell
10
10
{-# LANGUAGE LambdaCase #-}
11
11
import qualified Data.Set as S
12
-
\end{code}
12
+
```
13
13
14
14
Once we have those in place, begin by parsing the input; the input is of the form:
15
15
···
19
19
20
20
Where `C` is a letter, `NN` form a natural number. First we normalize the input by appending a "," to the end. We then use `words` to split on spaces, now each element is of the form `CNN,`. Using `init` we can drop the trailing comma, and finally, call `extract` to parse `C` and `NN` separately.
21
21
22
-
\begin{code}
22
+
```haskell
23
23
parse :: String -> [(Char, Int)]
24
24
parse input = map (extract . init) $ words normalized
25
25
where normalized = input ++ ","
26
26
extract (d:rest) = (d, read rest)
27
-
\end{code}
27
+
```
28
28
29
29
Next, we define a list of axes, the +x axis is defined as (1, 0) and so on:
30
30
31
-
\begin{code}
31
+
```haskell
32
32
axis :: [(Int, Int)]
33
33
axis = [(0, 1), (1, 0), (0, -1), (-1, 0)]
34
-
\end{code}
34
+
```
35
35
36
36
And finally, the first bit of interesting computation; given a direction, we apply a move to the right or left. Each face is represented by an integer (0 being North, 1 being East etc.),
37
37
Turning right adds one; and turing left subtracts one, the modulo makes the computation cyclic:
38
38
39
-
\begin{code}
39
+
```haskell
40
40
dir :: Int -> Char -> Int
41
41
dir face = \case
42
42
'R' -> (face + 1) `mod` 4
43
43
'L' -> (face - 1) `mod` 4
44
-
\end{code}
44
+
```
45
45
46
46
Now, given a position, and a movement; we can compute the new position like so; first compute the new face to look at by turning,
47
47
next, determine the axis that we would move along. If we are moving along the +x axis, (dx, dy) is set to (1, 0). Thus the new position is given by movind `l * dx` along the x-axis, and `l * dy` along the y-axis (which would be zero if `dy` is zero).
48
48
49
-
\begin{code}
49
+
```haskell
50
50
move (face, x, y) (d, l) = (nf, x + l * dx, y + l * dy)
51
51
where nf = dir face d
52
52
(dx, dy) = axis !! nf
53
-
\end{code}
53
+
```
54
54
55
55
The problem requires us to compute the Manhattan distance of the destination location; which is given by:
56
56
57
-
\begin{code}
57
+
```haskell
58
58
mag (_, x, y) = abs x + abs y
59
-
\end{code}
59
+
```
60
60
61
61
Thus, the solution to part 1 is given by `p1`; apply the `move` function starting at (0, 0, 0); and applying all the moves in the input. Finally compute the Manhattan distance of the destination from the origin.
62
62
63
-
\begin{code}
63
+
```haskell
64
64
p1 :: [(Char, Int)] -> Int
65
65
p1 n = mag $ foldl' move (0, 0, 0) n
66
-
\end{code}
66
+
```
67
67
68
-
=== Part 2
68
+
### Part 2
69
69
70
70
In the second part, we are tasked with finding the first point that we cross over. This requires us to first enumerate all the points we have visited by making each move.
71
71
72
72
This `range` function is a helper to enumerate all points between two integers:
73
73
74
-
\begin{code}
74
+
```haskell
75
75
range :: Int -> Int -> [Int]
76
76
range a b
77
77
| a <= b = [a .. b]
78
78
| otherwise = [a, a - 1 .. b]
79
-
\end{code}
79
+
```
80
80
81
81
The first point we cross over will then be the first duplicate element in the list of points we visit, `firstDup` uses `Data.Set` to determine the first duplicate point from a sequence:
82
82
83
-
\begin{code}
83
+
```haskell
84
84
firstDup :: Ord a => [a] -> a
85
85
firstDup xs = go S.empty xs
86
86
where
87
87
go seen (x : xs)
88
88
| x `S.member` seen = x
89
89
| otherwise = go (S.insert x seen) xs
90
-
\end{code}
90
+
```
91
91
92
92
Thus, the solution to the second part is given by `p2`. First, `pts` is calculated as all the final locations after each move. We then run through these pairwise and calculate all the points in between. Finally, we determine the magnitude of the first point we visit twice.
93
93
94
-
\begin{code}
94
+
```haskell
95
95
p2 :: [(Char, Int)] -> Int
96
96
p2 n = mag $ firstDup coords
97
97
where
···
104
104
y <- range y1 y2,
105
105
(x, y) /= (x1, y1)
106
106
]
107
-
\end{code}
107
+
```
108
108
109
109
Finally the `main` function is defined like so:
110
110
111
-
\begin{code}
111
+
```haskell
112
112
input = "R8, R4, R4, R8"
113
113
main = do
114
114
let f = parse input
115
115
print $ p1 f
116
116
print $ p2 f
117
-
\end{code}
117
+
```
+4
-4
src/2016/02.lhs
+4
-4
src/2016/02.lhs
+70
src/2025/02.lhs
+70
src/2025/02.lhs
···
1
+
# 2025
2
+
3
+
## Day 2
4
+
5
+
Starting with the parse step, the input is of the form `11-22,15-17,...`.
6
+
So we first split on commas,
7
+
for each item in the list (of the form `"11-22"`), we can split again on `"-"`,
8
+
and finally, use `read` to parse them to integers.
9
+
10
+
```haskell
11
+
import Data.List.Split (splitOn)
12
+
13
+
parse :: String -> [[Int]]
14
+
parse = map (map read . splitOn "-") . splitOn ","
15
+
```
16
+
17
+
We can move onto the problem itself now.
18
+
19
+
### Part 1
20
+
21
+
The check for invalidity for an integer in Part 1 requires us to simply split the string in half and ensure that the two halves are identical, this is easily produced using `splitAt`:
22
+
23
+
```haskell
24
+
invalid :: Int -> Bool
25
+
invalid n = l == r
26
+
where
27
+
s = show n
28
+
(l, r) = splitAt (length s `div` 2) s
29
+
```
30
+
31
+
With that in place, we can define the solution to part 1. `range` is a utility to iterate through the pair, we then filter out `invalid` items and add everything up:
32
+
33
+
```haskell
34
+
range [a, b] = [a .. b]
35
+
36
+
p1 i = sum $ concatMap (filter invalid . range) i
37
+
```
38
+
39
+
### Part 2
40
+
41
+
This part requires a slight modification to the invalidity check. We now need to check for any number of repeating substrings, so "123123123" is invalid because it is formed from `"123" + "123" + "123"`.
42
+
The methodology here is slightly involved, first we get all prefixes of the input using `inits`.
43
+
We can filter out the initial empty prefix with `tail`. Upon repeated cyling the prefixes, if we are able to form the original string, then the string can be considered invalid!
44
+
45
+
```haskell-top
46
+
import Data.List (inits, isPrefixOf)
47
+
```
48
+
49
+
```haskell
50
+
invalid2 :: Int -> Bool
51
+
invalid2 n = any ((s `isPrefixOf`) . cycle) $ tail $ inits l
52
+
where
53
+
s = show n
54
+
(l, _) = splitAt (length s `div` 2) s
55
+
```
56
+
57
+
Then, part 2 is defined like so:
58
+
59
+
```haskell
60
+
p2 i = sum $ concatMap (filter invalid2 . range) i
61
+
```
62
+
63
+
Finally, a main function to wrap it all up:
64
+
65
+
```haskell
66
+
main = do
67
+
n <- parse <$> getContents
68
+
print $ p1 n
69
+
print $ p2 n
70
+
```
+26
src/2025/03.hs
+26
src/2025/03.hs
···
1
+
import Data.Char (digitToInt)
2
+
import Data.List (tails)
3
+
4
+
joltage _ [] = []
5
+
joltage 0 _ = []
6
+
joltage need bank
7
+
| length bank == need = bank
8
+
| otherwise =
9
+
let size = length bank - need + 1
10
+
lead = maximum $ take size bank
11
+
after = tail $ dropWhile (/= lead) bank
12
+
in lead : joltage (need - 1) after
13
+
14
+
toInt = foldl ((+) . (* 10)) 0
15
+
16
+
p1 n = sum $ map (toInt . joltage 2) n
17
+
18
+
p2 n = sum $ map (toInt . joltage 12) n
19
+
20
+
parse :: String -> [[Int]]
21
+
parse = map (map digitToInt) . lines
22
+
23
+
main = do
24
+
n <- parse <$> getContents
25
+
print $ p1 n
26
+
print $ p2 n
+81
src/2025/04.lhs
+81
src/2025/04.lhs
···
1
+
## Day 4
2
+
3
+
As always, we start by parsing the input into something more manageable:
4
+
5
+
```haskell
6
+
import Data.Set
7
+
8
+
parse :: String -> Set (Int, Int)
9
+
parse = grid . lines
10
+
```
11
+
12
+
`grid` is a helper function that produces a `Set` of points. An interesting note about this problem is that the points that do *not* contain rolls (points that are not `@`) are inconsequential to the problem itself, and we can fully ignore them. Using a list comprehension, we first enumerate each line of the input, and then enumerate each character of that line, and only preserve the characters that are `@`:
13
+
14
+
```haskell
15
+
grid l =
16
+
fromList
17
+
[ (x, y)
18
+
| (r, x) <- zip l [0 ..],
19
+
(c, y) <- zip r [0 ..],
20
+
c == '@'
21
+
]
22
+
```
23
+
24
+
Now that are input has been munged, lets move onto the problem itself.
25
+
26
+
### Part 1
27
+
28
+
This part requires us to first calculate all points adjacent to a roll, if there are more than 4 rolls at these adjacent locations, disqualify the roll, as it cannot be lifted by a forklift. First, lets generate a list comprehension that produces the points adjacent to a given point. We ignore the offset (0, 0) because that is the point itself:
29
+
30
+
```haskell
31
+
adjs (x, y) =
32
+
[ (x + x', y + y')
33
+
| x' <- [-1, 0, 1],
34
+
y' <- [-1, 0, 1],
35
+
(x', y') /= (0, 0)
36
+
]
37
+
```
38
+
39
+
Then, a roll is liftable by a forklift if the adjacent points only have upto 4 rolls. We can use `Set.filter` to traverse the entire grid. Our filter predicate first collects adjacent points, filters out ones that are within the boundaries of the grid, and counts them. Remember that our grid does not contain points that are *not* rolls anyway!
40
+
41
+
```haskell
42
+
liftable g = Data.Set.filter pred g
43
+
where
44
+
pred =
45
+
(< 4)
46
+
. length
47
+
. Prelude.filter (`member` g)
48
+
. adjs
49
+
```
50
+
51
+
Thus, the solution to part one is given as:
52
+
53
+
```haskell
54
+
p1 = size . liftable
55
+
```
56
+
57
+
### Part 2
58
+
59
+
This part is very similar to the previous part. We need to sequentially remove liftable rolls until we can lift no more. A simple recursive function can do the trick. The base case: if no more rolls can be lifted from the grid, return the number of rolls lifted thus far. The recursive case: accumulate the rolls that are liftable in the current state of the grid, and recurse into the grid where the rolls are removed! The removal is calculated simply using `Set.\\`, which performs set difference:
60
+
61
+
```haskell
62
+
go s g
63
+
| size lifted == 0 = s
64
+
| otherwise = go (s + size lifted) (g \\ lifted)
65
+
where
66
+
lifted = liftable g
67
+
```
68
+
69
+
Thus, the solution for the second part is given like so:
70
+
71
+
```haskell
72
+
p2 = go 0
73
+
```
74
+
Finally, a main function to wrap it all up:
75
+
76
+
```haskell
77
+
main = do
78
+
n <- parse <$> getContents
79
+
print $ p1 n
80
+
print $ p2 n
81
+
```
+212
unlit/unlit.hs
+212
unlit/unlit.hs
···
1
+
-- Copyright (c) 2012-2025 Simon Hengel <sol@typeful.net>
2
+
-- Copyright (c) 2025 Akshay Oppiliappan <me@oppi.li>
3
+
--
4
+
-- Permission is hereby granted, free of charge, to any person obtaining a copy
5
+
-- of this software and associated documentation files (the "Software"), to deal
6
+
-- in the Software without restriction, including without limitation the rights
7
+
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
8
+
-- copies of the Software, and to permit persons to whom the Software is
9
+
-- furnished to do so, subject to the following conditions:
10
+
--
11
+
-- The above copyright notice and this permission notice shall be included in
12
+
-- all copies or substantial portions of the Software.
13
+
--
14
+
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15
+
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16
+
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
17
+
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18
+
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
19
+
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
20
+
-- THE SOFTWARE.
21
+
{-# LANGUAGE CPP #-}
22
+
{-# LANGUAGE DerivingStrategies #-}
23
+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
24
+
{-# LANGUAGE LambdaCase #-}
25
+
{-# LANGUAGE OverloadedStrings #-}
26
+
{-# LANGUAGE ViewPatterns #-}
27
+
28
+
module Main where
29
+
30
+
import Control.Arrow
31
+
import Data.Char
32
+
import Data.List (isPrefixOf, sortOn)
33
+
import Data.Maybe
34
+
import Data.String
35
+
import Debug.Trace
36
+
import System.Environment
37
+
import System.Exit
38
+
import System.IO
39
+
import Text.Read
40
+
41
+
fenceChars :: [Char]
42
+
fenceChars = ['`', '~']
43
+
44
+
fences :: [String]
45
+
fences = map (replicate 3) fenceChars
46
+
47
+
main = do
48
+
args <- getArgs
49
+
run (trace (show args) args)
50
+
51
+
-- | Program entry point.
52
+
run :: [String] -> IO ()
53
+
run args =
54
+
-- GHC calls unlit like so:
55
+
--
56
+
-- > unlit [args] -h label Foo.lhs /tmp/somefile
57
+
--
58
+
-- [args] are custom arguments provided with -optL
59
+
--
60
+
-- The label is meant to be used in line pragmas, like so:
61
+
--
62
+
-- #line 1 "label"
63
+
--
64
+
case break (== "-h") args of
65
+
(mkSelector -> selector, "-h" : files) -> case files of
66
+
[src, cur, dst] -> do
67
+
readFileUtf8 cur >>= writeFileUtf8 dst . unlit src selector
68
+
[src] -> do
69
+
readFileUtf8 src >>= writeUtf8 stdout . unlit src selector
70
+
_ -> usage
71
+
_ -> usage
72
+
where
73
+
usage :: IO ()
74
+
usage = do
75
+
name <- getProgName
76
+
hPutStrLn stderr ("usage: " ++ name ++ " [selector] -h SRC CUR DST")
77
+
exitFailure
78
+
79
+
mkSelector :: [String] -> Selector
80
+
mkSelector = fromMaybe ("haskell" :&: Not "ignore") . parseSelector . unwords
81
+
82
+
readFileUtf8 :: FilePath -> IO String
83
+
readFileUtf8 name = openFile name ReadMode >>= \handle -> hSetEncoding handle utf8 >> hGetContents handle
84
+
85
+
writeFileUtf8 :: FilePath -> String -> IO ()
86
+
writeFileUtf8 name str = withFile name WriteMode $ \handle -> writeUtf8 handle str
87
+
88
+
writeUtf8 :: Handle -> String -> IO ()
89
+
writeUtf8 handle str = hSetEncoding handle utf8 >> hPutStr handle str
90
+
91
+
unlit :: FilePath -> Selector -> String -> String
92
+
unlit src selector = unlines . concatMap formatCodeBlock . sortCodeBlocks . parse
93
+
where
94
+
formatCodeBlock :: CodeBlock -> [String]
95
+
formatCodeBlock cb = ("#line " ++ show (codeBlockStartLine cb) ++ " " ++ show src) : codeBlockContent cb
96
+
97
+
sortCodeBlocks :: [CodeBlock] -> [CodeBlock]
98
+
sortCodeBlocks = map fst . sortOn snd . addSortKey
99
+
where
100
+
addSortKey :: [CodeBlock] -> [(CodeBlock, (ReorderingKey, DeclarationOrder))]
101
+
addSortKey = zipWith ((id &&&) . sortKey) [0 ..]
102
+
103
+
sortKey :: a -> CodeBlock -> (ReorderingKey, a)
104
+
sortKey n code = (reorderingKey code, n)
105
+
106
+
toPredicate :: Selector -> [String] -> Bool
107
+
toPredicate = go
108
+
where
109
+
go s = case s of
110
+
Class c -> elem c
111
+
Not p -> not . go p
112
+
a :&: b -> (&&) <$> go a <*> go b
113
+
a :|: b -> (||) <$> go a <*> go b
114
+
115
+
newtype DeclarationOrder = DeclarationOrder Int
116
+
deriving newtype (Eq, Ord, Enum, Num)
117
+
118
+
newtype ReorderingKey = ReorderingKey Int
119
+
deriving newtype (Eq, Show, Read, Ord, Bounded, Num)
120
+
121
+
reorderingKey :: CodeBlock -> ReorderingKey
122
+
reorderingKey = parseReorderingKey . codeBlockClasses
123
+
124
+
parseReorderingKey :: [String] -> ReorderingKey
125
+
parseReorderingKey = go
126
+
where
127
+
go :: [String] -> ReorderingKey
128
+
go = \case
129
+
[] -> 0
130
+
"top" : _ -> minBound
131
+
"haskell-top" : _ -> minBound
132
+
('t' : 'o' : 'p' : ':' : (readMaybe -> Just n)) : _ -> minBound + n
133
+
('h' : 'a' : 's' : 'k' : 'e' : 'l' : 'l' : '-' : 't' : 'o' : 'p' : ':' : (readMaybe -> Just n)) : _ -> minBound + n
134
+
_ : classes -> go classes
135
+
136
+
infixr 3 :&:
137
+
138
+
infixr 2 :|:
139
+
140
+
data Selector
141
+
= Class String
142
+
| Not Selector
143
+
| Selector :&: Selector
144
+
| Selector :|: Selector
145
+
deriving (Eq, Show)
146
+
147
+
parseSelector :: String -> Maybe Selector
148
+
parseSelector input = case words input of
149
+
[] -> Nothing
150
+
xs -> (Just . foldr1 (:|:) . map parseAnds) xs
151
+
where
152
+
parseAnds = foldr1 (:&:) . map parseClass . split (== '+')
153
+
154
+
parseClass c = case c of
155
+
'!' : xs -> Not (Class xs)
156
+
_ -> Class c
157
+
158
+
-- a copy from https://github.com/sol/string
159
+
split :: (Char -> Bool) -> String -> [String]
160
+
split p = go
161
+
where
162
+
go xs = case break p xs of
163
+
(ys, []) -> [ys]
164
+
(ys, _ : zs) -> ys : go zs
165
+
166
+
instance IsString Selector where
167
+
fromString = Class
168
+
169
+
data CodeBlock = CodeBlock
170
+
{ codeBlockClasses :: [String],
171
+
codeBlockContent :: [String],
172
+
codeBlockStartLine :: Int
173
+
}
174
+
deriving (Eq, Show)
175
+
176
+
type Line = (Int, String)
177
+
178
+
parse :: String -> [CodeBlock]
179
+
parse = go . zip [2 ..] . lines
180
+
where
181
+
go :: [Line] -> [CodeBlock]
182
+
go xs = case break isFence xs of
183
+
(_, []) -> []
184
+
(_, y : ys) -> case takeCB y ys of
185
+
(cb, rest) -> cb : go rest
186
+
187
+
takeCB :: Line -> [Line] -> (CodeBlock, [Line])
188
+
takeCB (n, fence) xs =
189
+
let indent = length . takeWhile isSpace $ fence
190
+
in case break isFence xs of
191
+
(cb, rest) -> (CodeBlock (parseClasses fence) (map (drop indent . snd) cb) n, drop 1 rest)
192
+
193
+
isFence :: Line -> Bool
194
+
isFence = p . dropWhile isSpace . snd
195
+
where
196
+
p :: String -> Bool
197
+
p line = any (`isPrefixOf` line) fences
198
+
199
+
parseClasses :: String -> [String]
200
+
parseClasses xs = words $ case dropWhile isSpace . dropWhile (`elem` fenceChars) . dropWhile isSpace $ xs of
201
+
'{' : ys -> map dotToSpace . takeWhile (/= '}') $ ys
202
+
ys -> map dotToSpace . takeWhile (not . isSpace) $ ys
203
+
where
204
+
dotToSpace '.' = ' '
205
+
dotToSpace c = c
206
+
207
+
replace :: Char -> Char -> String -> String
208
+
replace x sub = map f
209
+
where
210
+
f y
211
+
| x == y = sub
212
+
| otherwise = y