Create a gist now

Instantly share code, notes, and snippets.

@bheklilr /conway.hs Secret
Created Feb 1, 2013

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