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