Skip to content

Commit a9a5232

Browse files
goblivendgoblivend
committed
feat(2024/Day15)
1 parent 78975a2 commit a9a5232

File tree

7 files changed

+306
-0
lines changed

7 files changed

+306
-0
lines changed

‎2024/Day15/Day15.hs

+161
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,161 @@
1+
module Main where
2+
3+
import Data.Bits
4+
import Data.List
5+
import Data.List.Split
6+
import Data.List.Unique
7+
import Data.Matrix (Matrix, (!))
8+
import Data.Matrix qualified as Mat
9+
import Data.Set (Set)
10+
import Data.Set qualified as S
11+
import Data.Tuple.Extra
12+
import Debug.Trace
13+
import System.Environment
14+
import Text.Regex.TDFA ((=~))
15+
16+
-- TODO: Cleanup imports after day done
17+
18+
data Dir = UP | LEFT | RIGHT | DOWN deriving (Show, Eq, Ord)
19+
20+
type Input = (Set (Int, Int), Set (Int, Int), [Dir], (Int, Int))
21+
22+
type Output = Int
23+
24+
parseInput1 :: String -> Input
25+
parseInput1 inp = (walls, boxes, parseMoves moves, robotPos)
26+
where
27+
[gridStr, moves] = splitOn "\n\n" inp
28+
(w, h) = (length $ head $ lines gridStr, length $ lines gridStr)
29+
wharehouse = lines $ gridStr
30+
parseMoves = map parseMove . concat . lines
31+
parseMove '<' = LEFT
32+
parseMove '^' = UP
33+
parseMove '>' = RIGHT
34+
parseMove 'v' = DOWN
35+
walls = S.fromList [(y, x) | y <- [0 .. h - 1], x <- [0 .. w - 1], wharehouse !! y !! x == '#']
36+
boxes = S.fromList [(y, x) | y <- [0 .. h - 1], x <- [0 .. w - 1], wharehouse !! y !! x == 'O']
37+
robotPos = head [(y, x) | y <- [0 .. h - 1], x <- [0 .. w - 1], wharehouse !! y !! x == '@']
38+
39+
parseInput2 :: String -> Input
40+
parseInput2 inp = (walls, boxes, parseMoves moves, robotPos)
41+
where
42+
[gridStr, moves] = splitOn "\n\n" inp
43+
(w, h) = (length $ head $ lines gridStr, length $ lines gridStr)
44+
wharehouse = lines $ gridStr
45+
parseMoves = map parseMove . concat . lines
46+
parseMove '<' = LEFT
47+
parseMove '^' = UP
48+
parseMove '>' = RIGHT
49+
parseMove 'v' = DOWN
50+
walls = S.fromList $ concat [[(y, 2 * x), (y, 2 * x + 1)] | y <- [0 .. h - 1], x <- [0 .. w - 1], wharehouse !! y !! x == '#']
51+
boxes = S.fromList [(y, 2 * x) | y <- [0 .. h - 1], x <- [0 .. w - 1], wharehouse !! y !! x == 'O']
52+
robotPos = head [(y, 2 * x) | y <- [0 .. h - 1], x <- [0 .. w - 1], wharehouse !! y !! x == '@']
53+
54+
move :: (Int, Int) -> Dir -> (Int, Int)
55+
move (y, x) UP = (y - 1, x)
56+
move (y, x) DOWN = (y + 1, x)
57+
move (y, x) LEFT = (y, x - 1)
58+
move (y, x) RIGHT = (y, x + 1)
59+
60+
processMoves :: Input -> Input
61+
processMoves (walls, boxes, [], pos) = (walls, boxes, [], pos)
62+
processMoves (walls, boxes, (e : l), pos) = processMoves (walls, newBoxes, l, newPos)
63+
where
64+
(newBoxes, newPos) = processMove e
65+
processMove e
66+
| pos' `S.member` walls = (boxes, pos)
67+
| pos' `S.notMember` boxes = (boxes, pos')
68+
| pos' `S.notMember` boxes' = (boxes', pos')
69+
| otherwise = (boxes, pos)
70+
where
71+
pos' = move pos e
72+
boxes' = processMoveBox e pos'
73+
74+
processMoveBox e pos'
75+
| pos'' `S.member` walls = boxes
76+
| pos'' `S.notMember` boxes = S.insert pos'' $ S.delete pos' boxes
77+
| pos'' `S.notMember` boxes' = S.insert pos'' $ S.delete pos' boxes'
78+
| otherwise = boxes
79+
where
80+
boxes' = processMoveBox e (move pos' e)
81+
pos'' = move pos' e
82+
83+
gps :: [(Int, Int)] -> Output
84+
gps = sum . map (\(y, x) -> 100 * y + x)
85+
86+
part1 :: Input -> Output
87+
part1 input = gps $ S.toList boxes
88+
where
89+
(_, boxes, _, _) = processMoves input
90+
91+
processMoves2 :: Input -> Input
92+
processMoves2 (walls, boxes, [], pos) = (walls, boxes, [], pos)
93+
processMoves2 (walls, boxes, (e : l), pos) = processMoves2 (walls, newBoxes, l, newPos)
94+
where
95+
(newBoxes, newPos) = processMove e
96+
processMove e
97+
| pos' `S.member` walls = (boxes, pos)
98+
| pos' `S.notMember` boxes && (y, x - 1) `S.notMember` boxes = (boxes, pos')
99+
| pos' `S.notMember` boxes' && (y, x - 1) `S.notMember` boxes' = (boxes', pos')
100+
| otherwise = (boxes, pos)
101+
where
102+
(pos'@(y, x)) = move pos e
103+
boxPos = (if pos' `S.member` boxes then pos' else (y, x - 1))
104+
boxes' = processMoveBox e boxPos
105+
106+
processMoveBox :: Dir -> (Int, Int) -> Set (Int, Int)
107+
processMoveBox LEFT pos = processMoveBoxLeft pos
108+
processMoveBox RIGHT pos = processMoveBoxRight pos
109+
processMoveBox e pos = processMoveBoxY boxes e pos
110+
111+
processMoveBoxLeft :: (Int, Int) -> Set (Int, Int)
112+
processMoveBoxLeft pos'
113+
| newBoxLeft `S.member` walls = boxes
114+
| (move newBoxLeft LEFT) `S.notMember` boxes = S.insert newBoxLeft $ S.delete pos' boxes
115+
| (move newBoxLeft LEFT) `S.notMember` boxes' = S.insert newBoxLeft $ S.delete pos' boxes'
116+
| otherwise = boxes
117+
where
118+
boxes' = processMoveBoxLeft (move newBoxLeft LEFT)
119+
newBoxLeft = move pos' LEFT
120+
newBoxRight = second (+ 1) newBoxLeft
121+
122+
processMoveBoxRight :: (Int, Int) -> Set (Int, Int)
123+
processMoveBoxRight pos'
124+
| newBoxRight `S.member` walls = boxes
125+
| newBoxLeft `S.notMember` boxes && newBoxRight `S.notMember` boxes = S.insert newBoxLeft $ S.delete pos' boxes
126+
| newBoxLeft `S.notMember` boxes' && newBoxRight `S.notMember` boxes' = S.insert newBoxLeft $ S.delete pos' boxes'
127+
| otherwise = boxes
128+
where
129+
boxes' = processMoveBoxRight (move newBoxLeft RIGHT)
130+
newBoxLeft = move pos' RIGHT
131+
newBoxRight = second (+ 1) newBoxLeft
132+
133+
processMoveBoxY :: Set (Int, Int) -> Dir -> (Int, Int) -> Set (Int, Int)
134+
processMoveBoxY boxes e pos'
135+
| newBoxLeft `S.member` walls || newBoxRight `S.member` walls = boxes
136+
| newBoxLeft `S.notMember` boxes && newBoxRight `S.notMember` boxes && (move newBoxLeft LEFT) `S.notMember` boxes = S.insert newBoxLeft $ S.delete pos' boxes
137+
| newBoxLeft `S.notMember` boxes' && newBoxRight `S.notMember` boxes' && (move newBoxLeft LEFT) `S.notMember` boxes' = S.insert newBoxLeft $ S.delete pos' boxes'
138+
| otherwise = boxes
139+
where
140+
boxes' = foldl (\b p -> processMoveBoxY b e p) boxes $ filter (`S.member` boxes) [(move newBoxLeft LEFT), newBoxLeft, newBoxRight]
141+
newBoxLeft = move pos' e
142+
newBoxRight = second (+ 1) newBoxLeft
143+
144+
part2 :: Input -> Output
145+
part2 input = gps $ S.toList boxes
146+
where
147+
(_, boxes, _, _) = processMoves2 input
148+
149+
showGrid :: Input -> [String]
150+
showGrid (walls, boxes, _, pos) = [[if (y, x) `S.member` walls then '#' else if (y, x) `S.member` boxes then 'O' else if (y, x) == pos then '@' else '.' | x <- [0 .. 13]] | y <- [0 .. 6]]
151+
152+
main :: IO ()
153+
main = do
154+
args <- getArgs
155+
content <- readFile (last args)
156+
let input1 = parseInput1 content
157+
let input2 = parseInput2 content
158+
159+
-- print $ input
160+
print $ part1 input1
161+
print $ part2 input2

‎2024/Day15/Makefile

+28
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
CONTAINER_NAME=haskell-aoc
2+
SRC=./Day15.hs
3+
TARGET=Day15
4+
all: $(TARGET)
5+
6+
$(TARGET): $(SRC)
7+
ghc -O3 $(SRC)
8+
9+
profile: $(SRC)
10+
11+
12+
clean:
13+
$(RM) ./Day15 ./Day15.o ./Day15.hi
14+
15+
setup: $(SRC)
16+
docker cp $(SRC) $(CONTAINER_NAME):/home/haskell/Main.hs
17+
docker cp input.txt $(CONTAINER_NAME):/home/haskell/input.txt
18+
docker cp shortinput.txt $(CONTAINER_NAME):/home/haskell/shortinput.txt
19+
20+
profiling: setup
21+
docker exec -it $(CONTAINER_NAME) cabal build --enable-profiling
22+
docker exec -it $(CONTAINER_NAME) ./profile input.txt
23+
24+
run: setup
25+
docker exec -it $(CONTAINER_NAME) cabal build
26+
docker exec -it $(CONTAINER_NAME) ./run input.txt
27+
28+
.PHONY: all $(TARGET) clean setup profiling run

0 commit comments

Comments
 (0)