我正在用 Haskell 完成 Advent of Code 来学习这门语言。以下是我的解决方案。
第一天
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)
相当简洁，我觉得没法再改进了。
第二天
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))
这段代码同样简洁明了。
第三天
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
不如其他的那么优雅。我本可以使用正则表达式或解析包的。
第 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
-- 第一部分
print $ countAllDirections grid
-- 第二部分
print $ countMasXAllDirections grid
尽管代码行数较多，但我认为这个解决方案在概念上非常简单。
第 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
-- 第一部分
print middleSum
-- 第二部分
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)
Graph API 在这个问题中非常方便！
第六天
这是我的第一个解决方案：
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
但它太慢了。主要问题是 simulate 使用了不可变数组，这导致每次赋值都需要复制。可以通过使用可变数组来解决这个问题，尽管会增加复杂性：
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
这样可以在合理的时间内得到正确答案。
第 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)
-- 反转参数，因为数据是反转的
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
-- 反转以便优先级从左到右
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
-- 第一部分
print $ result
-- 第二部分
print $ result2
我喜欢这个解决方案，因为它展示了高阶函数的表现力。
第 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
-- 第一部分
placeAntinodes inBounds (p1, p2) = filter inBounds [p1 - dist, p2 + dist]
where
dist = p2 - p1
-- 第二部分
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
-- 第一部分
print $ length $ nub allAntinodes1
-- 第二部分
print $ length $ nub allAntinodes2
我希望能够重载 * 运算符以实现标量乘法。
第 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
我对 compressBlocks 的解决方案并不感到自豪。它既复杂又慢。也许这个问题不太适合函数式编程，但也可能是我自己的技能问题。
第 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)]
-- 这里我们关心的是可到达的 9 的数量，索引唯一
trailheadScore grid (i, j) = count9 grid $ nub $ dfs grid (i, j)
-- 这里我们关心的是到达任意 9 的路径数量，索引不唯一
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 $ "第一部分: " ++ (show score1)
putStrLn $ "第二部分: " ++ (show score2)
第一部分和第二部分只差几个字符，真是巧妙！
第 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
不幸的是，没有缓存的情况下，代码运行得不够快。
第 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)
第二部分花了我一些时间才想出来。不确定是否有更好的解决方案。
第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 "按钮 A: X+"
ax <- many1 digit
_ <- string ", Y+"
ay <- many1 digit
_ <- newline
_ <- string "按钮 B: X+"
bx <- many1 digit
_ <- string ", Y+"
by <- many1 digit
_ <- newline
_ <- string "奖品: 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 $ "第一部分: " ++ show (minTokenCost testCases)
let testCasesPart2 = map (\((ax, ay), (bx, by), (px, py)) -> ((ax, ay), (bx, by), (px + delta, py + delta))) testCases
putStrLn $ "第二部分: " ++ show (minTokenCost testCasesPart2)
由于这个问题简化为一个简单的线性代数问题，解决方案在概念上很容易。但在Haskell中手动编写矩阵操作很不方便。
第 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 $ "第一部分: " ++ (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 $ "第二部分: " ++ (show i)
第 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)
-- 在方向 dir 上移动位于 (i,j) 的箱子
moveBox :: Array Loc Char -> Loc -> Dir -> Array Loc Char
moveBox grid (i, j) dir
-- 如果我们向上移动，它可能位于
-- []
-- [] (向上移动)
-- [][]
-- [] (向上移动)
-- 在第一种情况下，我们移动上方的箱子，如果有空间则移动当前箱子
-- 在第二种情况下，我们移动两个箱子，然后如果有空间则移动当前箱子
| boxSpaceEmpty grid (i, j) dir =
if grid ! (i, j) /= '['
then
error "必须是左括号"
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 "必须是左括号"
| 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 "必须是左括号"
| 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
对这个解决方案并不感到自豪。它很混乱、冗长，而且第一部分并不需要可变数组。可能会回来改进它。
第 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 $ "最低分数: " ++ show minCost
let tileCount = countBestPathTiles grid start end minCost costFromStart costToEnd
putStrLn $ "最佳路径瓷砖数量: " ++ show tileCount
这一天的第二部分需要一些动态规划的技巧才能及时运行。我们计算从起点到每个瓷砖的最短距离以及从每个瓷砖到终点的最短距离。然后我们可以利用这些数据快速计算所有最优路径。
第 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 "无效的操作数"
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]
-- 解析初始寄存器值
parseRegs :: Parser Regs
parseRegs = do
string "寄存器 A: "
aVal <- read <$> many1 digit
newline
string "寄存器 B: "
bVal <- read <$> many1 digit
newline
string "寄存器 C: "
cVal <- read <$> many1 digit
many newline
return $ listArray (0, 2) [aVal, bVal, cVal]
-- 解析程序
parseProg :: Parser Prog
parseProg = do
string "程序: "
sepBy parseInst (char ',')
-- 解析单个指令
parseInst :: Parser Inst
parseInst = do
opcode <- read <$> many1 digit
char ','
operand <- read <$> many1 digit
return (opcode, operand)
-- 组合解析器，用于解析整个输入
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 "第一部分: "
putStrLn $ intercalate "," $ map show $ runProg prog regs
let flatProg = concat [[x, y] | (x, y) <- prog]
putStrLn $ "第二部分: " ++ show (minimum (dfs flatProg))
第二部分相当困难。暴力破解不起作用，所以我不得不手动检查程序并找到一种更聪明的搜索方法。由于我在 Haskell 中调试速度不够快（技术问题），我的解决方案直接翻译了我的 Python 调试代码。
Python 调试代码
from collections import defaultdict
def run_specific_program(A):
"""给定的程序，直接翻译成 Python 用于验证。"""
B = 0
C = 0
output = []
while True:
# 指令 1: bst 4 -> B = A % 8
# 获取 A 的最后 3 位
B = (A & 0b111) ^ 0b101
# 指令 2: bxl 5 -> B ^= 5
# B <- B ^ 0b101
# 指令 3: cdv 5 -> C = A // (2 ** B)
# 操作数 5 引用寄存器 B
C = A >> B
# C = A // (2 ** B)
# 指令 4: bxl 6 -> B ^= 6
# 0b110
# B ^= 0b110
# 指令 5: adv 3 -> A = A // 8
A = A >> 3
# A = A // 8
# 指令 6: bxc 6 -> B ^= C
# B ^= C
# 指令 7: out 5 -> 输出 B % 8
output.append(str((B ^ C ^ 0b110) & 0b111))
# 指令 8: jnz 0 -> 如果 A != 0，跳转到开头
if A == 0:
break # 停止程序
return ",".join(output)
def cycle(A):
"""程序的单次循环迭代，翻译成 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 只与 A 的前 10 位有关
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]:
# 根据最后 7 位找到所有可能的 A 的下 3 位
if prog_i == len(prog):
if (cur >> 3) == 0:
# 程序以 A == 0 结束
return [path]
else:
# 程序未及时终止
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)
第 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) -- 将 x,y 转换为 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 "无法找到出口"
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 ++ " 对已添加"
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
有点慢，但能运行。
第 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
学会了如何使用 State 单子。很酷！
第 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)
我喜欢这个解决方案——它非常函数式——但对于第二部分来说，它运行得很慢。
第 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 "未找到路径"
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)
由于使用了不安全的 IO 操作，速度极快 🔥。此解决方案是从我用于调试的 Python 代码翻译而来。
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))
第 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)
这道题相当直接，不过解决方案有点慢。
第 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
我之前从未听说过 Bron Kerbosch 算法！