Wednesday, February 18, 2015

elementary cellular automata

Takes the rule number for an elementary CA as input. The seed is provided by 600 random bits taken from rule 30. Its length, when accounting for scale, is greater than the window width; this helps keep pathological edge effects outside the visible frame. The screenshot at right shows the infamous rule 110.
import Control.Monad (when)
import Graphics.UI.SDL as SDL
import System.Environment (getArgs)

(xres, yres, unit) = (800, 600, 2)

main = withInit [InitVideo] $ do
  [n] <- getArgs
  w <- setVideoMode xres yres 32 [NoFrame]
  enableEvent SDLMouseMotion False
  setCaption "Elementary CA" "Elementary CA"
  pause w $ zip (concat $ cells (read n) seed) xys
 
pause w cs = do
  delay 128
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   KeyUp (Keysym SDLK_SPACE _ _)  -> run w cs
   _                              -> pause w cs

run w (b:bs) = do
  drawCell w b
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   KeyUp (Keysym SDLK_SPACE  _ _) -> pause w $ b:bs
   _                              -> run w bs
 
drawCell w (b, (x,y)) = do
  f =<< createRGBSurface [SWSurface] unit unit 32 0 0 0 0
  when (x `mod` 73 == 0) $ SDL.flip w
 where
  rect = Just $ Rect x y unit unit
  rgb  = if b == 1 then 0 else 0xFFFFFF
  f c  = do fillRect c Nothing $ Pixel rgb
            blitSurface c Nothing w rect
 
xys = concat . zipWith zip xs $ map repeat [0, unit..]
 where
  xs       = offset $ iterate f [-299, -298.. 300]
  offset   = map . map $ (+ (xres `div` 2)) . (* unit)
  f (n:ns) = enumFromTo (n-1) $ last ns + 1

-----------------------------------------------------

seed = take 600 . map mid . tail $ cells 30 [1]
 where
  mid xs = xs !! (length xs `div` 2)

cells n = iterate next
 where
  next  = map f . chunk . pad
  f     = maybe 0 id . (`lookup` rule n)
  pad s = [0,0] ++ s ++ [0,0]

rule = zip ns . bin
 where
  ns = map (drop 5 . bin) [7, 6..0]

bin n = map (fromEnum . (`elem` bits n)) pows
 where
  pows = reverse $ map (2^) [0..7]

bits 0 = []
bits n = let x = f n in x : bits (n-x)
 where
  f n = last $ takeWhile (<= n) $ map (2^) [0..]

chunk (a:b:c:ns) = [a,b,c] : chunk (b:c:ns)
chunk _          = []

No comments:

Post a Comment