For a round of code golf, I wrote this spare implementation of Chris Langton's remarkably simple universal computer. If you want amenities like pause, random starting pattern or even quit, check out this more complete version.
This 'lava lamp' is actually a simple cyclic cellular automaton; the CA rule is courtesy of Jason Rampe. In keeping with the spirit of Haskell, I chose to implement it with a hashmap of points rather than an array. Needless to say, that's not practical; but this is just a demonstration.
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.
This code takes the rule number for an elementary cellular automaton as input, and then runs the CA from a random seed, rendering the result. The seed comprises 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 left shows an execution of the famous rule 110.
For my own conviction, it was enough to find that the expression sum (take 80 $ rands 5000) `div` 80 produces 2525.
Since each random bit requires computing a full cell generation, this algorithm quickly slows down. I assume more pragmatic implementations solve this by perhaps re-seeding the automaton after some number of iterations.
An array representation on the other hand, grows proportionally with the area spanned by all live cells. Since random patterns quite often fire gliders in opposite directions, this area can grow very quickly.
Anyway, this program takes a .cells pattern file for an optional argument; you can also press 'r' while paused for a random pattern, or click to create your own.
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TupleSections #-}
import Graphics.UI.SDL as SDL
import System.Environment (getArgs)
import Control.Arrow ((***))
import Control.Monad (liftM2, join)
import Data.List (delete, unfoldr)
import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
import qualified "hashmap" Data.HashSet as S
import qualified "unordered-containers" Data.HashMap.Strict as M
(xres, yres, cellSz) = (1600, 900, 3)
main = withInit [InitVideo] $ do
win <- setVideoMode xres yres 32 [Fullscreen]
args <- getArgs
pat <- case args of
[s] -> loadPattern s
_ -> return []
enableEvent SDLMouseMotion False
setCaption "Life" "Life"
pause win pat
pause w cs = do
delay 128
drawCells w cs
e <- pollEvent
case e of
KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
KeyUp (Keysym SDLK_SPACE _ _) -> run w cs
KeyUp (Keysym SDLK_r _ _) -> pause w =<< randPattern
MouseButtonUp x y _ -> click (scale x, scale y)
_ -> pause w cs
where
scale = (`div` cellSz) . fromIntegral
click c | c `elem` cs = pause w $ delete c cs
| otherwise = pause w $ c:cs
run w cs = do
drawCells w cs
e <- pollEvent
case e of
KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
KeyUp (Keysym SDLK_SPACE _ _) -> pause w cs
_ -> run w $ next cs
drawCells w cs = do
fillRect w (Just $ Rect 0 0 xres yres) (Pixel 0)
c <- createRGBSurface [SWSurface] cellSz cellSz 32 0 0 0 0
mapM_ (draw c . scale) cs
SDL.flip w
where
rect (x,y) = Just $ Rect x y cellSz cellSz
scale = join (***) (* cellSz)
draw c p = do fillRect c Nothing $ Pixel 0xFFFFFF
blitSurface c Nothing w $ rect p
----------------------------------------------------------------
loadPattern = fmap parse . readFile -- reads .cells format
where
parse = center . clean . coord . strip . lines
strip = dropWhile $ (== '!') . head
coord = zipWith zip $ map (zip [0..] . repeat) [0..]
clean = concatMap $ map fst . filter ((== 'O') . snd)
randPattern = fmap f newPureMT
where
f = center . uncurry zip . splitAt 48 . g
g = map (`rem` 9) . unfoldr (Just . randomInt)
center = map $ (x+) *** (+y)
where
[x,y] = map (`div` (2 * cellSz)) [xres, yres]
next cs = [i | (i,n) <- M.toList neighbors,
n == 3 || (n == 2 && S.member i cs')]
where
cs' = S.fromList cs
moore (x,y) = tail $ liftM2 (,) [x, x+1, x-1] [y, y+1, y-1]
neighbors = M.fromListWith (+) $ map (,1) $ moore =<< cs
import Data.Bits (shift)
import Data.List (unfoldr)
import Control.Arrow ((***))
import Control.Monad (when, join)
import Data.Set (insert, delete, member, empty, fromList, toList)
import Graphics.UI.SDL as SDL
import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
(xres, yres, sq, cast) = (1600, 900, 3, fromIntegral)
origin = (xres `div` 2 `div` sq, yres `div` 2 `div` sq)
main = withInit [InitVideo] $ do
w <- setVideoMode xres yres 32 [NoFrame]
enableEvent SDLMouseMotion False
setCaption "Langton's Ant" "Langton's Ant"
pause w origin (0,1) empty
pause w p v ps = do
delay 128
e <- pollEvent
case e of
KeyUp (Keysym SDLK_ESCAPE _ _) -> return ()
KeyUp (Keysym SDLK_SPACE _ _) -> run w [1..] p v ps
KeyUp (Keysym SDLK_r _ _) -> randomize
_ -> pause w p v ps
where
randomize = do
ps <- randPattern
render w ps
pause w origin (0,1) ps
run w (n:ns) p v ps = do
when (n `mod` 7 == 0) $ render w ps
e <- pollEvent
case e of
KeyUp (Keysym SDLK_ESCAPE _ _) -> print n
KeyUp (Keysym SDLK_SPACE _ _) -> pause w p v ps
_ -> continue
where
continue = run w ns (move p $ g v) (g v) $ f p ps
b = member p ps
f = if b then delete else insert
g = if b then fl else fr
move (x,y) = (x+) *** (+y)
fr (x,y) = if x == 0 then (-y,x) else (y,x)
fl (x,y) = if x == 0 then (y,x) else (y,-x)
render w ps = do
fillRect w (Just $ Rect 0 0 xres yres) $ Pixel 0
mapM_ (draw w . join (***) (* sq)) $ toList ps
SDL.flip w
draw w p = f p =<< g [SWSurface] sq sq 32 0 0 0 0
where
rect x y = Just $ Rect x y sq sq
g = createRGBSurface
f (x,y) s = do fillRect s (rect 0 0) $ Pixel $ rgb x y
blitSurface s (rect 0 0) w $ rect x y
randPattern = fmap (fromList . f) newPureMT
where
f = center . uncurry zip . splitAt 11000 . g
g = map (`rem` 512) . unfoldr (Just . randomInt)
center = map $ (x+) *** (+y)
where
[x,y] = map (`div` (2 * sq)) [xres, yres]
rgb x y = shift r 16 + shift g 8 + 128
where
r = round $ (cast x / cast xres) * 255
g = round $ (cast y / cast yres) * 255