Sunday, May 22, 2011

the game of life

A simple set-based algorithm. Takes a .cells pattern file for an optional argument; press 'r' while paused for a random pattern.
{-# LANGUAGE PackageImports #-}
 
import Graphics.UI.SDL as SDL
import System.Environment (getArgs)
import Control.Monad (liftM2)
import Control.Arrow ((***))
import Data.List (delete, unfoldr)
import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
import qualified "hashmap" Data.HashSet as Set (filter)
import "hashmap" Data.HashSet (toList, fromList,
  difference, size, union, intersection)
  
(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 100
  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
  delay 64
  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)
  s <- createRGBSurface [SWSurface] cellSz cellSz 32 0 0 0 0
  mapM_ (draw s . scale) cs
  SDL.flip w
 where
  rect x y     = Just $ Rect x y cellSz cellSz
  scale (x,y)  = (x * cellSz, y * cellSz)
  draw s (x,y) = do fillRect s (rect 0 0) (Pixel 0xFFFFFF)
                    blitSurface s (rect 0 0) w (rect x y)
  
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 = do
  gen <- newPureMT
  let ints = map (`rem` 9) $ unfoldr (Just . randomInt) gen
  return . center . uncurry zip $ splitAt 48 ints
  
center = map $ (+x) *** (+y)
 where
  [x,y] = map (`div` (2 * cellSz)) [xres, yres]
  
----------------------------------------------------------------
 
next cells = toList $ Set.filter live cs `union` births
 where
  live        = (`elem` [2, 3]) . neighbors
  born        = (3 ==) . neighbors
  neighbors   = size . intersection cs . fromList . moore
  births      = Set.filter born $ mooreSet `difference` cs
  mooreSet    = fromList . concatMap moore $ toList cs
  moore (x,y) = tail $ liftM2 (,) [x, x+1, x-1] [y, y+1, y-1]
  cs          = fromList cells

No comments:

Post a Comment