fuxino/AdventOfCode2024
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Create stack project

Browse Source
This commit is contained in:
Daniele Fucini
2024-12-14 19:15:28 +01:00
parent aa1088a215
commit 19359d2992
31 changed files with 373 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
src/Day1/Puzzle1.hs Normal file
View File

@@ -0,0 +1,13 @@
module Day1.Puzzle1 (day1_1) where
import Data.List (transpose, sort)
listDistance :: [Int] -> [Int] -> Int
listDistance xs ys = sum $ map abs $ zipWith (-) (sort xs) (sort ys)
day1_1 :: IO ()
day1_1 = do
contents <- lines <$> readFile "input/day1.txt"
let [x, y] = transpose $ map read . words <$> contents
putStrLn $ "Day 1, Puzzle 1 solution: "
++ show (listDistance x y)

15
src/Day1/Puzzle2.hs Normal file
View File

@@ -0,0 +1,15 @@
module Day1.Puzzle2 (day1_2) where
import Data.List (transpose, sort, group, uncons)
import Data.Maybe (fromJust)
similarityScore :: [Int] -> [Int] -> Int
similarityScore xs ys = let elemsY = [ (fst . fromJust $ uncons y, length y) | y <- (group . sort) ys ]
in sum [ x * snd y | x <- xs, y <- elemsY, x == fst y ]
day1_2 :: IO ()
day1_2 = do
contents <- lines <$> readFile "input/day1.txt"
let [x, y] = transpose $ map read . words <$> contents
putStrLn $ "Day 1, Puzzle 2 solution: "
++ show (similarityScore x y)

34
src/Day10/Puzzle1.hs Normal file
View File

@@ -0,0 +1,34 @@
module Day10.Puzzle1 (day10_1) where
import Data.Char (digitToInt)
import Data.List (uncons)
import Data.List.Split (chunksOf)
import Data.Maybe (fromJust)
import Data.Graph (graphFromEdges, path, vertices)
type Coords = (Int, Int)
type V = (String, Int)
getValue :: [[V]] -> Coords -> V
getValue grid (i, j) = grid !! i !! j
getEdges :: [[V]] -> Coords -> [Int]
getEdges grid (i, j) = let value = fst $ grid !! i !! j
adjI = filter (\x -> fst x >= 0 && fst x < length grid && snd x >= 0 && snd x < length (fst . fromJust $ uncons grid)) [ (i, j + 1), (i + 1, j), (i, j - 1), (i - 1, j) ]
in [ snd x | x <- map (getValue grid) adjI, digitToInt (fst . fromJust $ uncons value) == digitToInt (fst . fromJust $ uncons (fst x)) - 1 ]
listVertices :: [String] -> [[V]]
listVertices grid = let l = length $ fst . fromJust $ uncons grid
in chunksOf l $ zip (map (:[]) (concat grid)) [0..]
day10_1 :: IO ()
day10_1 = do
contents <- lines <$> readFile "input/day10.txt"
let grid = listVertices contents
edgeCoords = [ (x, y) | x <- [0..length grid -1], y <- [0..length (fst . fromJust $ uncons grid) - 1] ]
edgeList = [ (x, y, z) | ((x, y), z) <- zip (concat grid) (map (getEdges grid) edgeCoords) ]
(graph, nodeFromVertex, _) = graphFromEdges edgeList
startList = [ x | (_, x, _) <- filter (\(x, _, _) -> x == "0") $ map nodeFromVertex $ vertices graph ]
endList = [ x | (_, x, _) <- filter (\(x, _, _) -> x == "9") $ map nodeFromVertex $ vertices graph ]
paths = filter id $ [ path graph x y | x <- startList, y <- endList ]
putStrLn $ "Day 10, Puzzle 1 solution: " ++ show (length paths)

21
src/Day11/Puzzle1.hs Normal file
View File

@@ -0,0 +1,21 @@
module Day11.Puzzle1 (day11_1) where
import qualified Data.Map.Strict as M
blinkStone :: (Int, Int) -> [(Int, Int)]
blinkStone (0, n) = [(1, n)]
blinkStone (s, n) = let ss = show s
nDigit = length ss
in if even nDigit
then zip (map read [take (nDigit `div` 2) ss, drop (nDigit `div` 2) ss]) [n, n]
else [(s * 2024, n)]
blink :: Int -> M.Map Int Int -> M.Map Int Int
blink 0 m = m
blink n m = blink (n - 1) $ M.fromListWith (+) $ concatMap blinkStone $ M.toList m
day11_1 :: IO ()
day11_1 = do
contents <- M.fromListWith (+) . flip zip (repeat 1) . map read . words <$> readFile "input/day11.txt"
putStrLn $ "Day 11, Puzzle 1 solution: "
++ show (M.foldl (+) 0 $ blink 25 contents)

21
src/Day11/Puzzle2.hs Normal file
View File

@@ -0,0 +1,21 @@
module Day11.Puzzle2 (day11_2) where
import qualified Data.Map.Strict as M
blinkStone :: (Int, Int) -> [(Int, Int)]
blinkStone (0, n) = [(1, n)]
blinkStone (s, n) = let ss = show s
nDigit = length ss
in if even nDigit
then zip (map read [take (nDigit `div` 2) ss, drop (nDigit `div` 2) ss]) [n, n]
else [(s * 2024, n)]
blink :: Int -> M.Map Int Int -> M.Map Int Int
blink 0 m = m
blink n m = blink (n - 1) $ M.fromListWith (+) $ concatMap blinkStone $ M.toList m
day11_2 :: IO ()
day11_2 = do
contents <- M.fromListWith (+) . flip zip (repeat 1) . map read . words <$> readFile "input/day11.txt"
putStrLn $ "Day 11, Puzzle 2 solution: "
++ show (M.foldl (+) 0 $ blink 75 contents)

