Je fais AoC en Haskell pour apprendre le langage. Voici mes solutions.
Jour 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)
Assez propre, je ne pense pas pouvoir l’améliorer.
Jour 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 ("nombre d'éléments sûrs : " ++ (show nSafe))
print ("nombre d'éléments sûrs (amortissement) : " ++ (show nSafeDamp))
C’est également assez propre et direct.
Jour 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 avec drapeau: " ++ show total2
Pas aussi élégant que les autres. J’aurais probablement pu utiliser des expressions régulières ou un package de parsing.
Jour 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
-- Partie 1
print $ countAllDirections grid
-- Partie 2
print $ countMasXAllDirections grid
Bien que le nombre de lignes de code soit élevé, je pense que cette solution est conceptuellement très simple.
Jour 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
-- partie 1
print middleSum
-- partie 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)
L’API Graph était pratique pour ce problème !
Jour 6
Voici ma première 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
Mais elle était beaucoup trop lente. Le principal problème était que simulate utilisait des tableaux immuables,
ce qui nécessitait des copies à chaque assignation. Cela peut être corrigé en utilisant des tableaux mutables,
au prix d’une complexité accrue :
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
ce qui donne la bonne réponse en un temps raisonnable.
Jour 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)
-- inverser les arguments car les données sont inversées
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
-- inverser pour que la priorité soit de gauche à droite
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
-- partie 1
print $ result
-- partie 2
print $ result2
J’aime cette solution car elle montre à quel point les fonctions d’ordre supérieur peuvent être expressives.
Jour 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
-- Partie 1
placeAntinodes inBounds (p1, p2) = filter inBounds [p1 - dist, p2 + dist]
where
dist = p2 - p1
-- Partie 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
-- partie 1
print $ length $ nub allAntinodes1
-- partie 2
print $ length $ nub allAntinodes2
J’aimerais pouvoir surcharger l’opérateur * pour la multiplication scalaire.
Jour 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
Je ne suis pas très fier de la solution compressBlocks. Elle est compliquée et lente. Peut-être que ce problème
n’est pas adapté à la programmation fonctionnelle, mais cela pourrait aussi être une question de compétence de ma part.
Jour 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)]
-- Ici, nous nous intéressons au nombre de 9 atteignables, uniques en index
trailheadScore grid (i, j) = count9 grid $ nub $ dfs grid (i, j)
-- Ici, nous nous intéressons au nombre de façons d'atteindre un 9, pas unique en 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 $ "Partie 1: " ++ (show score1)
putStrLn $ "Partie 2: " ++ (show score2)
C’est sympa de voir que les parties 1 et 2 ne diffèrent que de quelques caractères !
Jour 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 $ "Partie 1: " ++ show result
let (result2, _) = foldl (\(acc, cache) x -> let (res, newCache) = blinkLen 75 x cache in (acc + res, newCache)) (0, cache) nums
putStrLn $ "Partie 2: " ++ show result2
Le code ne s’exécutait pas assez rapidement sans mise en cache, malheureusement.
Jour 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 $ "Partie 1: " ++ show (sum $ zipWith (*) areas perimeters)
let sides = map (nSides grid) regions
putStrLn $ "Partie 2: " ++ show (sum $ zipWith (*) areas sides)
Il m’a fallu un peu de temps pour comprendre la partie 2. Je ne suis pas sûr qu’il existe une meilleure solution.
Jour 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 "Bouton A: X+"
ax <- many1 digit
_ <- string ", Y+"
ay <- many1 digit
_ <- newline
_ <- string "Bouton B: X+"
bx <- many1 digit
_ <- string ", Y+"
by <- many1 digit
_ <- newline
_ <- string "Récompense: 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 $ "Partie 1: " ++ show (minTokenCost testCases)
let testCasesPart2 = map (\((ax, ay), (bx, by), (px, py)) -> ((ax, ay), (bx, by), (px + delta, py + delta))) testCases
putStrLn $ "Partie 2: " ++ show (minTokenCost testCasesPart2)
Comme cela se réduit à un simple problème d’algèbre linéaire, la solution est conceptuellement facile. Mais écrire des opérations matricielles à la main en Haskell est peu pratique.
Jour 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 $ "Partie 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 $ "Partie 2: " ++ (show i)
Jour 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)
-- déplacer la boîte à (i,j) dans la direction dir
moveBox :: Array Loc Char -> Loc -> Dir -> Array Loc Char
moveBox grid (i, j) dir
-- si on monte, cela peut être soit entre
-- []
-- [] (monte)
-- [][]
-- [] (monte)
-- dans le premier cas, on déplace la boîte supérieure et on déplace la boîte actuelle s'il y a de la place
-- dans le second cas, on déplace les deux boîtes puis la boîte actuelle s'il y a de la place
| boxSpaceEmpty grid (i, j) dir =
if grid ! (i, j) /= '['
then
error "doit être un crochet gauche"
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 "doit être un crochet gauche"
| 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 "doit être un crochet gauche"
| 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
Pas très fier de cette solution. C’est désordonné, long, et la première partie ne nécessitait pas de tableaux mutables. Je pourrais revenir et l’améliorer.
Jour 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 $ "Score minimum : " ++ show minCost
let tileCount = countBestPathTiles grid start end minCost costFromStart costToEnd
putStrLn $ "Nombre de tuiles du meilleur chemin : " ++ show tileCount
Celui-ci nécessitait quelques astuces de programmation dynamique pour que la partie 2 s’exécute dans les temps. Nous calculons les distances les plus courtes depuis le départ et jusqu’à la tuile d’arrivée pour chaque tuile. Nous pouvons ensuite utiliser cela pour calculer rapidement tous les chemins optimaux.
Jour 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 "Opérande invalide"
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]
-- Parseur pour les valeurs initiales des registres
parseRegs :: Parser Regs
parseRegs = do
string "Registre A: "
aVal <- read <$> many1 digit
newline
string "Registre B: "
bVal <- read <$> many1 digit
newline
string "Registre C: "
cVal <- read <$> many1 digit
many newline
return $ listArray (0, 2) [aVal, bVal, cVal]
-- Parseur pour le programme
parseProg :: Parser Prog
parseProg = do
string "Programme: "
sepBy parseInst (char ',')
-- Parseur pour une seule instruction
parseInst :: Parser Inst
parseInst = do
opcode <- read <$> many1 digit
char ','
operand <- read <$> many1 digit
return (opcode, operand)
-- Parseur combiné pour l'entrée complète
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 "Partie 1: "
putStrLn $ intercalate "," $ map show $ runProg prog regs
let flatProg = concat [[x, y] | (x, y) <- prog]
putStrLn $ "Partie 2: " ++ show (minimum (dfs flatProg))
La partie 2 était assez difficile. La force brute n’a pas fonctionné, donc j’ai dû inspecter manuellement le programme et trouver une méthode de recherche plus intelligente. Je n’ai pas non plus pu déboguer assez rapidement avec Haskell (problème de compétence), donc ma solution est une traduction directe de mon code de débogage en Python.
Code de débogage en Python
from collections import defaultdict
def run_specific_program(A):
"""Le programme donné, directement traduit en Python pour validation."""
B = 0
C = 0
output = []
while True:
# Instruction 1: bst 4 -> B = A % 8
# obtenir les 3 derniers bits de A
B = (A & 0b111) ^ 0b101
# Instruction 2: bxl 5 -> B ^= 5
# B <- B ^ 0b101
# Instruction 3: cdv 5 -> C = A // (2 ** B)
# L'opérande 5 fait référence au registre 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 -> sortie B % 8
output.append(str((B ^ C ^ 0b110) & 0b111))
# Instruction 8: jnz 0 -> si A != 0, sauter au début
if A == 0:
break # Arrêter le programme
return ",".join(output)
def cycle(A):
"""Une seule itération de boucle du programme donné, traduit en 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 est uniquement une fonction des 10 premiers bits de 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]:
# trouver tous les prochains 3 bits possibles de A étant donné les 7 derniers
if prog_i == len(prog):
if (cur >> 3) == 0:
# le programme s'est terminé avec A == 0
return [path]
else:
# le programme ne s'est pas terminé à temps
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)
Jour 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 $ "Partie 1: " ++ (show len)
Nothing -> error "impossible de trouver la sortie"
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 ++ " paires ajoutées"
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
Un peu lent, mais ça fonctionne.
Jour 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 $ "Partie 1: " ++ (show $ length $ filter (\t -> countPossible patterns t > 0) towels)
putStrLn $ "Partie 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
J’ai appris à utiliser la monade State. Cool !
## Jour 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 $ "Partie 1 : " ++ (show $ computeSavings grid cheatTime thresh)
let cheatTime2 = 20
putStrLn $ "Partie 2 : " ++ (show $ computeSavings grid cheatTime2 thresh)
J’aime cette solution—elle est très fonctionnelle— mais elle est lente pour la partie 2.
Jour 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 "Aucun chemin trouvé"
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)
Extrêmement rapide grâce à l’IO non sécurisée 🔥. Cette solution a été traduite du code Python que j’ai utilisé pour le débogage.
Code de débogage Python
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))
Jour 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 $ "Partie 2: " ++ (show $ totalBananas maxKey)
Celui-ci était assez simple. La solution est un peu lente cependant.
Jour 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 "Pivot vide inattendu"
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
Je n’avais jamais entendu parler de l’algorithme de Bron-Kerbosch auparavant !