secret
Created

Conway's game of life in Haskell and OpenGL

  • Download Gist
conway.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
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
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.