40
src/Day12/Puzzle1.hs Normal file
View File

@@ -0,0 +1,40 @@
module Day12.Puzzle1 (day12_1) where
import Data.List (uncons)
import Data.List.Split (chunksOf)
import Data.Maybe (fromJust)
import Data.Graph (Tree, Vertex, graphFromEdges, scc)
import Data.Foldable (toList)
type Coords = (Int, Int)
type V = (String, Int)
getValue :: [[V]] -> Coords -> V
getValue grid (i, j) = grid !! i !! j
getEdges :: [[V]] -> Coords -> [Int]
getEdges grid (i, j) = let value = fst $ grid !! i !! j
adjI = filter (\x -> fst x >= 0 && fst x < length grid && snd x >= 0 && snd x < length (fst . fromJust $ uncons grid)) [ (i, j + 1), (i + 1, j), (i, j - 1), (i - 1, j) ]
in [ snd x | x <- map (getValue grid) adjI, (fst . fromJust $ uncons value) == (fst . fromJust $ uncons (fst x)) ]
listVertices :: [String] -> [[V]]
listVertices grid = let l = length $ fst . fromJust $ uncons grid
in chunksOf l $ zip (map (:[]) (concat grid)) [0..]
calculatePerimeter :: (Vertex -> (String, Vertex, [Vertex])) -> Tree Vertex -> Int
calculatePerimeter nodeFromVertex p = let edges = concat [ x | (_, _, x) <- toList $ fmap nodeFromVertex p ]
area = 4 * length p
in area - length edges
day12_1 :: IO ()
day12_1= do
contents <- lines <$> readFile "input/day12.txt"
let grid = listVertices contents
edgeCoords = [ (x, y) | x <- [0..length grid -1], y <- [0..length (fst . fromJust $ uncons grid) - 1] ]
edgeList = [ (x, y, z) | ((x, y), z) <- zip (concat grid) (map (getEdges grid) edgeCoords) ]
(graph, nodeFromVertex, _) = graphFromEdges edgeList
plots = scc graph
areas = map length plots
perimeters = map (calculatePerimeter nodeFromVertex) plots
putStrLn $ "Day 12, Puzzle 1 solution: "
++ show (sum $ zipWith (*) areas perimeters)

36
src/Day13/Puzzle1.hs Normal file
View File

@@ -0,0 +1,36 @@
module Day13.Puzzle1 (day13_1) where
import Data.Char (isDigit)
import Data.List (uncons)
import Data.List.Split (splitOn, chunksOf)
import Data.Matrix (Matrix, fromLists, toList, rref, zero)
import Data.Either (fromRight)
import Data.Maybe (mapMaybe, fromJust)
isAlmostInt :: (RealFrac a) => a -> Bool
isAlmostInt x = let diff = x - fromInteger (round x)
in abs diff < 0.001
getMatrix :: (Read a) => String -> Matrix a
getMatrix s = let nValues = map (map read . splitOn ",") . splitOn ":" . drop 1 $ filter (\x -> isDigit x || x == ',' || x == ':') s
eq1 = map (fst . fromJust . uncons) nValues
eq2 = map last nValues
in fromLists [eq1, eq2]
solve :: (RealFrac a) => Matrix a -> Maybe [a]
solve eqSystem = let rowEchelonList = toList . fromRight (zero 1 1) $ rref eqSystem
solutions = [ rowEchelonList !! 2, rowEchelonList !! 5 ]
in if all isAlmostInt solutions
then Just solutions
else Nothing
cost :: [Int] -> Int
cost [x, y] = 3 * x + y
day13_1 :: IO ()
day13_1 = do
contents <- map concat . chunksOf 4 . lines <$> readFile "input/day13.txt"
let eqSystems = map getMatrix contents
solutions = (map . map) round $ mapMaybe solve eqSystems
putStrLn $ "Day 13, Puzzle 1 solution: "
++ show (sum $ map cost solutions)

39
src/Day13/Puzzle2.hs Normal file
View File

@@ -0,0 +1,39 @@
module Day13.Puzzle2 (day13_2) where
import Data.Char (isDigit)
import Data.List (uncons)
import Data.List.Split (splitOn, chunksOf)
import Data.Matrix (Matrix, fromLists, toList, rref, zero)
import Data.Either (fromRight)
import Data.Maybe (mapMaybe, fromJust)
isAlmostInt :: (RealFrac a) => a -> Bool
isAlmostInt x = let diff = x - fromInteger (round x)
in abs diff < 0.001
multRes :: (Num a) => [a] -> [a]
multRes [x, y, z] = [x, y, z + 10000000000000]
getMatrix :: (Num a, Read a) => String -> Matrix a
getMatrix s = let nValues = map (map read . splitOn ",") . splitOn ":" . drop 1 $ filter (\x -> isDigit x || x == ',' || x == ':') s
eq1 = multRes $ map (fst . fromJust . uncons) nValues
eq2 = multRes $ map last nValues
in fromLists [eq1, eq2]
solve :: (RealFrac a) => Matrix a -> Maybe [a]
solve eqSystem = let rowEchelonList = toList . fromRight (zero 1 1) $ rref eqSystem
solutions = [ rowEchelonList !! 2, rowEchelonList !! 5 ]
in if all isAlmostInt solutions
then Just solutions
else Nothing
cost :: [Int] -> Int
cost [x, y] = 3 * x + y
day13_2 :: IO ()
day13_2 = do
contents <- map concat . chunksOf 4 . lines <$> readFile "input/day13.txt"
let eqSystems = map getMatrix contents
solutions = (map . map) round $ mapMaybe solve eqSystems
putStrLn $ "Day 13, Puzzle 2 solution: "
++ show (sum $ map cost solutions)

