primitive totalistic automata

This code renders any of the 2187 possible 3-colored, 1-dimensional, totalistic cellular automata. I was charmed by these and many other beautiful demonstrations in Stephen Wolfram's notorious compendium, though I regret I can't say the same for its tendentious style.

The program input is an integer representing the intended 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..]

view raw primitive-totalistic-automata.hs hosted with ❤ by GitHub