--- /dev/null
+-- Writeup at https://work.njae.me.uk/2022/12/19/advent-of-code-2022-day-17/
+
+-- import Debug.Trace
+
+import AoC
+import qualified Data.Set as S
+import qualified Data.Map.Strict as M
+import Linear hiding (Trace, trace, distance)
+import Control.Lens
+import Data.Maybe
+
+type Position = V2 Int -- x, y; y increasing upwards
+type Chamber = S.Set Position
+type Rock = S.Set Position
+
+data SimulationState = SimulationState
+ { _chamber :: Chamber
+ , _jets :: [Position]
+ , _rocks :: [Rock]
+ , _droppedCount :: Int
+ } deriving (Eq, Ord)
+makeLenses ''SimulationState
+
+instance Show SimulationState where
+ show sState = "SimState { _chamber = "
+ ++ (show $ sState ^. chamber)
+ ++ ", _jets = "
+ ++ (show (take 5 (sState ^. jets)))
+ ++ ", _rocks = "
+ ++ (show (take 5 (sState ^. rocks)))
+ ++ ", _droppedCount = "
+ ++ (show (sState ^. droppedCount))
+ ++ " }"
+
+main :: IO ()
+main =
+ do dataFileName <- getDataFileName
+ text <- readFile dataFileName
+ let oneJetCycle = mkJets text
+ print $ part1 oneJetCycle
+ -- print $ (length oneJetCycle) * (length rockPics)
+ print $ part2 oneJetCycle
+
+part1, part2 :: [Position] -> Int
+part1 oneJetCycle = rocksHeight final -- fromMaybe -1 $ maximumOf (folded . _y) (final ^. chamber)
+ where final = simulate mkRocks (cycle oneJetCycle) 2022
+
+part2 oneJetCycle = calculatedHeight -- (cycleStartState, cycleRepeatState)
+ where initState = SimulationState
+ { _chamber = S.empty
+ , _jets = (cycle oneJetCycle)
+ , _rocks = mkRocks
+ , _droppedCount = 0
+ }
+ (cycleStartState, _) = findEarliestRepeat (length oneJetCycle) initState
+ cycleRepeatState = findCycleRepeat (length oneJetCycle) cycleStartState
+ cycleStart = cycleStartState ^. droppedCount
+ cycleLength = (cycleRepeatState ^. droppedCount) - cycleStart
+ startHeight = rocksHeight cycleStartState
+ differenceHeight = (rocksHeight cycleRepeatState) - startHeight
+ afterStart = 1000000000000 - cycleStart
+ (numCycles, remainingDrops) = afterStart `divMod` cycleLength
+ finalState = (!!remainingDrops) $ iterate dropFromTop cycleStartState
+ finalHeight = rocksHeight finalState
+ calculatedHeight = finalHeight + (differenceHeight * numCycles)
+
+rocksHeight :: SimulationState -> Int
+rocksHeight state = fromMaybe -1 $ maximumOf (folded . _y) (state ^. chamber)
+
+simSome :: [Position] -> Int -> Int
+simSome oneJetCycle n = fromMaybe -1 $ maximumOf (folded . _y) (final ^. chamber)
+ where final = simulate mkRocks (cycle oneJetCycle) n
+
+simulate :: [Rock] -> [Position] -> Int -> SimulationState
+simulate rocks jets n = (!!n) $ iterate dropFromTop initState
+ where initState = SimulationState { _chamber = S.empty, _jets = jets, _rocks = rocks, _droppedCount = 0}
+
+dropFromTop :: SimulationState -> SimulationState
+dropFromTop simState = (dropRock simState (initialPlace simState))
+ & rocks %~ tail
+ & droppedCount %~ (+ 1)
+
+dropRock :: SimulationState -> Rock -> SimulationState
+dropRock simState rock
+ | rock2 == Nothing = simState & chamber %~ (S.union rock1)
+ & jets %~ tail
+ | otherwise = dropRock (simState & jets %~ tail) $ fromJust rock2
+ where rock1 = push (simState ^. chamber) rock (head (simState ^. jets))
+ rock2 = fall (simState ^. chamber) rock1
+
+initialPlace :: SimulationState -> Rock
+initialPlace simState = S.map (^+^ (V2 2 startHeight)) rock
+ where startHeight = 4 + (fromMaybe 0 $ maximumOf (folded . _y) (simState ^. chamber))
+ rock = head $ simState ^. rocks
+
+push :: Chamber -> Rock -> Position -> Rock
+push chamber rock direction
+ -- | trace ("Before push " ++ (intercalate " : " $ [show chamber, show rock, show direction])) False = undefined
+ | disjoint && inLeft && inRight = pushedRock
+ | otherwise = rock
+ where pushedRock = S.map (^+^ direction) rock
+ disjoint = S.null $ S.intersection pushedRock chamber
+ inLeft = (fromJust $ minimumOf (folded . _x) pushedRock) >= 0
+ inRight = (fromJust $ maximumOf (folded . _x) pushedRock) <= 6
+
+fall :: Chamber -> Rock -> Maybe Rock
+fall chamber rock
+ -- | trace ("Before fall " ++ (intercalate " : " $ [show chamber, show rock, show disjoint, show aboveFloor, show droppedRock])) False = undefined
+ | disjoint && aboveFloor = Just droppedRock
+ | otherwise = Nothing
+ where droppedRock = S.map (^+^ (V2 0 -1)) rock
+ disjoint = S.null $ S.intersection droppedRock chamber
+ aboveFloor = (fromJust $ minimumOf (folded . _y) droppedRock) > 0
+
+
+findCycleRepeat :: Int -> SimulationState -> SimulationState
+findCycleRepeat jetLength cycleStart = head $ dropWhile (differentProfiles jetLength cycleStart) hares
+ where hares = drop 1 $ iterate dropFromTop cycleStart
+
+
+findEarliestRepeat :: Int -> SimulationState -> (SimulationState, SimulationState)
+findEarliestRepeat jetLength simState = head $ dropWhile (uncurry (differentProfiles jetLength)) pairs
+ where tortoises = drop 1 $ iterate dropFromTop simState
+ hares = drop 1 $ iterate (dropFromTop . dropFromTop) simState
+ pairs = zip tortoises hares
+
+differentProfiles :: Int -> SimulationState -> SimulationState -> Bool
+differentProfiles jetLength t h = (simulationProfile jetLength t) /= (simulationProfile jetLength h)
+
+simulationProfile :: Int -> SimulationState -> (Chamber, [Position], Rock)
+simulationProfile jetLength state =
+ ( surfaceProfile state
+ , take jetLength $ state ^. jets
+ , head $ state ^. rocks
+ )
+
+surfaceProfile :: SimulationState -> Chamber
+surfaceProfile state = S.fromList $ map (^-^ (V2 0 peak)) rawProfile
+ where ch = state ^. chamber
+ rawProfile = [V2 i (fromMaybe -1 $ maximumOf (folded . filteredBy (_x . only i) . _y) ch) | i <- [0..6] ]
+ peak = fromJust $ maximumOf (folded . _y) rawProfile
+
+showChamber :: Chamber -> String
+showChamber chamber = unlines
+ [ [showCell x y | x <- [0..6]]
+ | y <- reverse [1..yMax]
+ ] ++ "-------"
+ where yMax = fromMaybe 0 $ maximumOf (folded . _y) chamber
+ showCell x y
+ | (V2 x y) `S.member` chamber = '#'
+ | otherwise = '.'
+
+mkJets :: String -> [Position]
+mkJets = fmap mkJet
+ where mkJet '<' = V2 -1 0
+ mkJet '>' = V2 1 0
+ mkJet _ = error "Illegal jet character"
+
+mkRocks :: [Rock]
+mkRocks = cycle $ fmap mkRock rockPics
+
+mkRock :: String -> Rock
+mkRock rockPic = S.fromList
+ [ V2 x y
+ | x <- [0..((length (rockLines!!0)) - 1)]
+ , y <- [0..((length rockLines) - 1)]
+ , (rockLines!!y)!!x == '#'
+ ]
+ where rockLines = reverse $ lines rockPic
+
+rockPics :: [String]
+rockPics = ["####", ".#.\n###\n.#.", "..#\n..#\n###", "#\n#\n#\n#", "##\n##"]
+
projects / advent-of-code-22.git / blobdiff