45
src/Day14/Puzzle1.hs Normal file
View File

@@ -0,0 +1,45 @@
module Day14.Puzzle1 (day14_1) where
import Data.Char (isDigit)
import Data.List.Split (splitOn)
type Position = (Int, Int)
type Velocity = (Int, Int)
type Robot = (Position, Velocity)
readRobot :: String -> Robot
readRobot s = let [ps, vs] = splitOn " " s
[px, py] = map read . splitOn "," $ filter (\x -> isDigit x || x == ',' || x == '-') ps
[vx, vy] = map read . splitOn "," $ filter (\x -> isDigit x || x == ',' || x == '-') vs
in ((px, py), (vx, vy))
moveRobot :: Int -> Robot -> Robot
moveRobot 0 r = r
moveRobot n r = let (px, py) = fst r
(vx, vy) = snd r
in moveRobot (n - 1) (((px + vx) `mod` 101, (py + vy) `mod` 103), (vx, vy))
quadrant :: Robot -> Int
quadrant r
| fst p `elem` [0..49] &&
snd p `elem` [0..50] = 0
| fst p `elem` [51..100] &&
snd p `elem` [0..50] = 1
| fst p `elem` [0..49] &&
snd p `elem` [52..102] = 2
| fst p `elem` [51..100] &&
snd p `elem` [52..102] = 3
| otherwise = -1
where p = fst r
day14_1 :: IO ()
day14_1= do
contents <- lines <$> readFile "input/day14.txt"
let robots = map readRobot contents
robots' = map (moveRobot 100) robots
firstQ = length $ filter (\r -> quadrant r == 0) robots'
secondQ = length $ filter (\r -> quadrant r == 1) robots'
thirdQ = length $ filter (\r -> quadrant r == 2) robots'
fourthQ = length $ filter (\r -> quadrant r == 3) robots'
putStrLn $ "Day 14, Puzzle 1 solution: "
++ show (firstQ * secondQ * thirdQ * fourthQ)

17
src/Day2/Puzzle1.hs Normal file
View File

@@ -0,0 +1,17 @@
module Day2.Puzzle1 (day2_1) where
import Data.List (sort, sortBy)
import Data.Ord
isSafe :: [Int] -> Bool
isSafe xs = (isAscending xs || isDescending xs) && maximum distances <= 3 && minimum distances >= 1
where isAscending xs = xs == sort xs
isDescending xs = xs == sortBy (comparing Down) xs
distances = map abs $ zipWith (-) xs (drop 1 xs)
day2_1 :: IO ()
day2_1 = do
contents <- lines <$> readFile "input/day2.txt"
let reports = map read . words <$> contents
putStrLn $ "Day 2, Puzzle 1 solution: "
++ show (length $ filter isSafe reports)

22
src/Day2/Puzzle2.hs Normal file
View File

@@ -0,0 +1,22 @@
module Day2.Puzzle2 (day2_2) where
import Data.List (sort, sortBy, inits, tails)
import Data.Ord
isSafe :: [Int] -> Bool
isSafe xs = (isAscending xs || isDescending xs) && maximum distances <= 3 && minimum distances >= 1
where isAscending xs = xs == sort xs
isDescending xs = xs == sortBy (comparing Down) xs
distances = map abs $ zipWith (-) xs (drop 1 xs)
removeLevel :: [Int] -> [[Int]]
removeLevel xs = zipWith (++) ys zs
where ys = map init $ drop 1 (inits xs)
zs = map (drop 1) $ init (tails xs)
day2_2 :: IO ()
day2_2 = do
contents <- lines <$> readFile "input/day2.txt"
let reports = map read . words <$> contents
putStrLn $ "Day 2, Puzzle 2 solution: "
++ show (length . filter (any isSafe) $ map removeLevel reports)

16
src/Day3/Puzzle1.hs Normal file
View File

@@ -0,0 +1,16 @@
module Day3.Puzzle1 (day3_1) where
import Data.List.Split (splitOn)
import Data.Char (isDigit)
import Text.Regex.TDFA (getAllTextMatches, (=~))
sumMul :: [String] -> Int
sumMul xs = let vals = map (splitOn "," . filter (`elem` "0123456789,")) xs
in sum $ map (product . map read) vals
day3_1 :: IO ()
day3_1 = do
contents <- readFile "input/day3.txt"
let mults = getAllTextMatches (contents =~ "mul\\([0-9]+,[0-9]+\\)") :: [String]
putStrLn $ "Day 3, Puzzle 1 solution: "
++ show (sumMul mults)

20
src/Day3/Puzzle2.hs Normal file
View File

