life-0.1: Life.hs

import Data.IORef
import Data.Array
import Graphics.UI.GLUT
import System.Random
import Control.Monad

-- TODO read these from the commandline
cellsX      = 120
cellsY      = 120
scaleFactor = 6                    

-- |Conway's life is classically described with these rules:
--   * If a cell has less than 2 neighbors, it dies of loneliness
--   * If a cell has four or more neighbors, it dies of overcrowding
--   * If a cell has 2 or 3 neighbors, it continues to live
--   * If an empty cell has three neighbors, a new cell is born
--
-- Functionally it's easier to describe with just three rules:
--   * An existing cell with two neighbors is live
--   * Any cell/space with exactly three neighbors is live 
--   * All other cells/spaces are dead
rule :: Bool -> Int -> Bool
rule True 2 = True
rule _    3 = True 
rule _    _ = False    

type World = Array (Int, Int) Bool

mkWorld :: Int -> Int -> [Bool] -> World
mkWorld sx sy = listArray ((1,1),(sx,sy))

generation :: World -> World
generation w = mkWorld cellsX cellsY $ map (uncurry rule . neighborhood w) $ indices w

neighborhood :: World -> (Int, Int) -> (Bool, Int)
neighborhood world (x,y) = (world ! (x,y), length . filter id $ neighbors)
  where 
    neighbors = map (world !*) [(x-1,y-1),(x,y-1),(x+1,y-1),
                                (x-1,y  ),        (x+1,y  ),
                                (x-1,y+1),(x,y+1),(x+1,y+1)]
    (!*) :: World -> (Int, Int) -> Bool
    w !* (x,y) = w ! (wrap cellsX x, wrap cellsY y)
        where wrap bound val | val <  1    = wrap bound $ val + bound - 1
                             | val > bound = wrap bound $ val - bound + 1
                             | otherwise   = val

main :: IO ()
main = do
  rng <- newStdGen
  let world = (mkWorld cellsX cellsY . map toEnum . randomRs (0,1)) rng
  worldRef <- newIORef $ world

  getArgsAndInitialize
  initialDisplayMode $= [ DoubleBuffered ]

  let screenX = fromIntegral $ cellsX * scaleFactor
      screenY = fromIntegral $ cellsY * scaleFactor

  initialWindowSize $= Size screenX screenY
  createWindow "Conway's Life"

  idleCallback $= Just (updateWorld worldRef)

  clearColor $= Color4 0 0 0 0
  ortho 0.0 (fromIntegral screenX) 0.0 (fromIntegral screenY) (-1.0) 1.0
  mainLoop

updateWorld :: IORef World -> IO ()
updateWorld wr = do 
  atomicModifyIORef wr $ \w -> (generation w, ())
  drawWorld wr

v2 :: GLfloat -> GLfloat -> Vertex2 GLfloat
v2 x y = Vertex2 x y :: Vertex2 GLfloat

drawWorld :: IORef World -> IO ()
drawWorld wr = do 
  world <- readIORef wr
  clear [ColorBuffer]
  sequence [drawCell world x y | x <- [1..cellsX], y <- [1..cellsY]]
  swapBuffers
  flush

drawCell :: World -> Int -> Int -> IO ()
drawCell world x y = do
  let sf = fromIntegral scaleFactor
      sx = (fromIntegral x) * sf :: GLfloat
      sy = (fromIntegral y) * sf :: GLfloat

  currentColor $= (cellColor $ world ! (x,y))
  renderPrimitive Polygon $ do
                       vertex $ v2 sx sy 
                       vertex $ v2 sx (sy + sf)
                       vertex $ v2 (sx + sf) (sy + sf)
                       vertex $ v2 (sx + sf) sy
      where 
        cellColor True  = Color4 1 1 1 1
        cellColor False = Color4 0 0 0 1