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 #-}
{-# LANGUAGE TupleSections #-}
 
import Graphics.UI.SDL as SDL
import System.Environment (getArgs)
import System.Random.Mersenne.Pure64 (newPureMT, randomInt)
import Control.Monad (liftM2, join)
import Control.Arrow ((***))
import Data.List (delete, unfoldr)
import "hashmap" Data.HashSet (fromList, member)
import Data.HashMap.Strict (toList, fromListWith)
 
(xres, yres, cellSz) = (1600, 900, 4)
 
main = withInit [InitVideo] $ do
  win  <- setVideoMode xres yres 32 [NoFrame]
  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
  c   <- createRGBSurface [SWSurface] cellSz cellSz 32 0 0 0 0
  fillRect w (Just $ Rect 0 0 xres yres) (Pixel 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 = f . g =<< newPureMT
 where
  f = return . center . uncurry zip . splitAt 48
  g = map (`rem` 9) . unfoldr (Just . randomInt)

center = map $ (+x) *** (+y)
 where
  [x,y] = map (`div` (2 * cellSz)) [xres, yres]

----------------------------------------------------------------

next cs = [c | (c,n) <- toList neighbors,
           n == 3 || (n == 2 && member c cs')]
 where
  cs'         = fromList cs
  moore (x,y) = tail $ liftM2 (,) [x, x+1, x-1] [y, y+1, y-1]
  neighbors   = fromListWith (+) $ map (,1) $ moore =<< cs

No comments:

Post a Comment