@@ -0,0 +1,20 @@
module Day3.Puzzle2 (day3_2) where
import Data.List (isPrefixOf)
import Data.List.Split (split, splitOn, startsWith)
import Data.Char (isDigit)
import Text.Regex.TDFA (getAllTextMatches, (=~))
sumMul :: [String] -> Int
sumMul xs = let vals = map (splitOn "," . filter (`elem` "0123456789,")) xs
in sum $ map (product . map read) vals
filterDonts :: [String] -> String
filterDonts = concat . filter (not . isPrefixOf "don't()") . concatMap (split (startsWith "do()"))
day3_2 :: IO()
day3_2 = do
contents <- split (startsWith "don't()") <$> readFile "input/day3.txt"
let mults = getAllTextMatches (filterDonts contents =~ "mul\\([0-9]+,[0-9]+\\)") :: [String]
putStrLn $ "Day 3, Puzzle 2 solution: "
++ show (sumMul mults)

25
src/Day4/Puzzle1.hs Normal file
View File

@@ -0,0 +1,25 @@
module Day4.Puzzle1 (day4_1) where
import Data.List (transpose, isPrefixOf)
diagonals :: [String] -> [String]
diagonals xs = diagonals' xs ++ diagonals' ((transpose . reverse) xs)
where diagonals' xs = transpose (zipWith drop [0..] xs)
++ transpose (zipWith drop [1..] (transpose xs))
countOccurrences :: String -> [String] -> Int
countOccurrences word text = sum (map (countOccurrences' word) text) + sum (map (countOccurrences' word . reverse) text)
+ sum (map (countOccurrences' word) cols) + sum (map (countOccurrences' word . reverse) cols)
+ sum (map (countOccurrences' word) diags) + sum (map (countOccurrences' word . reverse) diags)
where cols = transpose text
diags = diagonals text
countOccurrences' _ [] = 0
countOccurrences' word text@(_:rest) = if word `isPrefixOf` text
then 1 + countOccurrences' word rest
else countOccurrences' word rest
day4_1 :: IO ()
day4_1 = do
contents <- lines <$> readFile "input/day4.txt"
putStrLn $ "Day 4, Puzzle 1 solution: "
++ show (countOccurrences "XMAS" contents)

29
src/Day4/Puzzle2.hs Normal file
View File

@@ -0,0 +1,29 @@
module Day4.Puzzle2 (day4_2) where
import Data.List (transpose, isPrefixOf, tails)
diagonals :: [String] -> [String]
diagonals xs = diagonals' xs ++ diagonals' ((transpose . reverse) xs)
where diagonals' xs = transpose (zipWith drop [0..] xs)
++ transpose (zipWith drop [1..] (transpose xs))
countOccurrences :: String -> [String] -> Int
countOccurrences word text = sum (map (countOccurrences' word) diags) + sum (map (countOccurrences' word . reverse) diags)
where diags = diagonals text
countOccurrences' _ [] = 0
countOccurrences' word text@(_:rest) = if word `isPrefixOf` text
then 1 + countOccurrences' word rest
else countOccurrences' word rest
submatricesVert :: Int -> [String] -> [[String]]
submatricesVert _ [] = []
submatricesVert _ [xs] = []
submatricesVert _ [xs, ys] = []
submatricesVert n matrix@(xs:xxs) = submatrix matrix ++ submatricesVert n xxs
where submatrix matrix = [take n $ map (take n) matrix]
day4_2 :: IO ()
day4_2 = do
contents <- lines <$> readFile "input/day4.txt"
let xmas = length . filter (\x -> countOccurrences "MAS" x == 2) . concatMap (submatricesVert 3) . transpose $ map tails contents
putStrLn $ "Day 4, Puzzle 2 solution: " ++ show xmas

20
src/Day5/Puzzle1.hs Normal file
View File

@@ -0,0 +1,20 @@
module Day5.Puzzle1 (day5_1) where
import Data.List.Split (splitOn)
isSorted :: [(String, String)] -> [String] -> Bool
isSorted rules [x] = True
isSorted rules (x:xs) = let after = [ p | (p, n) <- rules, n == x ]
in not (any (`elem` after) xs) && isSorted rules xs
getMiddle :: [String] -> String
getMiddle xs = xs !! (length xs `div` 2)
day5_1 :: IO ()
day5_1 = do
contents <- map (splitOn "|") . lines <$> readFile "input/day5.txt"
let rules = [ (x, y) | [x, y] <- takeWhile (/= [""]) contents ]
updates = concatMap (map (splitOn ",")) . drop 1 $ dropWhile (/= [""]) contents
sorted = filter (isSorted rules) updates
putStrLn $ "Day 5, Puzzle 1 solution: "
++ show (sum $ map (read . getMiddle) sorted)

28
src/Day5/Puzzle2.hs Normal file
View File

@@ -0,0 +1,28 @@
module Day5.Puzzle2 (day5_2) where
import Data.List ((\\))
import Data.List.Split (splitOn)
isSorted :: [(Int, Int)] -> [Int] -> Bool
isSorted rules [x] = True
isSorted rules (x:xs) = let after = [ p | (p, n) <- rules, n == x ]
in not (any (`elem` after) xs) && isSorted rules xs
getMiddle :: [Int] -> Int
getMiddle xs = xs !! (length xs `div` 2)
sortOnRules :: [(Int, Int)] -> [Int] -> [Int]
sortOnRules _ [] = []
sortOnRules rules (x:xs) = sortOnRules rules beforeArray ++ [x] ++ sortOnRules rules afterArray
where afterArray = xs \\ before
beforeArray = xs \\ afterArray
before = [ p | (p, n) <- rules, n == x ]
day5_2 :: IO ()
day5_2 = do
contents <- map (splitOn "|") . lines <$> readFile "input/day5.txt"
let rules = [ (read x, read y) | [x, y] <- takeWhile (/= [""]) contents ]
unsorted = filter (not . isSorted rules) . map (map read) $ concatMap (map (splitOn ",")) . drop 1 $ dropWhile (/= [""]) contents
fixUnsorted = map (sortOnRules rules) unsorted
putStrLn $ "Day 5, Puzzle 2 solution: "
++ show (sum $ map getMiddle fixUnsorted)

