Monday, March 30, 2015

primitive totalistic automata

This code renders any of the 2187 possible 3-colored, 1-dimensional totalistic CAs; its input is an integer representing the CA rule in base 3.
import Control.Monad (when)
import Data.List (group, unfoldr)
import Graphics.UI.SDL as SDL
import System.Environment (getArgs)
import System.Random.Mersenne.Pure64 (pureMT, randomInt)

(xres, yres, unit) = (400, 400, 2)

main = withInit [InitVideo] $ do
  [n] <- getArgs
  w   <- setVideoMode xres yres 32 [NoFrame]
  enableEvent SDLMouseMotion False
  setCaption "Elementary CA" "Elementary CA"
  run w $ zip (concat $ cells (read n) seed) xys
 
run w (b:bs) = do
  drawCell w b
  e <- pollEvent
  case e of
   KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
   _                              -> run w bs
 
drawCell w (b, (x,y)) = do
  f =<< createRGBSurface [SWSurface] unit unit 32 0 0 0 0
  when (x `mod` 157 == 0) $ SDL.flip w
 where
  rect = Just $ Rect x y unit unit
  rgb  = maybe 0 id $ lookup b rgbs
  rgbs = [(0, 0xffffff), (1, 0x225577), (2,0)]
  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 (`mod` 3) ns
 where
  ns = unfoldr (Just . randomInt) $ pureMT 71

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

chunk [_,_] = []
chunk ns    = take 3 ns : chunk (tail ns)

tern n = map (length . f) pows
 where
  pows = map ((:[]) . (3^)) [6,5..0]
  f m  | m `elem` group (bits n)        = m
  f m  | (m ++ m) `elem` group (bits n) = m ++ m
       | otherwise                      = []

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

No comments:

Post a Comment