I’m doing AoC in Haskell to learn the language. These are my solutions.
Day 1
import Data.List
import qualified Data.Map as Map
f xs =
let x1s = sort $ map fst xs
x2s = sort $ map snd xs
diff x y = abs (x - y)
in sum $ zipWith diff x1s x2s
counter = Map.fromListWith (+) . map (,1)
sim xs =
let c = counter (map snd xs)
in sum [x * Map.findWithDefault 0 x c | x <- map fst xs]
main = do
l <- readFile "data1.txt"
let xs = [(read x, read y) | [x, y] <- map words (lines l)]
print (f xs)
print (sim xs)
Pretty clean, I don’t think I can make it nicer.
Day 2
allSame [] = True
allSame (x : xs) = all (== x) xs
monotonic xs = allSame (zipWith (\x y -> signum (x - y)) xs (tail xs))
diffValid (x : y : xs)
| abs (x - y) >= 1 && abs (x - y) <= 3 = diffValid (y : xs)
| otherwise = False
diffValid _ = True
isSafe xs = monotonic xs && diffValid xs
without xs i = [x | (x, j) <- zip xs [1 ..], j /= i]
isSafeDamp xs = isSafe xs || any (isSafe . without xs) [1 .. length xs]
main = do
content <- readFile "data2.txt"
let parsed = map (\l -> map read (words l)) (lines content) :: [[Int]]
let nSafe = length (filter isSafe parsed)
let nSafeDamp = length (filter isSafeDamp parsed)
print ("number of safe elements: " ++ (show nSafe))
print ("number of safe elements (damping): " ++ (show nSafeDamp))
This is also quite clean and straightforward.
Day 3
import Data.List
import Debug.Trace
findMuls :: String -> [Int]
findMuls "" = []
findMuls s@(_ : s')
| "mul(" `isPrefixOf` s = case parseArgs (drop 3 s) of
Just ((n1, n2), rest) -> (n1 * n2) : findMuls rest
Nothing -> findMuls s'
| otherwise = findMuls s'
findMuls2 :: String -> Bool -> [Int]
findMuls2 [] _ = []
findMuls2 s@(_ : s') enabled
| "do()" `isPrefixOf` s = findMuls2 (drop 4 s) True
| "don't()" `isPrefixOf` s = findMuls2 (drop 7 s) False
| "mul(" `isPrefixOf` s = case (enabled, parseArgs (drop 3 s)) of
(True, Just ((n1, n2), rest)) -> (n1 * n2) : findMuls2 rest enabled
_ -> findMuls2 s' enabled
| otherwise = findMuls2 s' enabled
parseArgs :: String -> Maybe ((Int, Int), String)
parseArgs s = case break (== ')') s of
(front, ')' : rest) -> case reads (front ++ ")") of
[(val, "")] -> Just (val, rest)
_ -> Nothing
_ -> Nothing
main :: IO ()
main = do
content <- readFile "data3.txt"
let total = sum (findMuls content)
let total2 = sum (findMuls2 content True)
print $ "total: " ++ show total
print $ "total with flag: " ++ show total2
Not as nice as the other ones. I probably could have used regex or a parsing package.
Day 4
import Data.Array
import Data.List
countXmas [] = 0
countXmas s@(_ : s')
| "XMAS" `isPrefixOf` s = 1 + countXmas (drop 4 s)
| otherwise = countXmas s'
diagonals grid = [diagonal arr i | i <- [0 .. m + n - 2]]
where
m = length grid
n = length $ head grid
arr = listArray ((0, 0), (m - 1, n - 1)) (concat grid)
diagonal arr k = [arr ! (i, k - i) | i <- [max 0 (k - n + 1) .. min k (m - 1)]]
antiDiagonals = diagonals . map reverse
countPatterns grid = sum (map countXmas grid) + sum (map (countXmas . reverse) grid)
countAllDirections grid =
let gridT = transpose grid
gridDiag = diagonals grid
gridADiag = antiDiagonals grid
horCount = countPatterns grid
verCount = countPatterns gridT
diagCount = countPatterns gridDiag
antiDiagCount = countPatterns gridADiag
in horCount + verCount + diagCount + antiDiagCount
isMasXShape (i, j) grid =
grid !! i !! j == 'M'
&& grid !! (i) !! (j + 2) == 'S'
&& grid !! (i + 1) !! (j + 1) == 'A'
&& grid !! (i + 2) !! (j) == 'M'
&& grid !! (i + 2) !! (j + 2) == 'S'
countMasXShape grid = length [() | i <- [0 .. m - 3], j <- [0 .. n - 3], isMasXShape (i, j) grid]
where
m = length grid
n = length $ head grid
countMasXAllDirections grid =
let normalCount = countMasXShape grid
horizontalFlipCount = countMasXShape (map reverse grid)
verticalFlipCount = countMasXShape (transpose grid)
bothFlipCount = countMasXShape (map reverse $ transpose grid)
in normalCount + horizontalFlipCount + verticalFlipCount + bothFlipCount
main = do
content <- readFile "data4.txt"
let grid = lines content
-- Part 1
print $ countAllDirections grid
-- Part 2
print $ countMasXAllDirections grid
Although the number of lines of code are high, I think this solution is conceptually very simple.
Day 5
import qualified Data.Graph as G
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import System.IO
main = do
contents <- readFile "data5.txt"
let (ruleLines, updateLines) = break null (lines contents)
rules = map parseRule ruleLines
updates = map parseUpdate (drop 1 updateLines)
(correctUpdates, incorrectUpdates) = partition (isSorted rules) updates
sortedUpdates = map (sortAccordingTo rules) incorrectUpdates
middleSum = sum $ map middle correctUpdates
middleSum2 = sum $ map middle sortedUpdates
-- part 1
print middleSum
-- part 2
print middleSum2
parseRule s = let [x, y] = splitOn '|' s in (read x, read y)
parseUpdate s = map read $ splitOn ',' s
splitOn delim s = case break (== delim) s of
(a, _ : b) -> a : splitOn delim b
(a, "") -> [a]
isSorted rules update =
let indices = Map.fromList $ zip update [0 ..]
in all
(\(x, y) -> Map.lookup x indices < Map.lookup y indices)
[(x, y) | (x, y) <- rules, x `elem` update, y `elem` update]
sortAccordingTo rules update =
let edges = [(n, n, [y | (x, y) <- rules, x == n, y `elem` update]) | n <- update]
(graph, nodeFromVertex, _) = G.graphFromEdges edges
sortedVertices = G.topSort graph
sortedNodes = map (\v -> let (n, _, _) = nodeFromVertex v in n) sortedVertices
in sortedNodes
middle xs = xs !! (length xs `div` 2)
The Graph API was convenient for this problem!
Day 6
This was my first solution:
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import qualified Data.Set as Set
import Debug.Trace
data Elem = Visited | Blocked | Free deriving (Show, Eq)
type Grid = [[Elem]]
data Direction = U | D | L | R deriving (Show, Eq, Ord)
type Pos = (Int, Int)
type State = (Pos, Direction)
turnRight :: Direction -> Direction
turnRight d
| d == U = R
| d == R = D
| d == D = L
| d == L = U
move (i, j) d
| d == U = (i - 1, j)
| d == R = (i, j + 1)
| d == D = (i + 1, j)
| d == L = (i, j - 1)
toGrid :: [String] -> Grid
toGrid [] = []
toGrid (l : ls) = (foldr repl [] l) : (toGrid ls)
where
repl c acc
| c == '#' = Blocked : acc
| otherwise = Free : acc
findGuard grid = head [(i, j) | i <- [0 .. length grid - 1], j <- [0 .. length (head grid) - 1], grid !! i !! j == '^']
countVisited grid = length (filter (== Visited) (elems grid))
simulate grid pos d m n states
| (pos, d) `Set.member` states = (countVisited grid, True)
| i' < 0 || i' >= m || j' < 0 || j' >= n = (countVisited grid', False)
| grid ! (i', j') == Blocked = simulate grid' pos (turnRight d) m n states'
| otherwise = simulate grid' (move pos d) d m n states'
where
states' = Set.insert (pos, d) states
(i', j') = move pos d
grid' = (grid // [(pos, Visited)])
countCycles grid pos d m n = length $ filter snd $ map (\(g, idx) -> simulateWithLog g pos d m n Set.empty idx total) (zip grids [1 ..])
where
grids = [grid // [((i, j), Blocked)] | i <- [0 .. m - 1], j <- [0 .. n - 1], grid ! (i, j) /= Blocked]
total = length grids
simulateWithLog grid pos d m n states idx total = trace (logProgress idx total) $ simulate grid pos d m n states
logProgress idx total = show idx ++ "/" ++ show total
main = do
content <- readFile "data6.txt"
let charGrid = lines content
let grid = toGrid charGrid
let pos = findGuard charGrid
let (m, n) = (length grid, length $ head grid)
let inds = [(i, j) | i <- [0 .. m - 1], j <- [0 .. n - 1]]
let gridArr = array ((0, 0), (m - 1, n - 1)) (zip inds $ concat grid)
print $ fst $ simulate gridArr pos U m n Set.empty
print $ countCycles gridArr pos U m n
But it was way too slow. The main issue was that simulate was using immutable arrays,
which required copies on every assignment. This can be fixed by using mutable arrays,
at the expense of complexity:
countVisitedST :: STArray s (Int, Int) Elem -> ST s Int
countVisitedST mGrid = do
elems <- getElems mGrid
return $ length (filter (== Visited) elems)
simulate :: Array (Int, Int) Elem -> (Int, Int) -> Direction -> Int -> Int -> Set.Set State -> (Int, Bool)
simulate grid pos d m n states = runST $ do
mGrid <- thaw grid :: ST s (STArray s (Int, Int) Elem)
simulateST mGrid pos d m n states
simulateST :: STArray s (Int, Int) Elem -> (Int, Int) -> Direction -> Int -> Int -> Set.Set State -> ST s (Int, Bool)
simulateST mGrid pos@(i, j) d m n states
| (pos, d) `Set.member` states = do
writeArray mGrid pos Visited
visitedCount <- countVisitedST mGrid
return (visitedCount, True)
| i' < 0 || i' >= m || j' < 0 || j' >= n = do
writeArray mGrid pos Visited
visitedCount <- countVisitedST mGrid
return (visitedCount, False)
| otherwise = do
currentElem <- readArray mGrid (i', j')
if currentElem == Blocked
then simulateST mGrid pos (turnRight d) m n states'
else do
writeArray mGrid pos Visited
simulateST mGrid (move pos d) d m n states'
where
states' = Set.insert (pos, d) states
(i', j') = move pos d
which gives the correct answer in a reasonable amount of time.
Day 7
concatMapFuncs :: [(a -> a -> a)] -> [a] -> [a]
concatMapFuncs fs [x] = [x]
concatMapFuncs fs (x : xs) = concatMap applyAll (concatMapFuncs fs xs)
where
applyAll y = map (\f -> f x y) fs
evalResults ops target xs = target `elem` (concatMapFuncs ops xs)
-- reverse args since the data is reversed
intConcat x y = read (show y ++ show x)
splitLine c s = let (pre, _ : _ : post) = break (== c) s in (pre, post)
main = do
content <- readFile "data7.txt"
let contentLines = lines content
let splitLines = map (splitLine ':') contentLines
-- reverse so that precedence is left -> right
let parsedLines = [(read target, reverse $ map read $ words nums) | (target, nums) <- splitLines]
let calibratedLines = filter (uncurry (evalResults [(+), (*)])) parsedLines
let calibratedLinesConcat = filter (uncurry (evalResults [(+), (*), intConcat])) parsedLines
let result = sum $ map fst calibratedLines
let result2 = sum $ map fst calibratedLinesConcat
-- part 1
print $ result
-- part 2
print $ result2
I like this solution because it shows how expressive higher order functions can be.
Day 8
import Data.Array
import Data.List
import qualified Data.Map as Map
type Loc = (Int, Int)
instance Num Loc where
(x1, y1) + (x2, y2) = (x1 + x2, y1 + y2)
(x1, y1) - (x2, y2) = (x1 - x2, y1 - y2)
(x1, y1) * (x2, y2) = (x1 * x2, y1 * y2)
fromInteger n = (fromInteger n, fromInteger n)
freqLocations grid = foldr (\(pos, c) acc -> Map.insertWith (++) c [pos] acc) Map.empty nonEmptyGrid
where
nonEmptyGrid = filter (\(_, c) -> c /= '.') $ assocs grid
pairs [] = []
pairs (x : xs) = [(x, y) | y <- xs] ++ pairs xs
scale n p = p * fromInteger n
inBounds grid (i, j) =
let ((minI, minJ), (maxI, maxJ)) = bounds grid
in i >= minI && i <= maxI && j >= minJ && j <= maxJ
-- Part 1
placeAntinodes inBounds (p1, p2) = filter inBounds [p1 - dist, p2 + dist]
where
dist = p2 - p1
-- Part 2
placeAntinodes2 inBounds (p1, p2) = (genNodes spaceBefore) ++ (genNodes spaceAfter)
where
genNodes spacingRule = takeWhile inBounds $ map spacingRule [0 ..]
dist = p2 - p1
spaceBefore n = p1 - (scale n dist)
spaceAfter n = p2 + (scale n dist)
antinodes grid locMap placeAntinodes = concatMap process (Map.elems locMap)
where
process locs = concatMap placeAntinodes (pairs locs)
main = do
content <- readFile "data8.txt"
let gridList = lines content
let (m, n) = (length gridList, length $ head gridList)
let grid = listArray ((0, 0), (m - 1, n - 1)) (concat gridList)
let locMap = freqLocations grid
let placer1 = placeAntinodes (inBounds grid)
let placer2 = placeAntinodes2 (inBounds grid)
let allAntinodes1 = antinodes grid locMap placer1
let allAntinodes2 = antinodes grid locMap placer2
-- part 1
print $ length $ nub allAntinodes1
-- part 2
print $ length $ nub allAntinodes2
I wish I could override the * operator for scalar multiplication.
Day 9
import Data.Char
import Data.List (group)
import Debug.Trace
readDisk :: [Int] -> [Int]
readDisk xs = let (_, _, disk) = foldl process (True, 0, []) xs in disk
where
process (isFile, curId, disk) x =
if isFile
then
(False, curId + 1, disk ++ (replicate x curId))
else (True, curId, disk ++ (replicate x (-1)))
compress disk = (take filesize $ compress' disk revDisk) ++ (replicate (length disk - filesize) (-1))
where
compress' [] _ = []
compress' _ [] = []
compress' (f : fs) (b : bs)
| f == -1 = b : compress' fs bs
| otherwise = f : compress' fs (b : bs)
revDisk = filter (>= 0) $ reverse disk
filesize = length revDisk
compressBlocks :: [Int] -> [Int]
compressBlocks disk = concat $ compress' groups
where
compress' [] = []
compress' gs =
let (lastG, initG) = (last gs, init gs)
in if head lastG == -1
then (compress' initG) ++ [lastG]
else case place lastG initG of
Just gs' -> compress' $ group $ concat $ gs' ++ [replicate (length lastG) (-1)]
Nothing -> compress' initG ++ [lastG]
place _ [] = Nothing
place x (f : fs)
| (head f == -1) && length x <= length f = Just ((fill f x) : fs)
| otherwise = do
rest <- place x fs
return (f : rest)
groups = group disk
back = filter ((>= 0) . head) groups
fill f b = b ++ (drop (length b) f)
checkSum compressedDisk = sum [i * x | (i, x) <- zip [0 ..] compressedDisk, x /= -1]
showDisk disk = map (\x -> if x == -1 then '.' else intToDigit x) disk
main = do
content <- readFile "data9.txt"
let nums = map digitToInt content :: [Int]
let disk = readDisk nums
let compressed = compress disk
let compressedBlocks = compressBlocks disk
let cs = checkSum compressed
let cs2 = checkSum compressedBlocks
print $ cs
print $ cs2
I’m not very proud of the compressBlocks solution. It’s complicated and slow. Maybe this problem
is ill-suited for functional programming, but it could also be a skill issue on my part.
Day 10
import Data.Array
import Data.Char
import Data.List
import qualified Data.Set as Set
inBounds grid (i, j) =
let ((minI, minJ), (maxI, maxJ)) = bounds grid
in i >= minI && i <= maxI && j >= minJ && j <= maxJ
trailheads grid = [(i, j) | ((i, j), x) <- assocs grid, x == 0]
count9 grid positions = length $ filter (\pos -> grid ! pos == 9) positions
dfs grid (i, j) = dfs' [] [(i, j)]
where
dfs' seen [] = seen
dfs' seen (cur : stack) = dfs' (cur : seen) (neighbors cur ++ stack)
neighbors (i, j) =
[ (i', j')
| (i', j') <- diffs (i, j),
inBounds grid (i', j'),
grid ! (i', j') - grid ! (i, j) == 1
]
diffs (i, j) = [(i + 1, j), (i - 1, j), (i, j + 1), (i, j - 1)]
-- Here we care about the number of reachable 9s, unique in index
trailheadScore grid (i, j) = count9 grid $ nub $ dfs grid (i, j)
-- Here we care about number of ways to reach any 9, not unique in index
trailheadRating grid (i, j) = count9 grid $ dfs grid (i, j)
main = do
content <- readFile "data10.txt"
let contentLines = lines content
let (m, n) = (length contentLines, length $ head contentLines)
let grid = listArray ((0, 0), (m - 1, n - 1)) (map digitToInt $ concat contentLines)
let ths = trailheads grid
let score1 = sum $ map (trailheadScore grid) ths
let score2 = sum $ map (trailheadRating grid) ths
putStrLn $ "Part 1: " ++ (show score1)
putStrLn $ "Part 2: " ++ (show score2)
It’s nice how part 1 and 2 only differ by a few characters!
Day 11
import qualified Data.Map as Map
type Cache = Map.Map (Int, Int) Int
blinkLen :: Int -> Int -> Cache -> (Int, Cache)
blinkLen 0 _ cache = (1, cache)
blinkLen n 0 cache = blinkLen (n - 1) 1 cache
blinkLen n x cache =
case Map.lookup (n, x) cache of
Just result -> (result, cache)
Nothing ->
let (result, newCache) =
if evenLength x
then evenBlink x cache
else blinkLen (n - 1) (x * 2024) cache
updatedCache = Map.insert (n, x) result newCache
in (result, updatedCache)
where
evenBlink x cache =
let (x1, x2) = split x
(res1, cache1) = blinkLen (n - 1) x1 cache
(res2, cache2) = blinkLen (n - 1) x2 cache1
in (res1 + res2, cache2)
evenLength x = length (show x) `mod` 2 == 0
split x = (read $ take halfLen xStr, read $ drop halfLen xStr)
where
xStr = show x
halfLen = length xStr `div` 2
main = do
content <- readFile "data11.txt"
let nums = map read $ words content :: [Int]
let (result, cache) = foldl (\(acc, cache) x -> let (res, newCache) = blinkLen 25 x cache in (acc + res, newCache)) (0, Map.empty) nums
putStrLn $ "Part 1: " ++ show result
let (result2, _) = foldl (\(acc, cache) x -> let (res, newCache) = blinkLen 75 x cache in (acc + res, newCache)) (0, cache) nums
putStrLn $ "Part 2: " ++ show result2
The code didn’t run fast enough without caching, unfortunately.
Day 12
import Data.Array
import Data.List (group, sortOn)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
type Loc = (Int, Int)
type Grid = Array Loc Char
directions :: [Loc]
directions = [(-1, 0), (1, 0), (0, -1), (0, 1)]
inBounds :: Grid -> Loc -> Bool
inBounds grid (i, j) =
let ((minI, minJ), (maxI, maxJ)) = bounds grid
in i >= minI && i <= maxI && j >= minJ && j <= maxJ
dfs grid start value visited = dfs' [start] visited []
where
dfs' [] visited acc = (acc, visited)
dfs' (current : stack) visited acc
| current `Set.member` visited = dfs' stack visited acc
| otherwise = dfs' (neighbors ++ stack) (Set.insert current visited) (current : acc)
where
neighbors =
[ (i + di, j + dj)
| (di, dj) <- directions,
let (i, j) = current,
let neighbor = (i + di, j + dj),
inBounds grid neighbor,
grid ! neighbor == value
]
findRegions :: Grid -> [[Loc]]
findRegions grid = findRegions' (indices grid) Set.empty []
where
findRegions' [] _ acc = acc
findRegions' (loc : locs) visited acc
| loc `Set.member` visited = findRegions' locs visited acc
| otherwise =
let value = grid ! loc
(region, newVisited) = dfs grid loc value visited
in findRegions' locs newVisited (region : acc)
perimeter grid (i, j) = length $ perimeterIndices grid (i, j)
perimeterIndices grid (i, j) = filter isDifferentOrOutOfBounds neighbors
where
neighbors = [(i + di, j + dj) | (di, dj) <- directions]
isDifferentOrOutOfBounds (ni, nj) =
not (inBounds grid (ni, nj)) || grid ! (ni, nj) /= grid ! (i, j)
nSides grid region =
sum (map (vertSideRows (-1)) [0 .. n])
+ sum (map (vertSideRows 1) [0 .. n])
+ sum (map (horSideRows (-1)) [0 .. m])
+ sum (map (horSideRows 1) [0 .. m])
where
countSides sides = length $ filter (\xs -> head xs) $ group sides
vertSideRows dj j = contGroups $ map fst $ filter (\(i, j) -> invalid (i, j + dj)) (colArray ! j)
horSideRows di i = contGroups $ map snd $ filter (\(i, j) -> invalid (i + di, j)) (rowArray ! i)
((0, 0), (m, n)) = bounds grid
invalid (ni, nj) =
not (inBounds grid (ni, nj)) || not (inRegion (ni, nj))
inRegion pos = pos `Set.member` regionSet
regionSet = Set.fromList region
colArray = listArray (0, n) [sortOn fst $ filter ((== j) . snd) region | j <- [0 .. n]]
rowArray = listArray (0, m) [sortOn snd $ filter ((== i) . fst) region | i <- [0 .. m]]
contGroups [] = 0
contGroups [x] = 1
contGroups (x1 : x2 : xs)
| x2 - x1 == 1 = contGroups (x2 : xs)
| otherwise = 1 + contGroups (x2 : xs)
main :: IO ()
main = do
content <- readFile "data12.txt"
let gridList = lines content
let (m, n) = (length gridList, length $ head gridList)
let grid = listArray ((0, 0), (m - 1, n - 1)) (concat gridList)
let regions = findRegions grid
let areas = map length regions
let perimeters = map (\r -> sum $ map (perimeter grid) r) regions
putStrLn $ "Part 1: " ++ show (sum $ zipWith (*) areas perimeters)
let sides = map (nSides grid) regions
putStrLn $ "Part 2: " ++ show (sum $ zipWith (*) areas sides)
It took me a bit to figure out part 2. Not sure if there’s a better solution.
Day 13
import Data.Maybe
import Debug.Trace
import Text.Parsec
import Text.Parsec.String (Parser)
{-
A =
ax bx
ay by
b = [px, py]
Ax=b => x = A^-1 b
-}
solve ((ax, ay), (bx, by), (px, py)) =
let a = fromIntegral ax
b = fromIntegral bx
c = fromIntegral ay
d = fromIntegral by
p = fromIntegral px
q = fromIntegral py
det = a * d - b * c
in if det == 0
then Nothing
else
let (invA11, invA12, invA21, invA22) = (d / det, -b / det, -c / det, a / det)
x = invA11 * p + invA12 * q
y = invA21 * p + invA22 * q
roundedX = round x
roundedY = round y
in if (fromIntegral roundedX * a + fromIntegral roundedY * b == p) && (fromIntegral roundedX * c + fromIntegral roundedY * d == q)
then Just (3 * roundedX + roundedY)
else Nothing
minTokenCost xs = sum $ map (maybe 0 id . solve) xs
parseTestCase :: Parser ((Int, Int), (Int, Int), (Int, Int))
parseTestCase = do
_ <- string "Button A: X+"
ax <- many1 digit
_ <- string ", Y+"
ay <- many1 digit
_ <- newline
_ <- string "Button B: X+"
bx <- many1 digit
_ <- string ", Y+"
by <- many1 digit
_ <- newline
_ <- string "Prize: X="
px <- many1 digit
_ <- string ", Y="
py <- many1 digit
_ <- newline
return ((read ax, read ay), (read bx, read by), (read px, read py))
parseTestCases :: Parser [((Int, Int), (Int, Int), (Int, Int))]
parseTestCases = many (parseTestCase <* optional newline)
readTestCases :: String -> Either ParseError [((Int, Int), (Int, Int), (Int, Int))]
readTestCases = parse parseTestCases ""
main = do
input <- readFile "data13.txt"
let delta = 10000000000000
case readTestCases input of
Left err -> print err
Right testCases -> do
putStrLn $ "Part 1: " ++ show (minTokenCost testCases)
let testCasesPart2 = map (\((ax, ay), (bx, by), (px, py)) -> ((ax, ay), (bx, by), (px + delta, py + delta))) testCases
putStrLn $ "Part 2: " ++ show (minTokenCost testCasesPart2)
Since this reduced to a simple Linear Algebra problem, the solution is conceptually easy. But writing matrix ops by hand in Haskell is inconvenient.
Day 14
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Data.List
import Debug.Trace
import Text.Parsec
import Text.Parsec.String (Parser)
number :: Parser Int
number = do
sign <- optionMaybe (char '-')
digits <- many1 digit
let num = read digits
return $ case sign of
Just _ -> -num
Nothing -> num
parseLine :: Parser ((Int, Int), (Int, Int))
parseLine = do
_ <- string "p="
px <- number
_ <- char ','
py <- number
_ <- spaces
_ <- string "v="
vx <- number
_ <- char ','
vy <- number
return ((py, px), (vy, vx))
parseData :: Parser [((Int, Int), (Int, Int))]
parseData = parseLine `sepBy` newline
zeros m n = listArray ((0, 0), (m - 1, n - 1)) [0 | i <- [0 .. m - 1], j <- [0 .. n - 1]]
buildGrid :: [((Int, Int), (Int, Int))] -> Int -> Int -> Array (Int, Int) Int
buildGrid nums m n = runSTArray $ do
arr <- newArray ((0, 0), (m - 1, n - 1)) 0
mapM_ (assign arr) nums
return arr
where
assign arr ((x, y), _) = do
current <- readArray arr (x, y)
writeArray arr (x, y) (current + 1)
printGrid :: Array (Int, Int) Int -> IO ()
printGrid grid = do
let ((minX, minY), (maxX, maxY)) = bounds grid
mapM_ (printRow minY maxY) [minX .. maxX]
where
printRow minY maxY x = do
let row = [if grid ! (x, y) == 0 then '.' else head (show (grid ! (x, y))) | y <- [minY .. maxY]]
putStrLn row
timestep _ _ [] = []
timestep m n (((pi, pj), (vi, vj)) : rest) = (wrap (pi + vi) (pj + vj) m n, (vi, vj)) : (timestep m n rest)
where
wrap i j m n = ((i + m) `mod` m, (j + n) `mod` n)
quadrantSums grid m n =
let mid dim = ((dim - 1) `div` 2)
(midI, midJ) = (mid m, mid n)
in [ sum $ [grid ! (i, j) | i <- [0 .. midI - 1], j <- [0 .. midJ - 1]],
sum $ [grid ! (i, j) | i <- [0 .. midI - 1], j <- [midJ + 1 .. n - 1]],
sum $ [grid ! (i, j) | i <- [midI + 1 .. m - 1], j <- [0 .. midJ - 1]],
sum $ [grid ! (i, j) | i <- [midI + 1 .. m - 1], j <- [midJ + 1 .. n - 1]]
]
hasCenter :: Int -> Int -> Int -> [((Int, Int), (Int, Int))] -> Bool
hasCenter m n thresh nums = thresh <= (length $ filter inCenter nums)
where
inCenter ((i, j), _) = i >= m `div` 4 && i <= 3 * (m `div` 4) && j >= n `div` 4 && j <= 3 * (n `div` 4)
main = do
content <- readFile "data14.txt"
let (m, n) = (103, 101)
let niter = 100
case parse parseData "" content of
Left err -> print err >> return ()
Right nums -> do
putStrLn ""
let states = iterate (timestep m n) nums
let finalState = states !! niter
let finalGrid = buildGrid finalState m n
let qsums = quadrantSums finalGrid m n
putStrLn $ "Part 1: " ++ (show $ product qsums)
let thresh = length nums `div` 2
let (firstIndex, num) = head $ filter (\(i, num) -> hasCenter m n thresh num) $ zip [0 ..] states
printGrid $ buildGrid num m n
putStrLn $ "Part 2: " ++ (show i)
Day 15
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Debug.Trace
type Loc = (Int, Int)
type Grid = Array Loc Char
type Dir = Char
inBounds :: Grid -> Loc -> Bool
inBounds grid (i, j) =
let ((iMin, jMin), (iMax, jMax)) = bounds grid
in i >= iMin && i <= iMax && j >= jMin && j <= jMax
inBoundsMut :: (Ix i) => STArray s (i, i) e -> (i, i) -> ST s Bool
inBoundsMut grid (i, j) = do
((iMin, jMin), (iMax, jMax)) <- getBounds grid
return $ i >= iMin && i <= iMax && j >= jMin && j <= jMax
nextPos dir (i, j) = case dir of
'^' -> (i - 1, j)
'v' -> (i + 1, j)
'<' -> (i, j - 1)
'>' -> (i, j + 1)
move :: Grid -> Loc -> Loc -> Maybe Grid
move grid (i1, j1) (i2, j2)
| inBounds grid (i1, j1) && inBounds grid (i2, j2) =
let (didMove, grid') = runST $ do
gridMut <- thaw grid
didMove <- moveST gridMut (i1, j1) (i2, j2)
grid' <- freeze gridMut
return (didMove, grid')
in if didMove then Just grid' else Nothing
| otherwise = Nothing
moveST :: STArray s Loc Char -> Loc -> Loc -> ST s Bool
moveST gridMut (i1, j1) (i2, j2) = do
elem1 <- readArray gridMut (i1, j1)
elem2 <- readArray gridMut (i2, j2)
case (elem1, elem2) of
('.', _) -> return True
(_, '#') -> return False
('@', '.') -> do
writeArray gridMut (i2, j2) '@'
writeArray gridMut (i1, j1) '.'
return True
('O', '.') -> do
writeArray gridMut (i2, j2) 'O'
writeArray gridMut (i1, j1) '.'
return True
(x, 'O') -> do
let (i3, j3) = (i2 + (i2 - i1), j2 + (j2 - j1))
inb <- inBoundsMut gridMut (i3, j3)
if inb
then do
valid <- moveST gridMut (i2, j2) (i3, j3)
if not valid
then return False
else do
writeArray gridMut (i2, j2) x
writeArray gridMut (i1, j1) '.'
return True
else return False
moveRobot grid (i, j) dir =
let (i', j') = nextPos dir (i, j)
in if not (inBounds grid (i', j'))
then (grid, (i, j))
else case move grid (i, j) (i', j') of
Just g -> (g, (i', j'))
Nothing -> (grid, (i, j))
printGrid :: Grid -> IO ()
printGrid grid = do
let ((iMin, jMin), (iMax, jMax)) = bounds grid
mapM_
( \i -> do
mapM_ (\j -> putStr [grid ! (i, j)]) [jMin .. jMax]
putStrLn ""
)
[iMin .. iMax]
traceGrid :: Grid -> a -> a
traceGrid grid expr = trace (unlines gridLines) expr
where
((iMin, jMin), (iMax, jMax)) = bounds grid
gridLines = [[grid ! (i, j) | j <- [jMin .. jMax]] | i <- [iMin .. iMax]]
score grid = sum $ map (\((i, j), _) -> 100 * i + j) $ filter (\(_, x) -> x == 'O') $ assocs grid
wideGrid grid m n = listArray ((0, 0), (m - 1, 2 * n - 1)) grid'
where
grid' = concatMap repl (assocs grid)
repl (_, x)
| x == '#' = "##"
| x == 'O' = "[]"
| x == '.' = ".."
| x == '@' = "@."
findPos grid = head [pos | (pos, x) <- assocs grid, x == '@']
gpsCoordSum grid = sum [100 * i + j | ((i, j), x) <- assocs grid, x == '[']
moveW :: Array Loc Char -> Dir -> Array Loc Char
moveW grid dir = case (grid ! (i, j), grid ! (i', j')) of
('@', '#') -> grid
('@', '.') -> grid // [((i, j), '.'), ((i', j'), '@')]
('@', '[') ->
let grid' = moveBox grid (i', j') dir
in if grid' ! (i', j') == '.'
then
grid' // [((i, j), '.'), ((i', j'), '@')]
else grid
('@', ']') ->
let grid' = moveBox grid (i', j' - 1) dir
in if grid' ! (i', j') == '.'
then
grid' // [((i, j), '.'), ((i', j'), '@')]
else grid
x -> error (show x)
where
(i, j) = findPos grid
(i', j') = nextPos dir (i, j)
-- move box at (i,j) in direction dir
moveBox :: Array Loc Char -> Loc -> Dir -> Array Loc Char
moveBox grid (i, j) dir
-- if we move up, it can either between
-- []
-- [] (moves up)
-- [][]
-- [] (moves up)
-- in the first case, we move the upper box and move the cur box if there is space
-- in the second case we move both boxes and then the current box if there is space
| boxSpaceEmpty grid (i, j) dir =
if grid ! (i, j) /= '['
then
error "must be left brack"
else case dir of
'^' ->
grid
// [ ((i, j), '.'),
((i, j + 1), '.'),
((i - 1, j), '['),
((i - 1, j + 1), ']')
]
'v' ->
grid
// [ ((i, j), '.'),
((i, j + 1), '.'),
((i + 1, j), '['),
((i + 1, j + 1), ']')
]
'<' ->
grid
// [ ((i, j), ']'),
((i, j + 1), '.'),
((i, j - 1), '[')
]
'>' ->
grid
// [ ((i, j), '.'),
((i, j + 1), '['),
((i, j + 2), ']')
]
| boxSpaceBlocked grid (i, j) dir = grid
| otherwise =
let boxes = getNeighBoxes grid (i, j) dir
grid' = foldr (\pos g -> moveBox g pos dir) grid boxes :: Array Loc Char
in if boxSpaceEmpty grid' (i, j) dir
then
moveBox grid' (i, j) dir
else grid'
getNeighBoxes grid (i, j) dir
| grid ! (i, j) /= '[' = error "must be left brack"
| otherwise = case dir of
'^' ->
if grid ! (i - 1, j) == '['
then [(i - 1, j)]
else
if grid ! (i - 1, j) == ']' && grid ! (i - 1, j + 1) == '['
then [(i - 1, j - 1), (i - 1, j + 1)]
else
if grid ! (i - 1, j) == ']'
then [(i - 1, j - 1)]
else
if grid ! (i - 1, j + 1) == '['
then [(i - 1, j + 1)]
else []
'v' ->
if grid ! (i + 1, j) == '['
then [(i + 1, j)]
else
if grid ! (i + 1, j) == ']' && grid ! (i + 1, j + 1) == '['
then [(i + 1, j - 1), (i + 1, j + 1)]
else
if grid ! (i + 1, j) == ']'
then [(i + 1, j - 1)]
else
if grid ! (i + 1, j + 1) == '['
then [(i + 1, j + 1)]
else []
'>' -> if grid ! (i, j + 2) == '[' then [(i, j + 2)] else []
'<' -> if grid ! (i, j - 1) == ']' then [(i, j - 2)] else []
boxDisplacingSpaces grid (i, j) dir
| grid ! (i, j) /= '[' = error "must be left brack"
| otherwise = case dir of
'^' -> [(i - 1, j), (i - 1, j + 1)]
'v' -> [(i + 1, j), (i + 1, j + 1)]
'>' -> [(i, j + 2)]
'<' -> [(i, j - 1)]
boxSpaceEmpty grid (i, j) dir =
all
(\p -> inBounds grid p && grid ! p == '.')
(boxDisplacingSpaces grid (i, j) dir)
boxSpaceBlocked grid (i, j) dir =
any
(\p -> not (inBounds grid p) || grid ! p == '#')
(boxDisplacingSpaces grid (i, j) dir)
main :: IO ()
main = do
rawContent <- readFile "data15.txt"
let (gridSpec, _ : movesSpec) = break null (lines rawContent)
let moves = concat movesSpec
let (m, n) = (length gridSpec, length $ head gridSpec)
let grid = listArray ((0, 0), (m - 1, n - 1)) (concat gridSpec)
let (i, j) = fst $ head $ filter (\(_, x) -> x == '@') $ assocs grid
let (finalGrid, finalPos) = foldl' (\(grid, pos) d -> moveRobot grid pos d) (grid, (i, j)) moves
print $ score finalGrid
let wgrid = wideGrid grid m n
let final = foldl' moveW wgrid moves
print $ gpsCoordSum final
Not very proud of this solution. It’s messy, long, and the first part didn’t require mutable arrays. Might come back and improve it.
Day 16
{-# LANGUAGE TupleSections #-}
import Data.Array
import Data.Heap (MinPrioHeap)
import qualified Data.Heap as H
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import System.IO
type Dir = Int
type Loc = (Int, Int)
type Grid = Array Loc Char
type State = (Loc, Dir)
type Cost = Int
directionsForward = [(0, 1), (1, 0), (0, -1), (-1, 0)]
directionsBackward = map (\(x, y) -> (-x, -y)) directionsForward
parseGrid :: [String] -> (Grid, Loc, Loc)
parseGrid linesInput =
let m = length linesInput
n = length (head linesInput)
gridList = concat linesInput
grid = listArray ((0, 0), (m - 1, n - 1)) gridList
findPos x = head [(i, j) | i <- [0 .. m - 1], j <- [0 .. n - 1], grid ! (i, j) == x]
start = findPos 'S'
end = findPos 'E'
in (grid, start, end)
isValid :: Grid -> Loc -> Bool
isValid grid loc = inBounds grid loc && grid ! loc /= '#'
inBounds :: Grid -> Loc -> Bool
inBounds grid (i, j) =
let ((iMin, jMin), (iMax, jMax)) = bounds grid
in i >= iMin && i <= iMax && j >= jMin && j <= jMax
dijkstra :: Grid -> [State] -> [Loc] -> Map.Map State Cost
dijkstra grid starts directions = go initialQueue Map.empty
where
initialQueue = H.fromList [(0, s) | s <- starts]
go :: MinPrioHeap Cost State -> Map.Map State Cost -> Map.Map State Cost
go pq seenMap =
case H.view pq of
Nothing -> seenMap
Just ((currentCost, currentState), pq') ->
if Map.member currentState seenMap
then go pq' seenMap
else
let seenMap' = Map.insert currentState currentCost seenMap
(loc@(x, y), dir) = currentState
(dx, dy) = directions !! dir
newLoc = (x + dx, y + dy)
newStates =
if isValid grid newLoc
then [(currentCost + 1, (newLoc, dir))]
else []
turnDirs = [(dir + 1) `mod` 4, (dir + 3) `mod` 4]
newStates' = newStates ++ [(currentCost + 1000, (loc, newDir)) | newDir <- turnDirs]
updatedPQ = foldr H.insert pq' newStates'
in go updatedPQ seenMap'
countBestPathTiles grid start end minCost costFromStart costToEnd =
let startsFromStart = [(start, 0)]
startsFromEnd = [(end, d) | d <- [0 .. 3]]
gridBounds = range (bounds grid)
bestTiles =
Set.fromList
[ loc
| loc <- gridBounds,
grid ! loc /= '#',
any
( \d ->
let cost_s = Map.findWithDefault maxBound (loc, d) costFromStart
cost_e = Map.findWithDefault maxBound (loc, d) costToEnd
in cost_s + cost_e == minCost
)
[0 .. 3]
]
in Set.size bestTiles
main :: IO ()
main = do
content <- readFile "data16.txt"
let gridLines = lines content
let (grid, start, end) = parseGrid gridLines
let startsFromStart = [(start, 0)]
let costFromStart = dijkstra grid startsFromStart directionsForward
let startsFromEnd = [(end, d) | d <- [0 .. 3]]
let costToEnd = dijkstra grid startsFromEnd directionsBackward
let minCost = minimum [Map.findWithDefault maxBound (end, d) costFromStart | d <- [0 .. 3]]
putStrLn $ "Minimum Score: " ++ show minCost
let tileCount = countBestPathTiles grid start end minCost costFromStart costToEnd
putStrLn $ "Number of Best Path Tiles: " ++ show tileCount
This one needed some DP trickery for part 2 to run in time. We compute the shortest distances from the start and to the end tile for every tile. We can then use this to quickly compute all optimal paths.
Day 17
import Data.Array
import Data.Bits
import Data.List (foldl', intercalate)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import System.IO
import Text.Parsec
import Text.Parsec.String (Parser)
type Regs = Array Int Int
type Op = Int
type Inst = (Int, Int)
type Prog = [Inst]
type Func = Regs -> [Int] -> Op -> Int -> (Regs, [Int], Int)
[a, b, c] = [0 .. 2]
comboOperand :: Regs -> Int -> Int
comboOperand regs op
| op <= 3 = op
| op == 4 = regs ! a
| op == 5 = regs ! b
| op == 6 = regs ! c
| otherwise = error "Invalid operand"
adv, bxl, bst, jnz, bxc, outOp, bdv, cdv :: Func
adv regs out op ip = (regs // [(a, res)], out, ip + 1)
where
res = regs ! a `div` (2 ^ comboOperand regs op)
bxl regs out op ip = (regs // [(b, res)], out, ip + 1)
where
res = regs ! b `xor` op
bst regs out op ip = (regs // [(b, comboOperand regs op `mod` 8)], out, ip + 1)
jnz regs out op ip = (regs, out, ip')
where
ip' = if regs ! a /= 0 then op else ip + 1
bxc regs out op ip = (regs // [(b, regs ! b `xor` regs ! c)], out, ip + 1)
outOp regs out op ip = (regs, o : out, ip + 1)
where
o = comboOperand regs op `mod` 8
bdv regs out op ip = (regs // [(b, res)], out, ip + 1)
where
res = regs ! a `div` (2 ^ comboOperand regs op)
cdv regs out op ip = (regs // [(c, res)], out, ip + 1)
where
res = regs ! a `div` (2 ^ comboOperand regs op)
opFuncs :: [Func]
opFuncs = [adv, bxl, bst, jnz, bxc, outOp, bdv, cdv]
-- Parser for initial register values
parseRegs :: Parser Regs
parseRegs = do
string "Register A: "
aVal <- read <$> many1 digit
newline
string "Register B: "
bVal <- read <$> many1 digit
newline
string "Register C: "
cVal <- read <$> many1 digit
many newline
return $ listArray (0, 2) [aVal, bVal, cVal]
-- Parser for the program
parseProg :: Parser Prog
parseProg = do
string "Program: "
sepBy parseInst (char ',')
-- Parser for a single instruction
parseInst :: Parser Inst
parseInst = do
opcode <- read <$> many1 digit
char ','
operand <- read <$> many1 digit
return (opcode, operand)
-- Combined parser for the entire input
parseInput :: Parser (Regs, Prog)
parseInput = do
regs <- parseRegs
prog <- parseProg
return (regs, prog)
runProg :: Prog -> Regs -> [Int]
runProg prog regs = reverse out
where
progLen = length prog
notDone (_, _, ip) = ip < progLen
exec (regs', out, ip) =
let (opCode, operand) = prog !! ip
func = opFuncs !! opCode
in func regs' out operand ip
(_, out, _) = head $ dropWhile notDone $ iterate exec (regs, [], 0)
cycleFunc :: Int -> Int
cycleFunc a =
let b1 = a .&. 7
b2 = b1 `xor` 5
c = a `shiftR` b2
b3 = b2 `xor` 6
a' = a `shiftR` 3
b4 = b3 `xor` c
in b4 .&. 7
dfs :: [Int] -> [Int]
dfs prog = concatMap (\a -> findPath a 10 a (tail prog)) initialSet
where
possibleAs :: Map Int [Int]
possibleAs = Map.fromListWith (++) [(cycleFunc a, [a]) | a <- [0 .. 1023]]
initialSet :: [Int]
initialSet = case prog of
[] -> []
(x : _) -> Map.findWithDefault [] x possibleAs
findPath :: Int -> Int -> Int -> [Int] -> [Int]
findPath path pathI cur [] =
if (cur `shiftR` 3) == 0 then [path] else []
findPath path pathI cur (t : ts) =
let cur' = cur `shiftR` 3
candidates = Map.findWithDefault [] t possibleAs
matches = filter (\a0 -> (a0 .&. 0x7F) == cur') candidates
in concatMap
( \a ->
let newA = (a `shiftR` 7) .&. 0x7
newPath = path .|. (newA `shiftL` pathI)
in findPath newPath (pathI + 3) a ts
)
matches
main :: IO ()
main = do
content <- readFile "data17.txt"
case parse parseInput "" content of
Left err -> print err
Right (regs, prog) -> do
putStr "Part 1: "
putStrLn $ intercalate "," $ map show $ runProg prog regs
let flatProg = concat [[x, y] | (x, y) <- prog]
putStrLn $ "Part 2: " ++ show (minimum (dfs flatProg))
Part 2 was quite tough. Brute force didn’t work, so I had to manually inspect the program and find a smarter search method. I also couldn’t debug fast enough with Haskell (skill issue), so my solution is direct translation of my Python debugging code.
Python debugging code
from collections import defaultdict
def run_specific_program(A):
"""The given program, directly translated into Python for validation."""
B = 0
C = 0
output = []
while True:
# Instruction 1: bst 4 -> B = A % 8
# get last 3 bits of A
B = (A & 0b111) ^ 0b101
# Instruction 2: bxl 5 -> B ^= 5
# B <- B ^ 0b101
# Instruction 3: cdv 5 -> C = A // (2 ** B)
# Operand 5 refers to register B
C = A >> B
# C = A // (2 ** B)
# Instruction 4: bxl 6 -> B ^= 6
# 0b110
# B ^= 0b110
# Instruction 5: adv 3 -> A = A // 8
A = A >> 3
# A = A // 8
# Instruction 6: bxc 6 -> B ^= C
# B ^= C
# Instruction 7: out 5 -> output B % 8
output.append(str((B ^ C ^ 0b110) & 0b111))
# Instruction 8: jnz 0 -> if A != 0, jump to start
if A == 0:
break # Halt the program
return ",".join(output)
def cycle(A):
"""A single loop iteration of the program given, translated into python."""
B = A % 8 # & 0b111
B ^= 5 # 0b101
# 0 <= B <= 7
C = A >> B
B ^= 6
A = A >> 3
B ^= C
out = B % 8 # & 0b111
return out
def dfs(prog):
possible_As = defaultdict(list)
# cycle is only a function of the first 10 bits of A
for A in range(1 << 10):
out = cycle(A)
possible_As[out].append(A)
def find_path(path, path_i, cur, prog, prog_i) -> list[int]:
# find all possible next 3 bits of A given the last 7
if prog_i == len(prog):
if (cur >> 3) == 0:
# program ended with A == 0
return [path]
else:
# program didn't terminate on time
return []
cur = cur >> 3
nexts = []
target = prog[prog_i]
for A0 in possible_As[target]:
if A0 & 0b1111111 == cur:
nexts.append(A0)
ret = []
for A in nexts:
new_A = (A & (0b111 << 7)) >> 7
cur_path = path | (new_A << path_i)
ret.extend(find_path(cur_path, path_i + 3, A, prog, prog_i + 1))
return ret
init_set = possible_As[prog[0]]
ret = []
for cur in init_set:
ret.extend(find_path(cur, 10, cur, prog, 1))
return ret
prog = [2, 4, 1, 5, 7, 5, 1, 6, 0, 3, 4, 6, 5, 5, 3, 0]
test = [3, 6, 3, 7, 0, 7, 0, 3, 0]
res = dfs(prog)
print(len(res))
print(min(res))
for r in res:
result = run_specific_program(r)
print(result)
Day 18
import Control.Monad
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Data.Foldable (toList)
import qualified Data.Map as Map
import Data.Maybe (isJust)
import Data.Sequence (Seq (..), (|>))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Debug.Trace
import System.IO
import System.IO.Unsafe (unsafePerformIO)
readPair s =
let (pre, _ : post) = break (== ',') s
in (read post, read pre) -- convert x,y to i,j
printGrid grid = do
let ((iMin, jMin), (iMax, jMax)) = bounds grid
mapM_
( \i -> do
mapM_ (\j -> putStr [grid ! (i, j)]) [jMin .. jMax]
putStrLn ""
)
[iMin .. iMax]
bfs grid start target = bfs' (Seq.singleton (start, 0)) Set.empty
where
bfs' Seq.Empty _ = Nothing
bfs' ((current@(i, j), len) :<| rest) visited
| current == target = Just len
| current `Set.member` visited = bfs' rest visited
| otherwise =
bfs' (rest <> Seq.fromList neighbors) (Set.insert current visited)
where
neighbors = [((i + di, j + dj), len + 1) | (di, dj) <- directions, inBounds (i + di, j + dj), grid ! (i + di, j + dj) /= '#']
inBounds (i, j) =
let ((minI, minJ), (maxI, maxJ)) = bounds grid
in i >= minI && i <= maxI && j >= minJ && j <= maxJ
directions = [(-1, 0), (1, 0), (0, -1), (0, 1)]
showPair (i, j) = show j ++ "," ++ show i
main = do
content <- readFile "data18.txt"
let pairs = map readPair (lines content)
let (m, n) = (71, 71)
let nPairs = 1024
let gridInit = listArray ((0, 0), (m - 1, n - 1)) ['.' | i <- [0 .. m - 1], j <- [0 .. n - 1]]
let grid = gridInit // [(p, '#') | p <- (take nPairs pairs)]
case bfs grid (0, 0) (m - 1, n - 1) of
Just len -> putStrLn $ "Part 1: " ++ (show len)
Nothing -> error "couldn't find exit"
let total = length pairs
let restPairs = drop nPairs pairs
let grids = scanl addObstacle (head restPairs, grid) (zip [1025 ..] (tail restPairs))
where
addObstacle (_, g) (n, p) = unsafePerformIO $ do
putStr $ "\r" ++ show n ++ "/" ++ show total ++ " pairs added"
hFlush stdout
return (p, g // [(p, '#')])
let result = (showPair . fst . head) $ dropWhile (\(_, g) -> isJust $ bfs g (0, 0) (m - 1, n - 1)) grids
putStrLn ""
print $ result
A bit slow, but it works.
Day 19
import Control.Monad (void)
import qualified Control.Monad.State as S
import Data.List (isPrefixOf)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Text.Parsec
import Text.Parsec.String (Parser)
type Pattern = String
type Towel = String
type Cache = Map.Map String Bool
parsePatternOrTowel :: Parser String
parsePatternOrTowel = many1 (noneOf ", \n")
parsePatterns :: Parser [Pattern]
parsePatterns = parsePatternOrTowel `sepBy` (char ',' <* spaces)
parseTowels :: Parser [Towel]
parseTowels = many1 (parsePatternOrTowel <* spaces)
parseInput :: Parser ([Pattern], [Towel])
parseInput = do
patterns <- parsePatterns
void newline
void newline
towels <- parseTowels
return (patterns, towels)
main :: IO ()
main = do
content <- readFile "data19.txt"
case parse parseInput "" content of
Left err -> print err
Right (patterns, towels) -> do
putStrLn $ "Part 1: " ++ (show $ length $ filter (\t -> countPossible patterns t > 0) towels)
putStrLn $ "Part 2: " ++ (show $ sum $ map (countPossible patterns) towels)
countPossible patterns towel = S.evalState (go patterns towel) Map.empty
where
go _ "" = return 1
go patterns towel = do
cache <- S.get
case Map.lookup towel cache of
Just result -> return result
Nothing -> do
let cands = filter (`isPrefixOf` towel) patterns
let checkCandidate p = go patterns (drop (length p) towel)
result <- sum <$> mapM checkCandidate cands
S.modify (Map.insert towel result)
return result
Learned how to use the State monad. Cool!
Day 20
import Control.Monad
import Data.Array
import qualified Data.Map as Map
import Data.Sequence (Seq (..), (|>))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
inBounds grid (i, j) =
let ((minI, minJ), (maxI, maxJ)) = bounds grid
in i >= minI && i <= maxI && j >= minJ && j <= maxJ
distanceFrom grid start = go (Seq.singleton (start, 0)) Set.empty Map.empty
where
go Seq.Empty _ dists = listArray (bounds grid) (map (\i -> Map.findWithDefault maxBound i dists) (indices grid))
go ((pos@(i, j), d) :<| rest) seen dists
| pos `Set.member` seen = go rest seen dists
| otherwise = go (rest <> Seq.fromList (neighbors grid pos)) (Set.insert pos seen) (Map.insert pos d dists)
where
neighbors grid (i, j) =
[((i + di, j + dj), d + 1) | (di, dj) <- directions, inBounds grid (i + di, j + dj), grid ! (i + di, j + dj) /= '#']
distWithSkip grid distFromStart distToEnd (skipStart, skipEnd, skipLen) =
distFromStart ! skipStart + skipLen + distToEnd ! skipEnd
directions = [(-1, 0), (1, 0), (0, -1), (0, 1)]
findPaths grid maxDist start = bfs' [] (Seq.singleton (start, 0)) Set.empty
where
bfs' acc Seq.Empty _ = acc
bfs' acc ((current@(i, j), len) :<| rest) visited
| len > maxDist = bfs' acc rest (Set.insert current visited)
| current `Set.member` visited = bfs' acc rest visited
| otherwise =
let acc' = if grid ! current /= '#' then ((current, len) : acc) else acc
in bfs' acc' (rest <> Seq.fromList neighbors) (Set.insert current visited)
where
neighbors = [((i + di, j + dj), len + 1) | (di, dj) <- directions, inBounds grid (i + di, j + dj)]
barriers grid cheatTime =
let allPaths = [pos | (pos, x) <- assocs grid, x /= '#']
reachablePaths = findPaths grid cheatTime
in [(s, e, l) | s <- allPaths, (e, l) <- reachablePaths s]
gridFind grid target = head [pos | (pos, x) <- assocs grid, x == target]
computeSavings grid cheatTime thresh =
let start = gridFind grid 'S'
end = gridFind grid 'E'
fromStart = distanceFrom grid start
toEnd = distanceFrom grid end
origTime = fromStart ! end
possibleSkips = barriers grid cheatTime
savings = map ((\x -> origTime - x) . distWithSkip grid fromStart toEnd) possibleSkips
validSavings = filter (>= thresh) savings
in length validSavings
main = do
content <- readFile "data20.txt"
let contentLines = lines content
let (m, n) = (length contentLines, length $ head contentLines)
let grid = listArray ((0, 0), (m - 1, n - 1)) (concat contentLines)
let cheatTime = 2 :: Int
let thresh = 100
putStrLn $ "Part 1: " ++ (show $ computeSavings grid cheatTime thresh)
let cheatTime2 = 20
putStrLn $ "Part 2: " ++ (show $ computeSavings grid cheatTime2 thresh)
I like this solution—it’s very functional— but it is slow for part 2.
Day 21
import Data.Char (isDigit)
import Data.IORef
import Data.List (zip4)
import Data.Map (Map)
import qualified Data.Map as M
import System.IO.Unsafe (unsafePerformIO)
type Keypad = [String]
type Pos = (Int, Int)
dirKeypad :: Keypad
dirKeypad = [".^A", "<v>"]
dirKeypadInv :: Map Char Pos
dirKeypadInv = buildInv dirKeypad
keypad :: Keypad
keypad = ["789", "456", "123", ".0A"]
keypadInv :: Map Char Pos
keypadInv = buildInv keypad
buildInv :: Keypad -> Map Char Pos
buildInv kp =
M.fromList
[ (c, (r, cx))
| (r, row) <- zip [0 ..] kp,
(cx, c) <- zip [0 ..] row
]
inBounds :: Keypad -> Pos -> Bool
inBounds kp (r, c) = r >= 0 && r < length kp && c >= 0 && c < length (head kp)
neighbors :: Keypad -> Pos -> [(Pos, Char)]
neighbors kp (r, c) =
let ds = [(0, 1), (0, -1), (1, 0), (-1, 0)]
dch = ['>', '<', 'v', '^']
in [ ((r + dr, c + dc), ch)
| ((dr, dc), ch) <- zip ds dch,
inBounds kp (r + dr, c + dc),
(kp !! (r + dr)) !! (c + dc) /= '.'
]
getDirections :: Keypad -> Pos -> Pos -> [String]
getDirections kp start target = bfs [(start, "")]
where
bfs [] = error "No path found"
bfs q =
let found = [path | (p, path) <- q, p == target]
in if not (null found)
then found
else
let nxt =
[ (npos, path ++ [dir])
| (pos, path) <- q,
(npos, dir) <- neighbors kp pos
]
in bfs nxt
getCodeDirections :: Keypad -> Map Char Pos -> Pos -> String -> [String]
getCodeDirections kp kpinv st keys =
let sc = (kp !! fst st) !! snd st
in foldl
( \dirs (sK, tK) ->
let nds = getDirections kp (kpinv M.! sK) (kpinv M.! tK)
in [d ++ nd ++ "A" | d <- dirs, nd <- nds]
)
[""]
(zip (sc : keys) keys)
{-# NOINLINE memoMap #-}
memoMap :: IORef (Map (Pos, Pos, Int) Int)
memoMap = unsafePerformIO (newIORef M.empty)
shortestDirectionsPairwise :: Pos -> Pos -> Int -> Int
shortestDirectionsPairwise start end depth = unsafePerformIO $ do
m <- readIORef memoMap
case M.lookup (start, end, depth) m of
Just v -> return v
Nothing -> do
let dirs = getDirections dirKeypad start end
dirsAct = map (++ "A") dirs
let val =
if depth == 1
then minimum (map length dirsAct)
else
let ps = map (\d -> zip ('A' : d) d) dirsAct
in minimum
[ sum
[ shortestDirectionsPairwise
(dirKeypadInv M.! sC)
(dirKeypadInv M.! eC)
(depth - 1)
| (sC, eC) <- pair
]
| pair <- ps
]
writeIORef memoMap (M.insert (start, end, depth) val m)
return val
shortestPath :: String -> Int -> Int
shortestPath code padDepth =
let initDirs = getCodeDirections keypad keypadInv (3, 2) code
in minimum $
map
( \d ->
let pairs = zip ('A' : d) d
in sum
[ shortestDirectionsPairwise
(dirKeypadInv M.! sC)
(dirKeypadInv M.! eC)
padDepth
| (sC, eC) <- pairs
]
)
initDirs
parseNum :: String -> Int
parseNum = read . filter isDigit
part1 :: [String] -> Int
part1 codes =
let nums = map parseNum codes
lens = map (`shortestPath` 2) codes
in sum (zipWith (*) nums lens)
part2 :: [String] -> Int
part2 codes =
let nums = map parseNum codes
lens = map (`shortestPath` 25) codes
in sum (zipWith (*) nums lens)
input :: String
input =
unlines
[ "789A",
"968A",
"286A",
"349A",
"170A"
]
main :: IO ()
main = do
let args = lines input
print (part1 args)
print (part2 args)
Blazing fast due to unsafe IO 🔥. This solution was translated from Python code I used for debugging.
Python debug code
from functools import cache
dir_keypad = [list(".^A"), list("<v>")]
dir_keypad_inv = {
k: (i, j) for i, row in enumerate(dir_keypad) for j, k in enumerate(row)
}
keypad = [
list("789"),
list("456"),
list("123"),
list(".0A"),
]
keypad_inv = {k: (i, j) for i, row in enumerate(keypad) for j, k in enumerate(row)}
def keypad_get(keypad, pos):
i, j = pos
return keypad[i][j]
def get_directions(cur_keypad, start, target):
q = [(start, "")]
def in_bounds(pos):
i, j = pos
return 0 <= i < len(cur_keypad) and 0 <= j < len(cur_keypad[0])
def neighbors(pos):
i, j = pos
directions = [(0, 1), (0, -1), (1, 0), (-1, 0)]
direction_chars = [">", "<", "v", "^"]
return [
((i + di, j + dj), dir)
for (di, dj), dir in zip(directions, direction_chars)
if in_bounds((i + di, j + dj)) and cur_keypad[i + di][j + dj] != "."
]
while True:
target_paths = [path for pos, path in q if pos == target]
if target_paths:
return target_paths
n = []
for p, path in q:
for neigh, dir in neighbors(p):
n.append((neigh, path + dir))
if not n:
raise Exception
q = n
def get_code_directions(cur_keypad, cur_keypad_inv, start, keys):
directions = [""]
start_c = cur_keypad[start[0]][start[1]]
for start_k, target_k in zip(start_c + keys, keys):
start, target = cur_keypad_inv[start_k], cur_keypad_inv[target_k]
new_dir = get_directions(cur_keypad, start, target)
new_directions = []
for d in directions:
for nd in new_dir:
new_directions.append(d + nd + "A")
directions = new_directions
return directions
@cache
def shortest_directions_pairwise(start, end, depth):
dirs = get_directions(dir_keypad, start, end)
dirs_with_activation = [d + "A" for d in dirs]
if depth == 1:
return min(len(d) for d in dirs_with_activation)
dir_pairs = [list(zip("A" + d, d)) for d in dirs_with_activation]
return min(
sum(
shortest_directions_pairwise(
dir_keypad_inv[start], dir_keypad_inv[end], depth - 1
)
for start, end in pair
)
for pair in dir_pairs
)
def shortest_path(code, n_directional_pads=2):
init_dirs = get_code_directions(keypad, keypad_inv, (3, 2), code)
minlen = float("inf")
for dir in init_dirs:
pairs = list(zip("A" + dir, dir))
minlen = min(
minlen,
sum(
shortest_directions_pairwise(
dir_keypad_inv[start], dir_keypad_inv[end], n_directional_pads
)
for start, end in pairs
),
)
return minlen
def parse_num(code):
return int("".join(filter(str.isdigit, code)))
def part1(codes):
nums = map(parse_num, codes)
path_lens = map(shortest_path, codes)
return sum(n * length for n, length in zip(nums, path_lens))
def part2(codes):
def s(c):
return shortest_path(c, 25)
nums = map(parse_num, codes)
path_lens = map(s, codes)
return sum(n * length for n, length in zip(nums, path_lens))
input = """789A
968A
286A
349A
170A"""
args = input.split("\n")
print(part1(args))
print(part2(args))
Day 22
import Data.Bits (xor)
import Data.List
import qualified Data.Map as Map
import Data.Ord (comparing)
import qualified Data.Set as Set
mix secret val = secret `xor` val
prune secret = secret `mod` 16777216
nextSecret secret =
let x1 = prune $ mix secret (64 * secret)
x2 = prune $ mix x1 (x1 `div` 32)
x3 = prune $ mix x2 (x2 * 2048)
in x3
secrets :: Int -> [Int]
secrets x = iterate nextSecret x
secret2k x = (secrets x) !! 2000
changes xs = zipWith (-) (tail xs) xs
slidingWindow (a : b : c : d : xs) = (a, b, c, d) : slidingWindow (b : c : d : xs)
slidingWindow _ = []
prices xs = map (`mod` 10) xs
changeMap n start =
let secrets' = take n $ secrets start
prices' = prices secrets'
changes' = changes prices'
changeWindows = slidingWindow changes'
in Map.fromList $ reverse $ zip changeWindows (drop 4 prices')
main = do
content <- lines <$> readFile "data22.txt"
let nums = map read content :: [Int]
print $ sum $ map secret2k nums
let changeMaps = map (changeMap 2000) nums
let allKeys = foldr Set.union Set.empty $ map Map.keysSet changeMaps
let totalBananas key = sum $ map (\m -> Map.findWithDefault 0 key m) changeMaps
let soldPrices = Set.toList allKeys
let maxKey = maximumBy (comparing totalBananas) soldPrices
putStrLn $ "Part 2: " ++ (show $ totalBananas maxKey)
This one was pretty straightforward. Solution is a bit slow though.
Day 23
import Control.Monad (guard)
import Data.List (isPrefixOf, nub, sort, sortOn)
import qualified Data.Map as M
import qualified Data.Set as S
type Graph = M.Map String (S.Set String)
fromEdges :: [(String, String)] -> Graph
fromEdges es =
M.fromListWith S.union $
concatMap (\(a, b) -> [(a, S.singleton b), (b, S.singleton a)]) es
triangles :: Graph -> [[String]]
triangles g =
nub $
sort
[ sort [a, b, c]
| a <- M.keys g,
b <- S.toList (g M.! a),
c <- S.toList (g M.! b),
c `S.member` (g M.! a)
]
bronKerbosch :: Graph -> S.Set String -> S.Set String -> S.Set String -> [S.Set String]
bronKerbosch g r p x
| S.null p && S.null x = [r]
| otherwise = concatMap expand candidates
where
unionPx = S.union p x
pivot =
if not (S.null unionPx)
then S.findMin unionPx
else error "Unexpected empty pivot"
pivotNeighbors = M.findWithDefault S.empty pivot g
candidates = S.difference p pivotNeighbors
expand v = bronKerbosch g (S.insert v r) (S.intersection (g M.! v) p) (S.intersection (g M.! v) x)
main :: IO ()
main = do
input <- lines <$> readFile "data23.txt"
let edges = [let (a, _ : b) = break (== '-') l in (a, b) | l <- input]
g = fromEdges edges
let tris = triangles g
validTris = filter (any (isPrefixOf "t")) tris
print $ length validTris
let allNodes = S.fromList (M.keys g)
cliques = bronKerbosch g S.empty allNodes S.empty
maxSize = maximum $ map S.size cliques
largestCliques = filter ((== maxSize) . S.size) cliques
password = sort $ S.toList $ head largestCliques
putStrLn $ concat $ zipWith (\i s -> if i == 0 then s else "," ++ s) [0 ..] password
I had not heard of the Bron Kerbosch algorithm before!