Celular Automata (Rule 30)

Universe.hs

module Universe where

-- http://blog.sigfpe.com/2006/12/evaluating-cellular-automata-is.html

import Control.Comonad

data Universe a = Universe [a] a [a] deriving (Eq, Show)

instance Functor Universe where
  fmap f (Universe ls x rs) = Universe (map f ls) (f x) (map f rs)

left :: Universe a -> Universe a
left (Universe (l:ls) x rs) = Universe ls l (x:rs)
left (Universe []     x rs) = error "Universe.left: empty list"

right :: Universe a -> Universe a
right (Universe ls x (r:rs)) = Universe (x:ls) r rs
right (Universe ls x [])     = error "Universe.right: empty list"

instance Comonad Universe where
  extract (Universe ls x rs) = x

  -- Note that `iterate` first returns `u`, then `left u`, `left (left u)`,
  -- etc. Therefore, we ignore the first result with `tail`.
  duplicate u = Universe (tail $ iterate left u) u (tail $ iterate right u)

rule :: Universe Bool -> Bool
rule (Universe (l:ls) x (r:rs)) =
  case (l, x, r) of
    (True,  False, False) -> True
    (False, True,  True)  -> True
    (False, True,  False) -> True
    (False, False, True)  -> True
    _ -> False
rule (Universe _ x _) = error "Universe.rule: empty list"

next :: Universe a -> (Universe a -> a) -> (Universe a)
next u r = fmap r $ duplicate u

shift :: Int -> Universe a -> Universe a
shift i u = iterate direction u !! abs i
  where
  direction = if i < 0 then left else right

toList :: Int -> Int -> Universe a -> [a]
toList i j u = take (j - i) . half $ shift i u
  where
  half (Universe ls x rs) = x:rs

toString :: Int -> Universe Bool -> String
toString i u = map (\x -> if x then '#' else ' ') $ toList (-i) i u

main :: IO ()
main = do
  let universe    = Universe (repeat False) True (repeat False)
  let generations = iterate (=>> rule) universe
  putStrLn . unlines . take 20 $ map (toString 20) generations