day14 slow

day14.hs

@@ -0,0 +1,114 @@
+{-# options_ghc -Wall #-}
+{-# language BlockArguments #-}
+import Data.List
+import System.Environment
+import qualified Data.Map as M
+import Data.Maybe
+
+
+data Block = Rock | Space | Wall deriving (Eq, Ord, Show)
+
+block :: Char -> Maybe Block
+block 'O' = Just Rock
+block '.' = Just Space
+block '#' = Just Wall
+block _   = Nothing
+
+type Board = [[Block]]
+
+board :: String -> Board
+board = map (map block') . lines where
+  block' :: Char -> Block
+  block' c = fromMaybe (error $ "unrecognised " ++ show c) $ block c
+
+chunks :: (a -> Bool) -> [a] -> [[a]]
+chunks _ [] = []
+chunks want (x : xs)
+  | want x    = let (as, bs) = span  want xs in (x : as) : chunks want bs
+  | otherwise = let (as, bs) = break want xs in (x : as) : chunks want bs
+
+fall :: Ord a => (a -> Bool) -> [a] -> [a]
+fall p = concat . map sort . chunks p
+
+rotateLeft :: [[a]] -> [[a]]
+rotateLeft = transpose . map reverse
+
+rotateRight :: [[a]] -> [[a]]
+rotateRight = map reverse . transpose
+
+rotate180 :: [[a]] -> [[a]]
+rotate180 = reverse . map reverse
+
+fallLeft, fallUp, fallRight, fallDown :: Board -> Board
+fallLeft  = map $ fall (/= Wall)
+fallUp    = rotateRight . fallLeft . rotateLeft
+fallRight = rotate180 . fallLeft . rotate180
+fallDown  = rotateLeft . fallLeft . rotateRight
+
+scoreWith :: (a -> Bool) -> [[a]] -> Int
+scoreWith p xss =
+  let ℓ = length xss; ℓs = [ℓ, ℓ-1 .. 0] in
+  sum $ zipWith (\xs y -> length (filter p xs) * y) xss ℓs
+
+score :: Board -> Int
+score = scoreWith (== Rock)
+
+part1 :: Board -> Int
+part1 = score . fallUp
+
+type Cycle = (Board, Board, Board, Board)
+
+cycle1 :: Board -> Cycle
+cycle1 xs =
+  let as = fallUp xs
+      bs = fallLeft as
+      cs = fallDown bs
+      ds = fallRight cs in
+  (as, bs, cs, ds)
+
+nextCycle :: Cycle -> Cycle
+nextCycle (_, _, _, xs) = cycle1 xs
+
+cycles :: Board -> [Cycle]
+cycles start = let c = cycle1 start in iterate nextCycle c
+
+fourth :: (a,b,c,d) -> d
+fourth (_,_,_,d) = d
+
+findRepeat :: Ord a =>
+  M.Map a Int -> M.Map Int a ->
+  Int -> [a] -> (Int, Int, M.Map Int a)
+findRepeat ai ia i (a:as)
+  | Just j <- M.lookup a ai = (j, i, ia)
+  | otherwise               = findRepeat ai' ia' (i + 1) as
+    where ai' = M.insert a i ai; ia' = M.insert i a ia
+findRepeat _ _ _ _ = error "you said it was infinite"
+
+part2 :: Board -> Int
+part2 ℓs =
+  let loops      = 1_000_000_000
+      (m, n, xs) = findRepeat M.empty M.empty 0 $ cycles ℓs
+      index      = (loops - n) `mod` (n - m) - 1 in
+  score $ fourth $ xs M.! (m + index)
+
+main :: IO ()
+main = do
+  [part, file] <- getArgs
+  ℓs <- board <$> readFile file
+  case part of
+    "1" -> print $ part1 ℓs
+    "2" -> print $ part2 ℓs
+    _   -> error "usage: $0 <part> <file>"
+
+example1 :: [String]
+example1 =
+  ["O....#....",
+   "O.OO#....#",
+   ".....##...",
+   "OO.#O....O",
+   ".O.....O#.",
+   "O.#..O.#.#",
+   "..O..#O..O",
+   ".......O..",
+   "#....###..",
+   "#OO..#...."]