Day 12, parts 1 & 2: Initial solution.

Day12/Part1.hs

@@ -0,0 +1,87 @@
+#! /usr/bin/env stack
+-- stack --resolver lts-12.20 --install-ghc script
+{-# LANGUAGE ViewPatterns, DeriveFunctor, BangPatterns, LambdaCase #-}
+module Main where
+
+import Control.Applicative
+import Control.Comonad
+import Control.Monad.State
+import Data.Maybe
+import Data.Monoid
+
+import qualified Data.List as L
+
+import Debug.Trace
+
+main = interact $ solve . parseInput
+
+data Stream a = Cons a (Stream a) deriving Functor
+data Zipper a = Zipper (Stream a) a (Stream a) deriving Functor
+
+type Pots = Zipper Bool
+
+iterateS :: (a -> a) -> a -> Stream a
+iterateS f a = Cons a (iterateS f (f a))
+
+zipWithS :: (a -> b -> c) -> Stream a -> Stream b -> Stream c
+zipWithS f (Cons a as) (Cons b bs) = Cons (f a b) (zipWithS f as bs)
+
+zipS :: Stream a -> Stream b -> Stream (a, b)
+zipS = zipWithS (,)
+
+zipWithZ :: (a -> b -> c) -> Zipper a -> Zipper b -> Zipper c
+zipWithZ f (Zipper l1 c1 r1) (Zipper l2 c2 r2) =
+   Zipper (zipWithS f l1 l2) (f c1 c2) (zipWithS f r1 r2)
+
+zipZ :: Zipper a -> Zipper b -> Zipper (a, b)
+zipZ = zipWithZ (,)
+
+identityZ :: Num a => Zipper a
+identityZ = Zipper (iterateS (subtract 1) (-1)) 0 (iterateS (+1) 1)
+
+window :: Int -> Zipper a -> [a]
+window n (Zipper ls c rs) = go n ls rs [c]
+   where
+      go n (Cons l ls) (Cons r rs)
+         | n <= 0    = id
+         | otherwise = go (n-1) ls rs . (l:) . (++[r])
+
+moveLeft :: Zipper a -> Zipper a
+moveLeft (Zipper (Cons l ls) c rs) = Zipper ls l (Cons c rs)
+
+moveRight :: Zipper a -> Zipper a
+moveRight (Zipper ls c (Cons r rs)) = Zipper (Cons c ls) r rs
+
+instance Comonad Zipper where
+   extract (Zipper _ c _) = c
+   duplicate z = Zipper (iterateS moveLeft (moveLeft z))
+                        z
+                        (iterateS moveRight (moveRight z))
+
+parseInput :: String -> (Int, Pots, Pots -> Pots)
+parseInput = evalState $ do
+   state (break (`elem` "#."))
+   initial <- map (=='#') <$> state (span (`elem` "#."))
+   rules <- fmap (fmap (fromMaybe False . getFirst . mconcat) . sequence)
+          $ replicateM 32 $ do
+      state (break (`elem` "#."))
+      rst <- get
+      if not (any (`elem` "#.") (take 1 rst)) then pure mempty else do
+         [a,b,c,d,e] <- map (=='#') <$> state (span (`elem` "#."))
+         state (break (`elem` "#."))
+         to <- (=='#') <$> state (\(h:t) -> (h, t))
+         pure $ \z -> if extract (moveLeft (moveLeft z)) == a
+                      && extract (moveLeft z) == b
+                      && extract z == c
+                      && extract (moveRight z) == d
+                      && extract (moveRight (moveRight z)) == e
+                      then First (Just to) else mempty
+   let initialZ = moveRight $ Zipper (iterateS id False) False
+                $ foldr Cons (iterateS id False) initial
+   pure (length initial, initialZ, extend rules)
+
+render n = window n . zipWithZ (\n v -> if v then '#' else '.') identityZ
+
+solve (n, initial, step) = show $ sum $ window (n + 40) $ zipWithZ (\n v -> if v then n else 0) identityZ $ iterate step initial !! 20
+--solve (n, initial, step) = unlines $ map (render (n + 40)) $ iterate step initial
+--solve (n, initial, step) = unlines $ [ show $ (,) g $ sum $ window (n + g) $ zipWithZ (\n v -> if v then n else 0) identityZ $ states !! g | let states = iterate step initial, g <- [0..] ]

Day12/Part2.hs

@@ -0,0 +1,30 @@
+#! /usr/bin/env stack
+-- stack --resolver lts-12.20 --install-ghc script
+module Main where
+
+-- After 101 generations a regular pattern emerges:
+-- 
+-- (101,3516)
+-- (102,3541)
+-- (103,3566)
+-- (104,3591)
+-- (105,3616)
+-- (106,3641)
+-- (107,3666)
+-- (108,3691)
+-- (109,3716)
+-- (110,3741)
+-- (111,3766)
+-- (112,3791)
+-- ...
+
+main = print solution
+   where
+      n = 50000000000
+      solution = 3500
+               + ((n - 101) `div` 4) * 100
+               + (case n `mod` 4 of
+                    1 -> 16
+                    2 -> 41
+                    3 -> 66
+                    0 -> 91)

Day12/input.txt

@@ -0,0 +1,34 @@
+initial state: #.#.#..##.#....#.#.##..##.##..#..#...##....###..#......###.#..#.....#.###.#...#####.####...#####.#.#
+
+..#.. => .
+#...# => .
+.#... => #
+#.##. => .
+..#.# => #
+#.#.# => .
+###.. => #
+###.# => #
+..... => .
+....# => .
+.##.. => #
+##### => .
+####. => .
+..##. => .
+##.#. => #
+.#..# => #
+##..# => .
+.##.# => .
+.#### => #
+..### => .
+...## => #
+#..## => #
+#.... => .
+##.## => .
+#.#.. => .
+##... => .
+.#.## => #
+.###. => #
+...#. => .
+#.### => .
+#..#. => #
+.#.#. => .

Day12/sample.txt

@@ -0,0 +1,16 @@
+initial state: #..#.#..##......###...###
+
+...## => #
+..#.. => #
+.#... => #
+.#.#. => #
+.#.## => #
+.##.. => #
+.#### => #
+#.#.# => #
+#.### => #
+##.#. => #
+##.## => #
+###.. => #
+###.# => #
+####. => #