68
src/Day6/Puzzle1.hs Normal file
View File

@@ -0,0 +1,68 @@
module Day6.Puzzle1 (day6_1) where
import Data.List (elemIndex, uncons)
import Data.Maybe (isJust, fromMaybe, fromJust)
type Grid = [String]
type Position = (Int, Int)
data Direction = U | R | D | L deriving Eq
getDirection :: Char -> Direction
getDirection '^' = U
getDirection '>' = R
getDirection 'v' = D
getDirection '<' = L
getStartPosition:: Char -> Grid -> Position
getStartPosition c grid = (x, y)
where x = fromMaybe (-1) . elemIndex True . map (isJust . elemIndex c) $ grid
y = if x == -1 then -1 else fromMaybe (-1) . elemIndex c $ grid !! x
getGridVal :: Position -> Grid -> Char
getGridVal (x, y) grid = (grid !! x) !! y
isInside :: Position -> Grid -> Bool
isInside (x, y) grid = x >= 0 && y >= 0 && x < length grid && y < length (fst . fromJust $ uncons grid)
getNextPosition :: Position -> Direction -> Grid -> (Position, Direction)
getNextPosition (x, y) U grid = let newPos = (x - 1, y)
gridVal = getGridVal newPos grid
in if newPos `isInside` grid && gridVal == '#'
then getNextPosition (x, y) R grid
else (newPos, U)
getNextPosition (x, y) R grid = let newPos = (x, y + 1)
gridVal = getGridVal newPos grid
in if newPos `isInside` grid && gridVal == '#'
then getNextPosition (x, y) D grid
else (newPos, R)
getNextPosition (x, y) D grid = let newPos = (x + 1, y)
gridVal = getGridVal newPos grid
in if newPos `isInside` grid && gridVal == '#'
then getNextPosition (x, y) L grid
else (newPos, D)
getNextPosition (x, y) L grid = let newPos = (x, y - 1)
gridVal = getGridVal newPos grid
in if newPos `isInside` grid && gridVal == '#'
then getNextPosition (x, y) U grid
else (newPos, L)
markVisited :: Position -> Char -> Grid -> Grid
markVisited (x, y) c grid = let row = grid !! x
newRow = take y row ++ [c] ++ drop (y + 1) row
in take x grid ++ [newRow] ++ drop (x + 1) grid
visitGrid :: Position -> Direction -> Grid -> Grid
visitGrid (x, y) direction grid = let newGrid = markVisited (x, y) 'X' grid
(nextPosition, newDirection) = getNextPosition (x, y) direction grid
in if nextPosition `isInside` newGrid
then visitGrid nextPosition newDirection newGrid
else newGrid
day6_1 :: IO ()
day6_1 = do
contents <- lines <$> readFile "input/day6.txt"
let (x, y) = (\w x y z -> fst . fromJust $ uncons $ filter ((>= 0) . fst) [w, x, y, z]) <$> getStartPosition 'v' <*> getStartPosition '^'
<*> getStartPosition '<' <*> getStartPosition '>' $ contents
direction = getDirection $ (contents !! x) !! y
putStrLn $ "Day 6, Puzzle 1 solution: "
++ show (length . filter (== 'X') . concat $ visitGrid (x, y) direction contents)

91
src/Day6/Puzzle2.hs Normal file
View File

