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