Skip to content

Commit 8bf2622

Browse files
goblivendgoblivend
committed
feat(2024/Day21)
1 parent 06b6d8c commit 8bf2622

File tree

5 files changed

+238
-0
lines changed

5 files changed

+238
-0
lines changed

‎2024/Day21/Day21.hs

+188
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,188 @@
1+
module Main where
2+
3+
import Data.Bits
4+
import Data.Char
5+
import Data.List
6+
import Data.List.Split
7+
import Data.List.Unique
8+
import Data.Map (Map)
9+
import Data.Map qualified as M
10+
import Data.Matrix (Matrix, (!))
11+
import Data.Matrix qualified as Mat
12+
import Data.Set (Set)
13+
import Data.Set qualified as S
14+
import Data.Tuple.Extra
15+
import Debug.Trace
16+
import System.Environment
17+
import Text.Regex.TDFA ((=~))
18+
19+
-- TODO: Cleanup imports after day done
20+
21+
type Input = [String]
22+
23+
type Output = Int
24+
25+
parseInput :: String -> Input
26+
parseInput = lines
27+
28+
shorten :: [String] -> [String]
29+
shorten = head . groupBy (\e1 e2 -> length e1 == length e2) . sortOn length
30+
31+
shortenS :: Set String -> Set String
32+
shortenS = S.fromList . head . groupBy (\e1 e2 -> length e1 == length e2) . sortOn length . S.toList
33+
34+
sConcat :: (Ord a) => Set (Set a) -> Set a
35+
sConcat = S.unions . S.toList
36+
37+
memoise2 :: (Ord a, Ord b) => Map (a, b) c -> (a -> b -> c) -> a -> b -> (Map (a, b) c, c)
38+
memoise2 mem f a b
39+
| (a, b) `M.member` mem = (mem, mem M.! (a, b))
40+
| otherwise = (M.insert (a, b) res mem, res)
41+
where res = f a b
42+
43+
memoise3 :: (Ord a, Ord b, Ord c) => Map (a, b, c) d -> (a -> b -> c -> d) -> a -> b -> c -> (Map (a, b, c) d, d)
44+
memoise3 mem f a b c
45+
| (a, b, c) `M.member` mem = (mem, mem M.! (a, b, c))
46+
| otherwise = (M.insert (a, b, c) res mem, res)
47+
where res = f a b c
48+
49+
50+
51+
goToY :: [(Int, Int)] -> (Int, Int) -> (Int, Int) -> String
52+
goToY possible (x, y) (x', y')
53+
| x == x' && y == y' = []
54+
| y < y' && (x, y+1) `elem` possible = 'v' : goToY possible (x, y + 1) (x', y')
55+
| y > y' && (x, y-1) `elem` possible = '^' : goToY possible (x, y - 1) (x', y')
56+
| x < x' && (x+1, y) `elem` possible = '>' : goToY possible (x + 1, y) (x', y')
57+
| x > x' && (x-1, y) `elem` possible = '<' : goToY possible (x - 1, y) (x', y')
58+
59+
goToX :: [(Int, Int)] -> (Int, Int) -> (Int, Int) -> String
60+
goToX possible (x, y) (x', y')
61+
| x == x' && y == y' = []
62+
| x < x' && (x+1, y) `elem` possible = '>' : goToX possible (x + 1, y) (x', y')
63+
| x > x' && (x-1, y) `elem` possible = '<' : goToX possible (x - 1, y) (x', y')
64+
| y < y' && (x, y+1) `elem` possible = 'v' : goToX possible (x, y + 1) (x', y')
65+
| y > y' && (x, y-1) `elem` possible = '^' : goToX possible (x, y - 1) (x', y')
66+
67+
isValid :: [(Int, Int)] -> (Int, Int) -> String -> Bool
68+
isValid validSpots xy [] = xy `elem` validSpots
69+
isValid validSpots (x, y) ('v':s) = (x, y) `elem` validSpots && isValid validSpots (x, y+1) s
70+
isValid validSpots (x, y) ('^':s) = (x, y) `elem` validSpots && isValid validSpots (x, y-1) s
71+
isValid validSpots (x, y) ('>':s) = (x, y) `elem` validSpots && isValid validSpots (x+1, y) s
72+
isValid validSpots (x, y) ('<':s) = (x, y) `elem` validSpots && isValid validSpots (x-1, y) s
73+
74+
generalEmulator :: Map (Int, Int) Char -> (Int, Int )-> String -> String
75+
generalEmulator poss posA code = sub code posA
76+
where
77+
sub [] _ = []
78+
sub ('A': l) xy = poss M.! xy : sub l xy
79+
sub ('v' : l) (x, y) = sub l (x, y+1)
80+
sub ('^' : l) (x, y) = sub l (x, y-1)
81+
sub ('>' : l) (x, y) = sub l (x+1, y)
82+
sub ('<' : l) (x, y) = sub l (x-1, y)
83+
84+
numericalEmulator :: String -> String
85+
numericalEmulator code = generalEmulator numMap (2, 3) code
86+
where
87+
numMap =
88+
M.fromList $
89+
[ ((0, 0), '7'),
90+
((1, 0), '8'),
91+
((2, 0), '9'),
92+
((0, 1), '4'),
93+
((1, 1), '5'),
94+
((2, 1), '6'),
95+
((0, 2), '1'),
96+
((1, 2), '2'),
97+
((2, 2), '3'),
98+
((1, 3), '0'),
99+
((2, 3), 'A')
100+
]
101+
102+
directionalEmulator :: String -> String
103+
directionalEmulator code = generalEmulator dirMap (2, 0) code
104+
where
105+
dirMap = M.fromList $ [((1, 0), '^'), ((2, 0), 'A'), ((0, 1), '<'), ((1, 1), 'v'), ((2, 1), '>')]
106+
107+
108+
sequencerC :: [(Int, Int)] -> (Int, Int) -> (Int, Int) -> ((Int, Int), Set String)
109+
sequencerC valid xy' xy = (xy', S.map (++ "A") goTos)
110+
where
111+
goTos = S.fromList $ shorten . map (\gt -> gt valid xy xy') $ [goToX, goToY]
112+
113+
sequencer :: Map Char (Int, Int) -> String -> (Int, Int) -> Set String
114+
sequencer poss [] _ = S.singleton []
115+
sequencer poss (e : l) xy = sConcat $ S.map (\r -> S.map (++ r) goTos) $ nextRes
116+
where
117+
nextRes = sequencer poss l xy'
118+
(xy', goTos) = sequencerC (M.elems poss) (poss M.! e) xy
119+
120+
numericalSequencer :: String -> Set String
121+
numericalSequencer code = sequencer numMap code (numMap M.! 'A')
122+
where
123+
numMap =
124+
M.fromList $
125+
[ ('7', (0, 0)),
126+
('8', (1, 0)),
127+
('9', (2, 0)),
128+
('4', (0, 1)),
129+
('5', (1, 1)),
130+
('6', (2, 1)),
131+
('1', (0, 2)),
132+
('2', (1, 2)),
133+
('3', (2, 2)),
134+
('0', (1, 3)),
135+
('A', (2, 3))
136+
]
137+
138+
139+
directionalSequencer :: String -> Set String
140+
directionalSequencer code = sequencer dirMap code (dirMap M.! 'A')
141+
where
142+
dirMap = M.fromList $ [('^', (1, 0)), ('A', (2, 0)), ('<', (0, 1)), ('v', (1, 1)), ('>', (2, 1))]
143+
144+
145+
depthMemorySequencer :: Map ((Int, Int), ((Int, Int), Int)) Int -> Int -> String -> (Map ((Int, Int), ((Int, Int), Int)) Int, Int)
146+
depthMemorySequencer mem depth code = sub mem depth code
147+
where
148+
dirMap = M.fromList $ [('^', (1, 0)), ('A', (2, 0)), ('<', (0, 1)), ('v', (1, 1)), ('>', (2, 1))]
149+
150+
subc' :: Map ((Int, Int), ((Int, Int), Int)) Int -> Int -> (Int, Int) -> (Int, Int) -> (Map ((Int, Int), ((Int, Int), Int)) Int, Int)
151+
subc' mem' 1 c xy = memoise2 mem' (\c (xy, d) -> (length . head . sortOn length . S.toList) . snd $ sequencerC (M.elems dirMap) c xy) c (xy, 1)
152+
subc' mem' d c xy
153+
| (c, (xy, d)) `M.member` mem' = (mem', mem' M.! (c, (xy, d)))
154+
| otherwise = (M.insert (c, (xy, d)) r newMem, r)
155+
where
156+
157+
(newMem, r) = S.foldl (\(m, r) s -> second (min r) $ sub m (d-1) s) (mem', maxBound) . snd $ sequencerC (M.elems dirMap) c xy
158+
159+
sub :: Map ((Int, Int), ((Int, Int), Int)) Int -> Int -> String -> (Map ((Int, Int), ((Int, Int), Int)) Int, Int)
160+
sub mem' d s = second snd $ foldl (\(m, (p, r)) e -> second (\r' -> (dirMap M.! e, r + r')) $ subc' m d (dirMap M.! e) p) (mem', ((dirMap M.! 'A'), 0)) s -- foldl
161+
162+
163+
164+
getComplexity :: Int -> String -> Int
165+
getComplexity depth code = trace (show sequenceLength ++ "*" ++ show codeValue) codeValue * sequenceLength
166+
where
167+
codeValue = read $ takeWhile isDigit code
168+
numSequences = numericalSequencer code
169+
170+
sequenceLength = snd $ foldl (\(m, r) s -> second (min r) $ depthMemorySequencer m depth s) (M.empty, maxBound) numSequences
171+
172+
173+
part1 :: Input -> Output
174+
part1 = sum . map (getComplexity 2)
175+
176+
part2 :: Input -> Output
177+
part2 = sum . map (getComplexity 25)
178+
179+
main :: IO ()
180+
main = do
181+
args <- getArgs
182+
content <- readFile (last args)
183+
let input = parseInput content
184+
185+
print input
186+
187+
print $ part1 input -- (== 248684) $
188+
print $ part2 input --(== 307055584161760) $

‎2024/Day21/Makefile

+28
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
CONTAINER_NAME=haskell-aoc
2+
SRC=./Day21.hs
3+
TARGET=Day21
4+
all: $(TARGET)
5+
6+
$(TARGET): $(SRC)
7+
ghc -O3 $(SRC)
8+
9+
profile: $(SRC)
10+
11+
12+
clean:
13+
$(RM) ./Day21 ./Day21.o ./Day21.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

‎2024/Day21/input.txt

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
836A
2+
540A
3+
965A
4+
480A
5+
789A

‎2024/Day21/shortinput.txt

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
029A
2+
980A
3+
179A
4+
456A
5+
379A

‎2024/README.md

+12
Original file line numberDiff line numberDiff line change
@@ -423,3 +423,15 @@ Day was interesting, solution is quite slow
423423

424424
part1: 30mins
425425
part2: 10mins
426+
427+
### Day21:
428+
429+
This day was hard.
430+
431+
Like really hard.
432+
433+
Took me all day to do it (part2 finished at 7:20pm).
434+
435+
I didn't really like the lore, like if the robots are not made for pushing buttons, how can they even know to crash when they're not in front of one...
436+
437+
Even more, at what speed is the main character pushing the buttons to be able to push ~3e14 of them...

0 commit comments

Comments
 (0)