@@ -0,0 +1,91 @@
module Day6.Puzzle2 (day6_2) where
import Data.List (elemIndex, uncons)
import Data.Maybe (isJust, fromMaybe, fromJust)
type Grid = [String]
type Position = (Int, Int)
data Direction = U | R | D | L deriving Eq
getDirection :: Char -> Direction
getDirection '^' = U
getDirection '>' = R
getDirection 'v' = D
getDirection '<' = L
printDirection :: Direction -> Char
printDirection U = '^'
printDirection R = '>'
printDirection D = 'v'
printDirection L = '<'
getStartPosition :: Char -> Grid -> Position
getStartPosition c grid = (x, y)
where x = fromMaybe (-1) . elemIndex True . map (isJust . elemIndex c) $ grid
y = if x == -1 then -1 else fromMaybe (-1) . elemIndex c $ grid !! x
getGridVal :: Position -> Grid -> Char
getGridVal (x, y) grid = (grid !! x) !! y
isInside :: Position -> Grid -> Bool
isInside (x, y) grid = x >= 0 && y >= 0 && x < length grid && y < length (fst . fromJust $ uncons grid)
getNextPosition :: Position -> Direction -> Grid -> (Position, Direction)
getNextPosition (x, y) U grid = let newPos = (x - 1, y)
gridVal = getGridVal newPos grid
in if newPos `isInside` grid && gridVal == '#'
then getNextPosition (x, y) R grid
else (newPos, U)
getNextPosition (x, y) R grid = let newPos = (x, y + 1)
gridVal = getGridVal newPos grid
in if newPos `isInside` grid && gridVal == '#'
then getNextPosition (x, y) D grid
else (newPos, R)
getNextPosition (x, y) D grid = let newPos = (x + 1, y)
gridVal = getGridVal newPos grid
in if newPos `isInside` grid && gridVal == '#'
then getNextPosition (x, y) L grid
else (newPos, D)
getNextPosition (x, y) L grid = let newPos = (x, y - 1)
gridVal = getGridVal newPos grid
in if newPos `isInside` grid && gridVal == '#'
then getNextPosition (x, y) U grid
else (newPos, L)
markVisited :: Position -> Char -> Grid -> Grid
markVisited (x, y) c grid = let gridVal = getGridVal (x, y) grid
in if gridVal == '#' || gridVal == '^' || gridVal == '>' || gridVal == 'v' || gridVal == '<'
then grid
else let row = grid !! x
newRow = take y row ++ [c] ++ drop (y + 1) row
in take x grid ++ [newRow] ++ drop (x + 1) grid
visitGrid :: Position -> Direction -> Grid -> Grid
visitGrid (x, y) direction grid = let newGrid = markVisited (x, y) 'X' grid
(nextPosition, newDirection) = getNextPosition (x, y) direction grid
in if nextPosition `isInside` newGrid
then visitGrid nextPosition newDirection newGrid
else newGrid
checkGridLoop :: Position -> Direction -> Grid -> Bool
checkGridLoop startPosition direction grid = let (nextPosition, newDirection) = getNextPosition startPosition direction grid
newDirectionChar = printDirection newDirection
newGrid = markVisited nextPosition newDirectionChar grid
in (nextPosition `isInside` grid)
&& ((getGridVal nextPosition grid == newDirectionChar)
|| checkGridLoop nextPosition newDirection newGrid)
setGridObstacles :: Position -> Grid -> [Grid]
setGridObstacles startPosition grid = let positions = [ (x, y) | x <- [0..(length grid - 1)], y <- [0..(length (fst . fromJust $ uncons grid) - 1)], (x, y) /= startPosition, getGridVal (x, y) grid == 'X' ]
in zipWith (`markVisited` '#') positions (replicate (length positions) grid)
day6_2 :: IO ()
day6_2 = do
contents <- lines <$> readFile "input/day6.txt"
let (x, y) = (\w x y z -> fst . fromJust $ uncons $ filter ((>= 0) . fst) [w, x, y, z]) <$> getStartPosition 'v' <*> getStartPosition '^'
<*> getStartPosition '<' <*> getStartPosition '>' $ contents
direction = getDirection $ (contents !! x) !! y
grid = visitGrid (x, y) direction contents
gridObstacles = setGridObstacles (x, y) grid
loops = filter (checkGridLoop (x, y) direction) gridObstacles
putStrLn $ "Day 6, Puzzle 2 solution: " ++ show (length loops)

23
src/Day7/Puzzle1.hs Normal file
View File

@@ -0,0 +1,23 @@
module Day7.Puzzle1 (day7_1) where
import Data.List (transpose)
import Data.List.Split (splitOn)
type Equation = (Int, [Int])
isSolvable :: Int -> Equation -> Bool
isSolvable cur (result, []) = cur == result
isSolvable cur (result, [x]) = cur + x == result || cur * x == result
isSolvable cur (result, x:y:ys) = isSolvable (cur + x + y) (result, ys)
|| isSolvable ((cur + x) * y) (result, ys)
|| isSolvable (cur * x + y) (result, ys)
|| isSolvable (cur * x * y) (result, ys)
day7_1 :: IO ()
day7_1 = do
[x, y] <- transpose . map (splitOn ":") . lines <$> readFile "input/day7.txt"
let results = map read x
values = map read <$> map words y
equations = zip results values
putStrLn $ "Day 7, Puzzle 1 solution: "
++ show (sum . map fst $ filter (isSolvable 0) equations)

31
src/Day7/Puzzle2.hs Normal file
View File

@@ -0,0 +1,31 @@
module Day7.Puzzle2 (day7_2) where
import Data.List (transpose)
import Data.List.Split (splitOn)
type Equation = (Int, [Int])
concatInt :: Int -> Int -> Int
concatInt x y = read $ show x ++ show y
isSolvable :: Int -> Equation -> Bool
isSolvable cur (result, []) = cur == result
isSolvable cur (result, [x]) = cur + x == result || cur * x == result || cur `concatInt` x == result
isSolvable cur (result, x:y:ys) = isSolvable (cur + x + y) (result, ys)
|| isSolvable ((cur + x) * y) (result, ys)
|| isSolvable ((cur + x) `concatInt` y) (result, ys)
|| isSolvable (cur * x + y) (result, ys)
|| isSolvable (cur * x * y) (result, ys)
|| isSolvable ((cur * x) `concatInt` y) (result, ys)
|| isSolvable ((cur `concatInt` x) + y) (result, ys)
|| isSolvable ((cur `concatInt` x) * y) (result, ys)
|| isSolvable ((cur `concatInt` x) `concatInt` y) (result, ys)
day7_2 :: IO ()
day7_2 = do
[x, y] <- transpose . map (splitOn ":") . lines <$> readFile "input/day7.txt"
let results = map read x
values = map read <$> map words y
equations = zip results values
putStrLn $ "Day 7, Puzzle 2 solution: "
++ show (sum . map fst $ filter (isSolvable 0) equations)

40
src/Day8/Puzzle1.hs Normal file
View File

