From a3bda76d71e056f575f56fbb6f2e149dc857cb47 Mon Sep 17 00:00:00 2001 From: Daniele Fucini Date: Sun, 15 Dec 2024 18:17:51 +0100 Subject: [PATCH] Day 15, Part 1 --- adventofcode2024.cabal | 1 + src/Day15/Puzzle1.hs | 208 +++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 2 + 3 files changed, 211 insertions(+) create mode 100644 src/Day15/Puzzle1.hs diff --git a/adventofcode2024.cabal b/adventofcode2024.cabal index 49c3054..c097917 100644 --- a/adventofcode2024.cabal +++ b/adventofcode2024.cabal @@ -58,3 +58,4 @@ executable adventofcode2024 Day13.Puzzle1 Day13.Puzzle2 Day14.Puzzle1 + Day15.Puzzle1 diff --git a/src/Day15/Puzzle1.hs b/src/Day15/Puzzle1.hs new file mode 100644 index 0000000..739db48 --- /dev/null +++ b/src/Day15/Puzzle1.hs @@ -0,0 +1,208 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Day15.Puzzle1 (day15_1) where + +import Data.List (elemIndex, elemIndices, transpose, uncons) +import Data.List.Split (splitOn) +import Data.Maybe (fromJust, fromMaybe, isJust) + +type Grid = [String] + +type Position = (Int, Int) + +data Direction = U | R | D | L deriving (Eq, Show) + +getDirection :: Char -> Maybe Direction +getDirection '^' = Just U +getDirection '>' = Just R +getDirection 'v' = Just D +getDirection '<' = Just L +getDirection _ = Nothing + +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 + +moveUp :: Position -> Position +moveUp (x, y) = (x - 1, y) + +moveRight :: Position -> Position +moveRight (x, y) = (x, y + 1) + +moveDown :: Position -> Position +moveDown (x, y) = (x + 1, y) + +moveLeft :: Position -> Position +moveLeft (x, y) = (x, y - 1) + +markPosition :: Position -> Char -> Grid -> Grid +markPosition (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 + +getValsUp :: Position -> Grid -> String +getValsUp (x, y) grid = takeWhile (/= '#') . reverse . take x $ transpose grid !! y + +getValsDown :: Position -> Grid -> String +getValsDown (x, y) grid = takeWhile (/= '#') . drop (x + 1) $ transpose grid !! y + +getValsLeft :: Position -> Grid -> String +getValsLeft (x, y) grid = takeWhile (/= '#') . reverse . take y $ grid !! x + +getValsRight :: Position -> Grid -> String +getValsRight (x, y) grid = takeWhile (/= '#') . drop (y + 1) $ grid !! x + +shiftUp :: Position -> Grid -> Grid +shiftUp p1 grid = + let p2 = moveUp p1 + p3 = moveUp p2 + v = getGridVal p3 grid + in if v == '#' + then grid + else + if v == '.' + then markPosition p1 '.' (markPosition p2 '@' (markPosition p3 'O' grid)) + else + let column = reverse $ transpose grid !! snd p1 + nextDot = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< length column - fst p1) $ elemIndices '.' column + nextHash = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< length column - fst p1) $ elemIndices '#' column + in if nextDot == -1 || nextDot > nextHash + then grid + else markPosition p1 '.' (markPosition p2 '@' (markPosition (length column - 1 - nextDot, snd p1) 'O' grid)) + +shiftRight :: Position -> Grid -> Grid +shiftRight p1 grid = + let p2 = moveRight p1 + p3 = moveRight p2 + v = getGridVal p3 grid + in if v == '#' + then grid + else + if v == '.' + then markPosition p1 '.' (markPosition p2 '@' (markPosition p3 'O' grid)) + else + let row = grid !! fst p1 + nextDot = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< snd p1) $ elemIndices '.' row + nextHash = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< snd p1) $ elemIndices '#' row + in if nextDot == -1 || nextDot > nextHash + then grid + else markPosition p1 '.' (markPosition p2 '@' (markPosition (fst p1, nextDot) 'O' grid)) + +shiftDown :: Position -> Grid -> Grid +shiftDown p1 grid = + let p2 = moveDown p1 + p3 = moveDown p2 + v = getGridVal p3 grid + in if v == '#' + then grid + else + if v == '.' + then markPosition p1 '.' (markPosition p2 '@' (markPosition p3 'O' grid)) + else + let column = transpose grid !! snd p1 + nextDot = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< fst p1) $ elemIndices '.' column + nextHash = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< fst p1) $ elemIndices '#' column + in if nextDot == -1 || nextDot > nextHash + then grid + else markPosition p1 '.' (markPosition p2 '@' (markPosition (nextDot, snd p1) 'O' grid)) + +shiftLeft :: Position -> Grid -> Grid +shiftLeft p1 grid = + let p2 = moveLeft p1 + p3 = moveLeft p2 + v = getGridVal p3 grid + in if v == '#' + then grid + else + if v == '.' + then markPosition p1 '.' (markPosition p2 '@' (markPosition p3 'O' grid)) + else + let row = reverse $ grid !! fst p1 + nextDot = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< length row - snd p1) $ elemIndices '.' row + nextHash = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< length row - snd p1) $ elemIndices '#' row + in if nextDot == -1 || nextDot > nextHash + then grid + else markPosition p1 '.' (markPosition p2 '@' (markPosition (fst p1, length row - 1 - nextDot) 'O' grid)) + +move :: Position -> Direction -> Grid -> (Position, Grid) +move p U grid = + let newP = moveUp p + newV = getGridVal newP grid + in if newV == '#' + then (p, grid) + else + if newV == '.' + then (newP, markPosition p '.' (markPosition newP '@' grid)) + else + let valsUp = getValsUp p grid + in if '.' `notElem` valsUp + then (p, grid) + else (newP, shiftUp p grid) +move p R grid = + let newP = moveRight p + newV = getGridVal newP grid + in if newV == '#' + then (p, grid) + else + if newV == '.' + then (newP, markPosition p '.' (markPosition newP '@' grid)) + else + let valsRight = getValsRight p grid + in if '.' `notElem` valsRight + then (p, grid) + else (newP, shiftRight p grid) +move p D grid = + let newP = moveDown p + newV = getGridVal newP grid + in if newV == '#' + then (p, grid) + else + if newV == '.' + then (newP, markPosition p '.' (markPosition newP '@' grid)) + else + let valsDown = getValsDown p grid + in if '.' `notElem` valsDown + then (p, grid) + else (newP, shiftDown p grid) +move p L grid = + let newP = moveLeft p + newV = getGridVal newP grid + in if newV == '#' + then (p, grid) + else + if newV == '.' + then (newP, markPosition p '.' (markPosition newP '@' grid)) + else + let valsLeft = getValsLeft p grid + in if '.' `notElem` valsLeft + then (p, grid) + else (newP, shiftLeft p grid) + +visitGrid :: Position -> [Direction] -> Grid -> Grid +visitGrid _ [] grid = grid +visitGrid p (d : ds) grid = + let (newP, grid') = move p d grid + in visitGrid newP ds grid' + +gpsCoords :: Position -> Int +gpsCoords (x, y) = 100 * x + y + +boxCoords :: Grid -> [Int] +boxCoords grid = + let coords = [(x, y) | x <- [0 .. length grid - 1], y <- [0 .. length (fst . fromJust $ uncons grid) - 1], getGridVal (x, y) grid == 'O'] + in map gpsCoords coords + +day15_1 :: IO () +day15_1 = do + contents <- lines <$> readFile "input/day15.txt" + let [grid, d] = splitOn [""] contents + directions = map (fromJust . getDirection) $ concat d + startPos = getStartPosition '@' grid + finalGrid = visitGrid startPos directions grid + print . sum $ boxCoords finalGrid diff --git a/src/Main.hs b/src/Main.hs index 7bf322c..0685975 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -25,6 +25,7 @@ import Day12.Puzzle1 import Day13.Puzzle1 import Day13.Puzzle2 import Day14.Puzzle1 +import Day15.Puzzle1 import System.Environment (getArgs) main :: IO () @@ -56,4 +57,5 @@ main = do "13":"1":_ -> day13_1 "13":"2":_ -> day13_2 "14":"1":_ -> day14_1 + "15":"1":_ -> day15_1 _ -> error "Not implemented"