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