Day 14 part 1 done, day 2 mostly

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index 04700237d2bc78a6ab1b48e47aea9c71bed1a129..5af0b4b4655eacccac392fa60eee001841d92219 100644 (file)
--- a/advent-of-code23.cabal
+++ b/advent-of-code23.cabal
@@ -181,3 +181,8 @@ executable advent13
   import: common-extensions, build-directives
   main-is: advent13/Main.hs
   build-depends: split
+
+executable advent14
+  import: common-extensions, build-directives
+  main-is: advent14/Main.hs
+  build-depends: containers

diff --git a/advent14/Main.hs b/advent14/Main.hs
new file mode 100644 (file)
index 0000000..efd4db6
--- /dev/null
+++ b/advent14/Main.hs
@@ -0,0 +1,92 @@
+-- Writeup at https://work.njae.me.uk/2023/12/15/advent-of-code-2023-day-13/
+
+import AoC
+import Data.List
+import Data.Semigroup
+import Data.Monoid
+import qualified Data.Map.Strict as M
+
+data Element = Empty | Cube | Round deriving (Show, Eq, Ord)
+type Grid = [[Element]]
+
+type Cache = M.Map Grid Int
+
+
+main :: IO ()
+main = 
+  do  dataFileName <- getDataFileName
+      text <- readFile dataFileName
+      let grid = transpose $ fmap (fmap readElem) $ lines text
+      -- print grid
+      -- print $ rollGrid $ transpose grid
+      -- let r1 = rollToCompletion grid
+      -- print r1
+      -- putStrLn $ showGrid r1
+      -- print $ transpose $ fmap reverse r1
+      print $ part1 grid
+      -- print $ rollCycle grid
+      -- putStrLn $ showGrid $ rollCycle grid
+      -- putStrLn $ showGrid $ rollCycle $ rollCycle grid
+      -- putStrLn $ showGrid $ rollCycle $ rollCycle $ rollCycle grid
+      -- print $ findRepeat grid
+
+
+
+      print $ part2 grid
+      -- print $ part2 patts
+
+part1 :: Grid -> Int
+part1 grid = scoreGrid grid'
+  where grid' = rollToCompletion grid
+
+part2 grid = scoreGrid finalGrid
+  where (grid', cache, i) = findRepeat grid
+        repeatStart = cache M.! grid'
+        repeatLen = i - repeatStart
+        finalIndex = (1e9 - repeatStart - 1) `mod` repeatLen
+        (finalGrid, _) = M.findMin $ M.filter (== finalIndex) cache
+
+readElem :: Char -> Element
+readElem '.' = Empty
+readElem '#' = Cube
+readElem 'O' = Round
+
+rollToCompletion :: Grid -> Grid
+rollToCompletion grid = fst $ head $ dropWhile (uncurry (/=)) $ zip states $ tail states
+  where states = iterate rollGrid grid
+
+rollGrid :: Grid -> Grid
+rollGrid = fmap roll
+
+roll :: [Element] -> [Element]
+roll [] = []
+roll (l:ls) = rs ++ [r]
+  where (rs, r) = foldl' rollStep ([], l) ls
+
+rollStep :: ([Element], Element) -> Element -> ([Element], Element)
+rollStep (handled, Empty) Round = (handled ++ [Round], Empty)
+rollStep (handled, target) source = (handled ++ [target], source)
+
+scoreGrid :: Grid -> Int
+scoreGrid grid = sum $ fmap scoreRow indexedGrid
+  where indexedGrid = zip [1..] $ reverse $ transpose grid
+        scoreRow (i, r) = i * (length $ filter (== Round) r)
+
+rotate1 :: Grid -> Grid
+rotate1 = transpose . fmap reverse
+
+rollCycle :: Grid -> Grid
+rollCycle = appEndo (stimes 4 (Endo rotate1 <> Endo rollToCompletion))
+
+showGrid :: Grid -> String
+showGrid grid = unlines $ fmap (fmap showElem) $ transpose grid
+  where showElem Empty = '.'
+        showElem Cube = '#'
+        showElem Round = 'O'
+
+
+rollCycleWithCache (grid, cache, index) = (rollCycle grid, M.insert grid index cache, (index + 1))
+
+findRepeat grid = head $ dropWhile test $ iterate rollCycleWithCache (grid, M.empty, 0)
+  where test (g, c, i) = g `M.notMember` c
+