88 lines
3.2 KiB
Haskell
Executable File
88 lines
3.2 KiB
Haskell
Executable File
#! /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..] ]
|