Conway's game of life in Haskell and OpenGL

conway.hs

module Conway where

import Data.List (intercalate)
import Control.Monad (liftM)
import Control.Concurrent (threadDelay)
import System.Console.ANSI (clearScreen)

type Board = [[Bool]]
data Game = Game {gameBoard :: Board, gameAge :: Integer}

instance Show Game where
    show (Game board _) = unlines [border, "|" ++ intercalate "|\n|" (map (map toChar) board) ++ "|", border]
        where
            toChar False = ' '
            toChar True  = '\x2588'
            (w, _) = boardSize board
            border = "+" ++ replicate (w + 1) '-' ++ "+"

mkGame :: (Int, Int) -> Game
mkGame (w, h) = Game (replicate h $ replicate w False) 0

readGame :: String -> Game
readGame text = Game (map (map (/= ' ')) $ lines text) 0

boardSize :: Board -> (Int, Int)
boardSize board = (length (head board) - 1, length board - 1)

determineFate :: Board -> (Int, Int) -> Bool
determineFate board (x, y)
    -- Since order doesn't matter, I decided to arrange the statements in such a
    -- way that it makes it more obvious which cells each one is checking
    -- Upper left corner
    | (x, y) == (0, 0) = isAlive $ map at [            (  1,   0),
                                           (  0,   1), (  1,   1)]
    -- Upper right corner
    | (x, y) == (w, 0) = isAlive $ map at [(w-1,   0),
                                           (w-1,   1), (  w,   1)]
    -- Lower left corner
    | (x, y) == (0, h) = isAlive $ map at [(  0, h-1), (  1, h-1),
                                           (  1,   h)]
    -- Lower right corner
    | (x, y) == (w, h) = isAlive $ map at [(w-1,   h), (  w, h-1),
                                           (w-1, h-1)]
    -- Top row
    | y == 0           = isAlive $ map at [(x-1,   0),             (x+1,   0),
                                           (x-1,   1), (  x,   1), (x+1,   1)]
    -- Bottom row
    | y == h           = isAlive $ map at [(x-1, h-1), (  x, h-1), (x+1, h-1),
                                           (x-1,   h),             (x+1,   0)]
    -- Left column
    | x == 0           = isAlive $ map at [(  0, y-1), (  1, y-1),
                                                       (  1,   y),
                                           (  0, y+1), (  1, y+1)]
    -- Right column
    | x == w           = isAlive $ map at [(w-1, y-1), (  w, y-1),
                                                       (w-1,   y),
                                           (w-1, y+1), (  w, y+1)]
    -- Anywhere else
    | otherwise        = isAlive $ map at [(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)]
    where
        at :: (Int, Int) -> Bool
        at (x', y') = (board !! y') !! x'
        current = at (x, y)
        (w, h)  = boardSize board
        isAlive :: [Bool] -> Bool
        isAlive neighbors =
            case length $ filter id neighbors of
                0         -> False
                1         -> False
                2         -> current
                3         -> True
                otherwise -> False

isAlive :: Game -> Bool
isAlive (Game board _) = any or board

stepGame :: Game -> Game
stepGame (Game board age) = Game newBoard (age + 1)
    where
        (w, h) = boardSize board
        newBoard = map (map (determineFate board)) [[(x, y) | x <- [0..w]] | y <- [0..h]]

main :: IO ()
main = do
    putStr "Enter the number of iterations to perform: "
    maxAge <- liftM read getLine :: IO Integer -- If 0 then will repeat until dead
    let loop game = do
        clearScreen
        print game
        if (maxAge > 0 && gameAge game >= maxAge) || not (isAlive game) then
            return $ gameAge game
        else do
            let newGame = stepGame game
            threadDelay 500000
            loop newGame
    endAge <- loop testGame
    putStrLn $ "Ran for " ++ show endAge ++ " iterations."

testGame :: Game
testGame = readGame $ unlines [
    "    O     ",
    "     OO   ",
    "    OOO   ",
    " OO  O    ",
    "  O  O O  ",
    "      O   ",
    "          ",
    "          ",
    "          ",
    "          "]

main.hs

module Main where

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT
import Data.IORef
import Data.List
import Data.Maybe
import Control.Monad
import Control.Concurrent (threadDelay, forkIO)

import Conway hiding (main)

type Running    = Bool
type Toggle     = Maybe (Int, Int) -- Index
type LastToggle = Maybe (Int, Int)
type ClearFlag  = Bool
data GameState  = GameState Running Toggle LastToggle ClearFlag

main :: IO ()
main = do
    (progname, _) <- getArgsAndInitialize
    initialDisplayMode $= [DoubleBuffered]
    initialWindowSize $= Size 300 300
    initialWindowPosition $= Position 100 100
    createWindow "Game of Life"

    game <- newIORef (mkGame (30, 30))
    stateFlag <- newIORef (GameState False (Just (-1, -1)) (Just (-1, -1)) False)

    displayCallback $= clearScreen game stateFlag
    keyboardMouseCallback $= Just (keyboardMouseStart game stateFlag)
    motionCallback $= Just (mouseDrag game stateFlag)
    clear [ColorBuffer]
    mainLoop

clearScreen game stateFlag = do
    clear [ColorBuffer]
    swapBuffers
    displayCallback $= display game stateFlag

display game stateFlag = do
    clear [ColorBuffer]
    (GameState running toggle lastToggle clearFlag) <- get stateFlag
    --putStrLn $ show toggle ++ "\t" ++ show lastToggle
    g <- get game
    if running then do
        let newGame = stepGame g
        game $= newGame
        redraw game
        swapBuffers
        stateFlag $= GameState running toggle lastToggle clearFlag
        addTimerCallback 100 (display game stateFlag)
    else when (isJust toggle && toggle /= lastToggle) $ do
        let (Just (x, y)) = toggle
        unless (x == (-1) || y == (-1)) $ do
            let board = gameBoard g
                current = (board !! y) !! x
                replaceAt n item ls = a ++ (item:b) where (a, _:b) = splitAt n ls
                newBoard = replaceAt y (replaceAt x (not current) (board !! y)) board
                newGame' = Game newBoard (gameAge g)
            game $= newGame'
            redraw game
            swapBuffers
        stateFlag $= GameState running (Just (-1, -1)) toggle clearFlag
    when clearFlag $ do
        redraw game
        swapBuffers
        stateFlag $= GameState running toggle lastToggle False

drawCell on r c = do
    color $ if on then Color3 (1.0 :: GLfloat) 1.0 1.0 else Color3 (0.0 :: GLfloat) 0.0 0.0
    let r' = fromIntegral r :: GLfloat
        c' = fromIntegral c :: GLfloat
        neg = (*) (-1)
        x1 = 10.0 * r' / 150.0 - 1.0
        y1 = neg $ 10.0 * c' / 150.0 - 1.0
        x2 = (10.0 * r' + 9.0) / 150.0 - 1.0
        y2 = neg $ (10.0 * c' + 9.0) / 150.0 - 1.0
    renderPrimitive Polygon $
        mapM_ (\(x, y) -> vertex $ Vertex3 x y 0) [(x1, y1), (x2, y1), (x2, y2), (x1, y2)]

redraw game = do
    clear [ColorBuffer]
    g <- get game
    let board = gameBoard g
        (w, h) = boardSize board
    sequence_ $ concat [[drawCell ((board !! c) !! r) r c | r <- [0..w]] | c <- [0..h]]

keyboardMouseStart game stateFlag key state modifiers position = case (key, state) of
    (MouseButton LeftButton, Down) -> mouseDrag game stateFlag position
    (Char ' ', Up) -> do
        (GameState running toggle lastToggle clearFlag) <- get stateFlag
        stateFlag $= GameState True Nothing Nothing clearFlag
        keyboardMouseCallback $= Just (keyboardMouseEnd game stateFlag)
        motionCallback $= Nothing
        display game stateFlag
    (Char 'c', Up) -> do
        game $= mkGame (30, 30)
        stateFlag $= GameState False Nothing Nothing True
        display game stateFlag
    otherwise -> return ()

keyboardMouseEnd game stateFlag key state modifiers position = case (key, state) of
    (Char ' ', Up) -> do
        (GameState running toggle lastToggle clearFlag) <- get stateFlag
        stateFlag $= GameState False toggle lastToggle clearFlag
        keyboardMouseCallback $= Just (keyboardMouseStart game stateFlag)
        motionCallback $= Just (mouseDrag game stateFlag)
        display game stateFlag
    otherwise -> return ()

mouseDrag game stateFlag (Position m_x m_y) = do
    (GameState running toggle lastToggle clearFlag) <- get stateFlag
    let x = fromIntegral (if m_x `mod` 10 > 0 then m_x `div` 10 else -1) :: Int
        y = fromIntegral (if m_y `mod` 10 > 0 then m_y `div` 10 else -1) :: Int
    stateFlag $= GameState running (Just (x, y)) lastToggle clearFlag
    display game stateFlag