generalizing langton's ant

Christopher Langton's ant can be generalized by adding states to the ant, producing automata known as turmites. Shown here is the behavior of one interesting two-state turmite, started on an empty plane. Click the thumbnail to see more generations; you'll see that this turmite always produces a framed square with the same distinctive irregular pattern.

langton's ant

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.

elementary cellular automata

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.

the game of life

I find using a point set (rather than an array) to represent this CA surprisingly convenient. It suffers no edge effects, and I suspect its average-case complexity is less, since it's a function of the live cells' population, which grows little as a typical (random) pattern evolves.

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

plenary ant

Here's a more polished edition of the basic Langton's ant previously posted. As in this version of Conway's Life, you can pause with the space key, and press r while paused to restart with a random pattern. Just for fun I also threw in colors. On exiting, the code prints the iteration count - given populous initial states, it's interesting how much this value can vary before the ant builds its inevitable highway.

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