@@ -0,0 +1,40 @@
module Day8.Puzzle1 (day8_1) where
import Data.List (uncons)
import Data.Maybe (fromJust)
import Control.Applicative
import qualified Data.Set as Set
type Freq = Char
type Coords = (Int, Int)
data Antenna = Antenna { frequency :: Freq
, coordinates :: Coords
} deriving (Show, Eq)
readAntenna :: Freq -> Coords -> Antenna
readAntenna frequency coordinates = Antenna {frequency=frequency, coordinates=coordinates}
getAntennas :: [String] -> [Antenna]
getAntennas grid = concat . getZipList $ getAntennasRow <$> ZipList [0..] <*> ZipList grid
where getAntennasRow n row = [ readAntenna x (n, y) | (x, y) <- zip row [0..], x /= '.' ]
isInside :: Coords -> Int -> Int -> Bool
isInside c x y = fst c >= 0 && fst c < x && snd c >= 0 && snd c < y
getAntinodes :: Antenna -> Antenna -> Int -> Int -> [Coords]
getAntinodes a b maxX maxY = let xa = fst $ coordinates a
ya = snd $ coordinates a
xb = fst $ coordinates b
yb = snd $ coordinates b
in if frequency a /= frequency b || coordinates a == coordinates b
then []
else filter (\c -> isInside c maxX maxY) [(2 * xa - xb, 2 * ya - yb), (2 * xb - xa, 2 * yb - ya)]
day8_1 :: IO ()
day8_1 = do
contents <- lines <$> readFile "input/day8.txt"
let antennas = getAntennas contents
x = length contents
y = length $ fst . fromJust $ uncons contents
antinodes = Set.fromList $ concat [ getAntinodes a b x y | a <- antennas, b <- antennas, a /= b, frequency a == frequency b ]
putStrLn $ "Day 8, Puzzle 1 solution: " ++ show (length antinodes)

49
src/Day8/Puzzle2.hs Normal file
View File

@@ -0,0 +1,49 @@
module Day8.Puzzle2 (day8_2) where
import Data.List (uncons)
import Data.Maybe (fromJust)
import Control.Applicative
import Data.Set (fromList)
import Data.Bifunctor (bimap)
type Freq = Char
type Coords = (Int, Int)
data Antenna = Antenna { frequency :: Freq
, coordinates :: Coords
} deriving (Show, Eq)
readAntenna :: Freq -> Coords -> Antenna
readAntenna frequency coordinates = Antenna {frequency=frequency, coordinates=coordinates}
getAntennas :: [String] -> [Antenna]
getAntennas grid = concat . getZipList $ getAntennasRow <$> ZipList [0..] <*> ZipList grid
where getAntennasRow n row = [ readAntenna x (n, y) | (x, y) <- zip row [0..], x /= '.' ]
isInside :: Coords -> Int -> Int -> Bool
isInside c x y = fst c >= 0 && fst c < x && snd c >= 0 && snd c < y
generateCoords :: Coords -> Coords -> [Coords]
generateCoords c offset = scanl shiftCoords c (repeat offset)
where shiftCoords c = bimap (fst c +) (snd c +)
getAntinodes :: Antenna -> Antenna -> Int -> Int -> [Coords]
getAntinodes a b maxX maxY = let xa = fst $ coordinates a
ya = snd $ coordinates a
xb = fst $ coordinates b
yb = snd $ coordinates b
distX = xa - xb
distY = ya - yb
in if frequency a /= frequency b || coordinates a == coordinates b
then []
else filter (\c -> isInside c maxX maxY) [(2 * xa - xb, 2 * ya - yb), (2 * xb - xa, 2 * yb - ya)]
++ takeWhile (\c -> isInside c maxX maxY) (generateCoords (coordinates a) (distX, distY))
++ takeWhile (\c -> isInside c maxX maxY) (generateCoords (coordinates b) (-distX, -distY))
day8_2 :: IO ()
day8_2 = do
contents <- lines <$> readFile "input/day8.txt"
let antennas = getAntennas contents
x = length contents
y = length $ fst . fromJust $ uncons contents
antinodes = fromList $ concat [ getAntinodes a b x y | a <- antennas, b <- antennas, a /= b, frequency a == frequency b ]
putStrLn $ "Day 8, Puzzle 2 solution: " ++ show (length antinodes)

31
src/Day9/Puzzle1.hs Normal file
View File

@@ -0,0 +1,31 @@
module Day9.Puzzle1 (day9_1) where
import Data.List (intersperse)
import Data.Char (digitToInt)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Sequence as S
import qualified Data.Foldable as F
import Control.Applicative
parseDiskMap :: [Int] -> S.Seq Int
parseDiskMap xs = let values = intersperse (-1) [0..]
in S.fromList . concat . getZipList $ replicate <$> ZipList xs <*> ZipList values
compact :: S.Seq Int -> S.Seq Int
compact xs
| fileIndex == -1 = xs
| otherwise = S.filter (/= -1) $ startDisk S.>< (compact . S.insertAt 0 fileVal . S.deleteAt 0 $ S.deleteAt fileIndex endDisk)
where spaceIndex = fromJust $ S.elemIndexL (-1) xs
(startDisk, endDisk) = S.splitAt spaceIndex xs
fileIndex = fromMaybe (-1) (S.findIndexR (/= -1) endDisk)
fileVal = S.index endDisk fileIndex
checksum :: [Int] -> Int
checksum xs = sum $ zipWith (*) xs [0..]
day9_1 :: IO ()
day9_1 = do
contents <- init <$> readFile "input/day9.txt"
let diskMap = map digitToInt contents
putStrLn $ "Day 9, Puzzle 1 solution: "
++ show (checksum . F.toList . compact $ parseDiskMap diskMap)

