#! /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..] ]