Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Conway's game of life in Haskell and OpenGL
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 ",
" ",
" ",
" ",
" "]
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.