Sunday, May 22, 2011

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