Day 14 AOC 2023

day_fourteen_2023.hs

{-# LANGUAGE OverloadedStrings #-}
module DayFourteen where

import qualified Data.Text as T
import Data.Ratio ((%))
import qualified Data.List as L
import qualified Text.Read as TR
import Debug.Trace (traceShowId, traceShow)
import qualified Data.Maybe as M
import qualified Data.Map as DM
import qualified Data.Set as S
import qualified Data.List.Split as DLS
import qualified Data.Range as R
import qualified Data.Sequence as DS
import Data.Sequence as DS (index, (!?))
import Data.Sequence ((<|), (|>))
import Data.Range ((+=+), (+=*))
import Safe (atDef, atMay, minimumMay, headMay, headDef)
import Data.Foldable (toList)


testMirrorInput :: [T.Text]
testMirrorInput = ["O....#....",
             "O.OO#....#",
             ".....##...",
             "OO.#O....O",
             ".O.....O#.",
             "O.#..O.#.#",
             "..O..#O..O",
             ".......O..",
             "#....###..",
             "#OO..#...."]

testMirror = parseMirror testMirrorInput

parseMirror lines = DS.fromList (map DS.fromList lists)
  where lists = map ((map parseMirrorCell) . T.unpack) lines

data Cell = Round | Cubic | Empty deriving (Eq, Ord)
data Direction = North | South | East | West deriving (Eq, Ord)

instance Show Cell where
  show Round = "O"
  show Cubic = "#"
  show _ = "."

parseMirrorCell 'O' = Round
parseMirrorCell '#' = Cubic
parseMirrorCell _ = Empty


swapCells mirror (sr,sc) (tr, tc) = (putBack . copyOver) mirror
  where sourceItem = (mirror `index` sr) `index` sc
        destItem = (mirror `index` tr) `index` tc
        copyOver = DS.adjust (DS.update tc sourceItem) tr
        putBack = DS.adjust (DS.update sc destItem) sr

swapInDirection direction mirror@(Mirror grid positions) (r,c) = Mirror (swapCells grid (r,c) newPosition) (updatePositionsSet positions)
  where newPosition = (moveTowards direction (r,c))
        updatePositionsSet = (S.delete (r, c)) . (S.insert newPosition)

moveTowards North (r,c) = (r-1,c)
moveTowards South (r,c) = (r+1,c)
moveTowards East (r,c) = (r,c+1)
moveTowards West (r,c) = (r,c-1)

canRollInDirection grid direction (r,c) = M.fromMaybe False maybeAnswer
  where (targetRow, targetCol) = moveTowards direction (r,c)
        hereIsRound = ((grid `index` r) `index` c) == Round
        maybeAnswer = do
                        destinationRow <- grid !? targetRow
                        destinationCell <- destinationRow !? targetCol
                        Just (destinationCell == Empty && hereIsRound)


allIndices mirror = do
  r <- 0 `enumFromTo` (length mirror - 1)
  c <- 0 `enumFromTo` (length (mirror `index` 0) - 1)
  [(r,c)]

data Mirror = Mirror (DS.Seq (DS.Seq Cell)) (S.Set (Int, Int)) deriving (Ord, Eq, Show)
buildMirror grid = Mirror grid $ S.fromList $ filter isRound (allIndices grid)
  where isRound (r,c) = ((grid `index` r) `index` c) == Round


iterateRolling :: Mirror -> Direction -> Mirror
iterateRolling mirror@(Mirror grid roundPositions) direction = foldl (swapInDirection direction) mirror toMove
  where toMove = S.filter (canRollInDirection grid direction) $ roundPositions

rollUntilComplete direction mirror
  | iterated == mirror = mirror
  | otherwise = rollUntilComplete direction iterated
  where iterated = iterateRolling mirror direction

cycleMirror = (rollUntilComplete East) . (rollUntilComplete South) . (rollUntilComplete West) . (rollUntilComplete North) -- . traceShowId

firstDuplicatedItem seenSoFar (head:rest)
  | head `elem` seenSoFar = head
  | otherwise = firstDuplicatedItem (S.insert head seenSoFar) rest

firstDuplicatedMirror seed = firstDuplicatedItem S.empty $ iterate cycleMirror seed

cycleDescription seed = take 2 $ L.elemIndices fd $ iterate cycleMirror seed
  where fd = firstDuplicatedMirror seed

scoreMirror mirror = sum $ map scoreRow zipped
  where zipped = zip (map toList (toList $ DS.reverse mirror)) (enumFrom 1)
        scoreRow (items, rank) = rank * (length (filter (== Round) items))