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