One Dimensional CA

OneDCA.hs

-- Based on http://blog.sigfpe.com/2006/12/evaluating-cellular-automata-is.html
-- But uses the Gloss (http://hackage.haskell.org/package/gloss) library to draw the image.

module OneDCA where

import Data.Bits
import Data.Word
import Graphics.Gloss

-- Universes
data U a = U [a] a [a] deriving Eq

right :: U a -> U a
right (U ls x (r:rs)) = U  (x:ls) r rs

left :: U a -> U a
left (U (l:ls) x rs) = U ls l (x:rs)

-- Abstractions
instance Functor U where
  fmap f (U ls x rs) = U (fmap f ls) (f x) (fmap f rs)
  
coreturn :: U a -> a
coreturn (U _ x _) = x

cojoin :: U a -> U (U a)
cojoin u = U (tail $ iterate left u) u (tail $ iterate right u)

cobind :: U a -> (U a -> b) -> U b
cobind u f = fmap f $ cojoin u

-- 1-D CA
pattern :: (Bool, Bool, Bool) -> Int
pattern (four, two, one) = fromEnum four * 4
                         + fromEnum two * 2
                         + fromEnum one * 1

rule :: Word -> U Bool -> Bool
rule i (U (l:_) x (r:_)) = testBit i $ pattern (l, x, r)

step :: Word -> U Bool -> U Bool
step i u = u `cobind` (rule i)

run :: Word -> Int -> IO ()
run i d = do
  let initial = U (repeat False) True (repeat False)
  let char False = ' '
      char True  = '█'
  let line (U ls x rs) = map char $ reverse (take d ls) ++ x : take d rs
  let grid = unlines . map line
  putStrLn $ grid $ take d $ iterate (step i) initial

visualise :: Word -> (Int, Int) -> Int -> IO ()
visualise i (w, h) s = do
  let initial = U (repeat False) True (repeat False)
  let grid = take h $ iterate (step i) initial
  let picture = scale (toEnum s) (toEnum $ negate s) $
                translate 0 ((toEnum h - 0.5) / negate 2) $
                pictures [ Translate (toEnum x) (toEnum y) $
                           color white $
                           rectangleSolid 1 1
                         | (y, U ls m rs) <- [0..] `zip` grid 
                         , (x, True) <- [negate w..w] `zip` 
                                        (reverse (take w ls) ++ m : rs)]
  display (InWindow "One Dimensional Cellular Automata"
                    (w * 2 * toEnum s, h * toEnum s) (10, 10)) black picture

*OneDCA> visualise 30 (150, 150) 5