64
src/Day9/Puzzle2.hs Normal file
View File

@@ -0,0 +1,64 @@
module Day9.Puzzle2 (day9_2) where
import Data.List (intersperse, groupBy)
import Data.Char (digitToInt)
import Data.Maybe (fromMaybe)
import Data.Function (on)
import qualified Data.Sequence as S
import qualified Data.Foldable as F
type DiskElem = (Int, Int)
parseDiskMap :: [Int] -> S.Seq DiskElem
parseDiskMap xs = let values = intersperse (-1) [0..]
in S.fromList $ zip values xs
isSpaceEnough :: Int -> DiskElem -> Bool
isSpaceEnough n (-1, l) = l >= n
isSpaceEnough _ _ = False
updateSpace :: Int -> DiskElem -> DiskElem
updateSpace n (-1, l) = (-1, l - n)
combineSpace :: DiskElem -> DiskElem -> DiskElem
combineSpace (-1, l1) (-1, l2) = (-1, l1 + l2)
compareFileValue :: Int -> DiskElem -> Bool
compareFileValue x (v, _) = x == v
moveFile :: Int -> Int -> DiskElem -> DiskElem -> S.Seq DiskElem -> S.Seq DiskElem
moveFile i sIndex sVal fVal xs = let xs' = F.toList . S.insertAt sIndex fVal . S.insertAt sIndex sVal . S.deleteAt sIndex . S.insertAt i (-1, snd fVal) $ S.deleteAt i xs
in S.fromList $ map (foldl1 combineSpace) $ groupBy ((==) `on` fst) xs'
compactFiles :: Int -> S.Seq DiskElem -> S.Seq DiskElem
compactFiles (-1) xs = xs
compactFiles 0 xs = xs
compactFiles n xs = if fst fVal == -1 || sIndex == -1 || sIndex >= n
then compactFiles (n - 1) xs
else compactFiles fIndex xs'
where fVal = S.index xs n
sIndex = fromMaybe (-1) $ S.findIndexL (isSpaceEnough (snd fVal)) xs
sVal = updateSpace (snd fVal) (fromMaybe (-1, 0) $ S.lookup sIndex xs)
xs' = moveFile n sIndex sVal fVal xs
fIndex = fromMaybe (-1) $ S.findIndexR (compareFileValue (fst fVal - 1)) xs'
maskMinus1 :: [Int] -> [Int]
maskMinus1 [] = []
maskMinus1 (l:ls)
| l == -1 = 0:maskMinus1 ls
| otherwise = l:maskMinus1 ls
tuplesToIntList :: S.Seq DiskElem -> [Int]
tuplesToIntList disk = let listDisk = F.toList disk
in concatMap (\x -> replicate (snd x) (fst x)) listDisk
checksum :: [Int] -> Int
checksum xs = sum $ zipWith (*) (maskMinus1 xs) [0..]
day9_2 :: IO ()
day9_2 = do
contents <- init <$> readFile "input/day9.txt"
let disk = parseDiskMap $ map digitToInt contents
i = fromMaybe (-1) $ S.findIndexR (\x -> fst x /= -1) disk
compactedDisk = tuplesToIntList $ S.filter (\x -> snd x > 0) $ compactFiles i disk
putStrLn $ "Day 9, Puzzle 2 solution: " ++ show (checksum compactedDisk)

59
src/Main.hs Normal file
View File

@@ -0,0 +1,59 @@
module Main (main) where
import Day1.Puzzle1
import Day1.Puzzle2
import Day2.Puzzle1
import Day2.Puzzle2
import Day3.Puzzle1
import Day3.Puzzle2
import Day4.Puzzle1
import Day4.Puzzle2
import Day5.Puzzle1
import Day5.Puzzle2
import Day6.Puzzle1
import Day6.Puzzle2
import Day7.Puzzle1
import Day7.Puzzle2
import Day8.Puzzle1
import Day8.Puzzle2
import Day9.Puzzle1
import Day9.Puzzle2
import Day10.Puzzle1
import Day11.Puzzle1
import Day11.Puzzle2
import Day12.Puzzle1
import Day13.Puzzle1
import Day13.Puzzle2
import Day14.Puzzle1
import System.Environment (getArgs)
main :: IO ()
main = do
args <- getArgs
case args of
"1":"1":_ -> day1_1
"1":"2":_ -> day1_2
"2":"1":_ -> day2_1
"2":"2":_ -> day2_2
"3":"1":_ -> day3_1
"3":"2":_ -> day3_2
"4":"1":_ -> day4_1
"4":"2":_ -> day4_2
"5":"1":_ -> day5_1
"5":"2":_ -> day5_2
"6":"1":_ -> day6_1
"6":"2":_ -> day6_2
"7":"1":_ -> day7_1
"7":"2":_ -> day7_2
"8":"1":_ -> day8_1
"8":"2":_ -> day8_2
"9":"1":_ -> day9_1
"9":"2":_ -> day9_2
"10":"1":_ -> day10_1
"11":"1":_ -> day11_1
"11":"2":_ -> day11_2
"12":"1":_ -> day12_1
"13":"1":_ -> day13_1
"13":"2":_ -> day13_2
"14":"1":_ -> day14_1
_ -> error "Not implemented"