Done day 25
[advent-of-code-22.git] / advent17 / Main.hs
1 -- Writeup at https://work.njae.me.uk/2022/12/19/advent-of-code-2022-day-17/
2
3 -- import Debug.Trace
4
5 import AoC
6 import qualified Data.Set as S
7 import qualified Data.Map.Strict as M
8 import Linear hiding (Trace, trace, distance)
9 import Control.Lens
10 import Data.Maybe
11
12 type Position = V2 Int -- x, y; y increasing upwards
13 type Chamber = S.Set Position
14 type Rock = S.Set Position
15
16 data SimulationState = SimulationState
17 { _chamber :: Chamber
18 , _jets :: [Position]
19 , _rocks :: [Rock]
20 , _droppedCount :: Int
21 } deriving (Eq, Ord)
22 makeLenses ''SimulationState
23
24 instance Show SimulationState where
25 show sState = "SimState { _chamber = "
26 ++ (show $ sState ^. chamber)
27 ++ ", _jets = "
28 ++ (show (take 5 (sState ^. jets)))
29 ++ ", _rocks = "
30 ++ (show (take 5 (sState ^. rocks)))
31 ++ ", _droppedCount = "
32 ++ (show (sState ^. droppedCount))
33 ++ " }"
34
35 main :: IO ()
36 main =
37 do dataFileName <- getDataFileName
38 text <- readFile dataFileName
39 let oneJetCycle = mkJets text
40 print $ part1 oneJetCycle
41 -- print $ (length oneJetCycle) * (length rockPics)
42 print $ part2 oneJetCycle
43
44 part1, part2 :: [Position] -> Int
45 part1 oneJetCycle = rocksHeight $ simulate mkRocks (cycle oneJetCycle) 2022
46
47 part2 oneJetCycle = calculatedHeight
48 where initState = SimulationState
49 { _chamber = S.empty
50 , _jets = (cycle oneJetCycle)
51 , _rocks = mkRocks
52 , _droppedCount = 0
53 }
54 (cycleStartState, _) = findEarliestRepeat (length oneJetCycle) initState
55 cycleRepeatState = findCycleRepeat (length oneJetCycle) cycleStartState
56 cycleStart = cycleStartState ^. droppedCount
57 cycleLength = (cycleRepeatState ^. droppedCount) - cycleStart
58 startHeight = rocksHeight cycleStartState
59 differenceHeight = (rocksHeight cycleRepeatState) - startHeight
60 afterStart = 1000000000000 - cycleStart
61 (numCycles, remainingDrops) = afterStart `divMod` cycleLength
62 finalState = (!!remainingDrops) $ iterate dropFromTop cycleStartState
63 finalHeight = rocksHeight finalState
64 calculatedHeight = finalHeight + (differenceHeight * numCycles)
65
66 rocksHeight :: SimulationState -> Int
67 rocksHeight state = fromMaybe -1 $ maximumOf (folded . _y) (state ^. chamber)
68
69 simSome :: [Position] -> Int -> Int
70 simSome oneJetCycle n = fromMaybe -1 $ maximumOf (folded . _y) (final ^. chamber)
71 where final = simulate mkRocks (cycle oneJetCycle) n
72
73 simulate :: [Rock] -> [Position] -> Int -> SimulationState
74 simulate rocks jets n = (!!n) $ iterate dropFromTop initState
75 where initState = SimulationState { _chamber = S.empty, _jets = jets, _rocks = rocks, _droppedCount = 0}
76
77 dropFromTop :: SimulationState -> SimulationState
78 dropFromTop simState = (dropRock simState (initialPlace simState))
79 & rocks %~ tail
80 & droppedCount %~ (+ 1)
81
82 dropRock :: SimulationState -> Rock -> SimulationState
83 dropRock simState rock
84 | rock2 == Nothing = simState & chamber %~ (S.union rock1)
85 & jets %~ tail
86 | otherwise = dropRock (simState & jets %~ tail) $ fromJust rock2
87 where rock1 = push (simState ^. chamber) rock (head (simState ^. jets))
88 rock2 = fall (simState ^. chamber) rock1
89
90 initialPlace :: SimulationState -> Rock
91 initialPlace simState = S.map (^+^ (V2 2 startHeight)) rock
92 where startHeight = 4 + (fromMaybe 0 $ maximumOf (folded . _y) (simState ^. chamber))
93 rock = head $ simState ^. rocks
94
95 push :: Chamber -> Rock -> Position -> Rock
96 push chamber rock direction
97 -- | trace ("Before push " ++ (intercalate " : " $ [show chamber, show rock, show direction])) False = undefined
98 | disjoint && inLeft && inRight = pushedRock
99 | otherwise = rock
100 where pushedRock = S.map (^+^ direction) rock
101 disjoint = S.null $ S.intersection pushedRock chamber
102 inLeft = (fromJust $ minimumOf (folded . _x) pushedRock) >= 0
103 inRight = (fromJust $ maximumOf (folded . _x) pushedRock) <= 6
104
105 fall :: Chamber -> Rock -> Maybe Rock
106 fall chamber rock
107 -- | trace ("Before fall " ++ (intercalate " : " $ [show chamber, show rock, show disjoint, show aboveFloor, show droppedRock])) False = undefined
108 | disjoint && aboveFloor = Just droppedRock
109 | otherwise = Nothing
110 where droppedRock = S.map (^+^ (V2 0 -1)) rock
111 disjoint = S.null $ S.intersection droppedRock chamber
112 aboveFloor = (fromJust $ minimumOf (folded . _y) droppedRock) > 0
113
114
115 findCycleRepeat :: Int -> SimulationState -> SimulationState
116 findCycleRepeat jetLength cycleStart = head $ dropWhile (differentProfiles jetLength cycleStart) hares
117 where hares = drop 1 $ iterate dropFromTop cycleStart
118
119
120 findEarliestRepeat :: Int -> SimulationState -> (SimulationState, SimulationState)
121 findEarliestRepeat jetLength simState = head $ dropWhile (uncurry (differentProfiles jetLength)) pairs
122 where tortoises = drop 1 $ iterate dropFromTop simState
123 hares = drop 1 $ iterate (dropFromTop . dropFromTop) simState
124 pairs = zip tortoises hares
125
126 differentProfiles :: Int -> SimulationState -> SimulationState -> Bool
127 differentProfiles jetLength t h = (simulationProfile jetLength t) /= (simulationProfile jetLength h)
128
129 simulationProfile :: Int -> SimulationState -> (Chamber, [Position], Rock)
130 simulationProfile jetLength state =
131 ( surfaceProfile state
132 , take jetLength $ state ^. jets
133 , head $ state ^. rocks
134 )
135
136 surfaceProfile :: SimulationState -> Chamber
137 surfaceProfile state = S.fromList $ map (^-^ (V2 0 peak)) rawProfile
138 where ch = state ^. chamber
139 rawProfile = [V2 i (fromMaybe -1 $ maximumOf (folded . filteredBy (_x . only i) . _y) ch) | i <- [0..6] ]
140 peak = fromJust $ maximumOf (folded . _y) rawProfile
141
142 showChamber :: Chamber -> String
143 showChamber chamber = unlines
144 [ [showCell x y | x <- [0..6]]
145 | y <- reverse [1..yMax]
146 ] ++ "-------"
147 where yMax = fromMaybe 0 $ maximumOf (folded . _y) chamber
148 showCell x y
149 | (V2 x y) `S.member` chamber = '#'
150 | otherwise = '.'
151
152 mkJets :: String -> [Position]
153 mkJets = fmap mkJet
154 where mkJet '<' = V2 -1 0
155 mkJet '>' = V2 1 0
156 mkJet _ = error "Illegal jet character"
157
158 mkRocks :: [Rock]
159 mkRocks = cycle $ fmap mkRock rockPics
160
161 mkRock :: String -> Rock
162 mkRock rockPic = S.fromList
163 [ V2 x y
164 | x <- [0..((length (rockLines!!0)) - 1)]
165 , y <- [0..((length rockLines) - 1)]
166 , (rockLines!!y)!!x == '#'
167 ]
168 where rockLines = reverse $ lines rockPic
169
170 rockPics :: [String]
171 rockPics = ["####", ".#.\n###\n.#.", "..#\n..#\n###", "#\n#\n#\n#", "##\n##"]
172