SnakeHS - OpenGL Snake game on Haskell

SnakeHS.hs

import Graphics.UI.GLUT
import Data.IORef
import Data.List (delete)
import System.Random (randomRIO)
import Control.Monad (forM_, when)

type Coord          = (Int, Int)
type Snake          = (Direction, [Coord])
type SnakeDigestion = [Coord]
type Food           = [Coord]
type Points         = Int

data GameStatus     = GameOver | Pause | Play
                    deriving(Eq, Show, Read)

data Direction      = UP | DOWN | LEFT | RIGHT
                    deriving(Eq, Show, Read)

data GameState      = GameState {
      snake      :: Snake
    , food       :: Food
    , digestion  :: SnakeDigestion
    , gameStatus :: GameStatus
    , points     :: Points
    , speed      :: Int
    , startWall  :: Int
    , cmdStack   :: [Direction]
    , wall       :: Int
    , walked     :: Bool
    }
                      deriving(Show, Read)

main = do
  initialize "SnakeHS" []
  initialDisplayMode $= [RGBAMode, DoubleBuffered]
  initialWindowSize  $= Size 600 600
  gameState  <- newGame
  createWindow "SnakeHS"
  displayCallback $= display gameState
  snakeMotion gameState
  keyboardMouseCallback $= Just (keyboardMouse gameState)
  mainLoop

newGame :: IO (IORef GameState)
newGame = do
  gameState  <- newIORef (GameState {
                            snake      = (UP, [(0,0)])
                          , food       = []
                          , digestion  = []
                          , gameStatus = Play
                          , points     = 0
                          , speed      = 190
                          , wall       = 10
                          , startWall  = 10
                          , cmdStack   = []
                          , walked     = False
                          }
                          :: GameState)
  generateFood gameState
  return gameState

snakeMotion, execCmdStack, eatFood, generateFood, growthSnake, mutateGame :: IORef GameState -> IO ()
snakeMotion gameState = do
  gameState'    <- readIORef gameState
  let gameStatus' = gameStatus gameState'
  case gameStatus' of 
    GameOver -> addTimerCallback (speed gameState' * 2) $ snakeMotion gameState --putStrLn "Game Over"
    Pause    -> addTimerCallback (speed gameState') $ snakeMotion gameState
    Play     -> do
      processGame gameState
      addTimerCallback (speed gameState') $ snakeMotion gameState
  postRedisplay Nothing

processGame gameState = do
  execCmdStack gameState      
  newGameState' <- readIORef gameState 
  moveSnake gameState (fst $ snake newGameState') True
  eatFood gameState    
  growthSnake gameState                 
  mutateGame gameState

eatFood gameState = do
  gameState' <- readIORef gameState
  let snake' = snake gameState'
  let food'  = food gameState'
  when (snakeHead snake' `elem` food') $ do
       generateFood gameState
       gs' <- readIORef gameState
       writeIORef gameState $ gameState' { 
                        food       = delete (snakeHead snake') (food gs')
                      , digestion  = digestion gameState' ++ [snakeHead snake']
                      , points     = points gameState' + 10
                      }

generateFood gameState = do
  gameState' <- readIORef gameState
  let food'  = food gameState'
  let snake' = snake gameState'
  x      <- rndAxis $ wall gameState'
  y      <- rndAxis $ wall gameState'
  if (x,y) `elem` food' || (x,y) `isTail` snake' 
  then generateFood gameState 
  else writeIORef gameState $ gameState' { food = food gameState' ++ [(x,y)] }


execCmdStack gameState = do
  gameState' <- readIORef gameState
  when (not (null $ cmdStack gameState') && walked gameState') $ do 
                           changeSnakeDirection gameState (last $ cmdStack gameState')
                           gs' <- readIORef gameState
                           writeIORef gameState $ gs' { cmdStack = take 1 $ cmdStack gameState' }

growthSnake gameState = do
  gameState' <- readIORef gameState
  let digestion' = digestion gameState'
  let snake'     = snake gameState'
  let newSnake   = pred' digestion' snake' (fst snake', snd snake' ++ [head digestion']) snake'
  let newDigest  = pred' digestion' snake' (tail digestion') digestion'
  writeIORef gameState $ gameState' { snake = newSnake, digestion = newDigest }
    where 
      pred' dig (_, snk) t e | null dig            = e
                             | head dig == last snk = t
                             | otherwise           = e

mutateGame gameState = do 
  gameState' <- readIORef gameState
  let bonus     = points gameState' `div` 300
  let foodBonus = bonus + 1 - length (food gameState')  
  genFood foodBonus
  readIORef gameState >>= \x -> writeIORef gameState $ x { wall = startWall x + bonus }
      where genFood n = when (n > 0) $ generateFood gameState >> genFood (n - 1)

addToCmdStack, changeSnakeDirection :: IORef GameState -> Direction -> IO ()
addToCmdStack gameState cmd = readIORef gameState >>= 
                              \x -> writeIORef gameState $ x { cmdStack = take 2 $ cmd : cmdStack x }

changeSnakeDirection gameState direction = do
  gameState' <- readIORef gameState
  when (chCourse (snake gameState') && walked gameState') $
       writeIORef gameState $ gameState' { snake = (direction, snd $ snake gameState'), walked = False }
    where 
      inverseDirection d = case d of { UP -> DOWN; DOWN -> UP; LEFT -> RIGHT; RIGHT -> LEFT }
      chCourse (d, _)    = d /= direction && inverseDirection d /= direction

moveSnake :: IORef GameState -> Direction -> Bool -> IO ()
moveSnake gameState direction pred = do
  gameState'  <- readIORef gameState
  let snake'        = snake gameState'
  let newSnake      = case direction of
                        UP    | pred -> makeNewSnake snake' (0, 1)
                        DOWN  | pred -> makeNewSnake snake' (0, -1)
                        LEFT  | pred -> makeNewSnake snake' (-1, 0)
                        RIGHT | pred -> makeNewSnake snake' (1, 0)
                        _            -> snake'
  let newGameStatus = if isWall (snakeHead newSnake) (wall gameState')  || isTail (snakeHead newSnake) newSnake 
                      then GameOver
                      else Play
  if newGameStatus == Play
  then writeIORef gameState $ gameState' { snake = newSnake, gameStatus = newGameStatus, walked = True }
  else writeIORef gameState $ gameState' { snake = snake',    gameStatus = newGameStatus, walked = True }
      where 
        makeNewSnake snk t = (direction, snakeHead snk `mv` t : (init $ snd snk))


mv :: Coord -> Coord -> Coord
mv (x,y) (n,m)     = (x + n, y + m)

notGs :: GameStatus -> GameStatus
notGs x = case x of { Play -> Pause; Pause -> Play; _ -> GameOver }

rndAxis :: Int -> IO Int
rndAxis wall = randomRIO (1 - wall, wall - 1) 

snakeHead :: Snake -> Coord
snakeHead = head . snd

isWall :: Coord -> Int -> Bool
isWall (x,y) wall = abs x >= wall || abs y >= wall

isTail :: Coord -> Snake -> Bool
isTail e (_, snk) = e `elem` tail snk

renderText :: (GLfloat, GLfloat) -> String -> IO ()
renderText (x,y) t = currentRasterPosition $= Vertex4 x y 0 1 >> renderString TimesRoman24 t

keyboardMouse :: IORef GameState -> Key -> KeyState -> t -> t1 -> IO ()
keyboardMouse gameState key state _ _ = do
  gameState' <- readIORef gameState
  case (key, state) of
    (SpecialKey KeyUp,    Down) -> addToCmdStack gameState UP
    (SpecialKey KeyDown,  Down) -> addToCmdStack gameState DOWN
    (SpecialKey KeyLeft,  Down) -> addToCmdStack gameState LEFT
    (SpecialKey KeyRight, Down) -> addToCmdStack gameState RIGHT
    (Char ' ', Down)            -> writeIORef gameState $ gameState' { gameStatus = notGs (gameStatus gameState') }
    (Char 'r', Down)            -> newGame >>= readIORef >>= writeIORef gameState
    (Char 's', Down)            -> writeFile "/tmp/snk.txt" (show gameState')
    (Char 'l', Down)            -> writeIORef gameState . read =<< readFile  "/tmp/snk.txt"
    _ -> return ()
  execCmdStack gameState

display :: IORef GameState -> IO ()
display gameState = do
  gameState' <- readIORef gameState
  let wall' = toFloat (wall gameState') * 0.0455 + (toFloat (wall gameState') - toFloat (startWall gameState')) * 0.005
  clear [ColorBuffer]
  renderPrimitive Quads $ do
                      forM_ (map convA $ snd $ snake gameState')
                          (\(x, y) -> do
                               color  $ Color3 1 1 (1 :: GLfloat)
                               vertex $ Vertex2 (conv $ x - 0.02) $ conv (y + 0.02)
                               vertex $ Vertex2 (conv $ x + 0.02) $ conv (y + 0.02)
                               color  $ Color3 1 1 (1 :: GLfloat)
                               vertex $ Vertex2 (conv $ x + 0.02) $ conv (y - 0.02)
                               color  $ Color3 1 1 (1 :: GLfloat)
                               vertex $ Vertex2 (conv $ x - 0.02) $ conv (y - 0.02))
                      forM_ (map convA $ food gameState')
                          (\(x, y) -> do 
                               color  $ Color3 1 1 (0 :: GLfloat)
                               vertex $ Vertex2 (conv $ x - 0.01) $ conv (y + 0.01)
                               vertex $ Vertex2 (conv $ x + 0.01) $ conv (y + 0.01)
                               color  $ Color3 1 0 (1 :: GLfloat)
                               vertex $ Vertex2 (conv $ x + 0.01) $ conv (y - 0.01)
                               color  $ Color3 1 1 (1 :: GLfloat)
                               vertex $ Vertex2 (conv $ x - 0.01) $ conv (y - 0.01) )
  renderPrimitive LineLoop $ do
                      color  $ Color3 1 1 (0 :: GLfloat)
                      vertex $ Vertex2 (conv $ -wall' - 0.02) $ conv (wall' + 0.02)
                      vertex $ Vertex2 (conv $ wall' + 0.02)  $ conv (wall' + 0.02)
                      vertex $ Vertex2 (conv $ wall' + 0.02)  $ conv (-wall' - 0.02)
                      vertex $ Vertex2 (conv $ -wall' - 0.02) $ conv (-wall' - 0.02)
  color  $ Color3 1 0.0 (0 :: GLfloat)
  renderText (-0.5, 0.9) $ "Points: " ++ show (points gameState')
  renderText (0.2, 0.9)  $ "Length: " ++ show (length $ snd $ snake gameState')
  case gameStatus gameState' of 
    GameOver -> renderText (-0.2, 0.3) "Game Over!"
    Pause    -> renderText (-0.1, 0.3) "Pause!"
    _        -> return ()
  swapBuffers
      where 
        conv x       = fromRational $ toRational x :: GLfloat
        convA (x, y) = (,) (toFloat x / coeff) (toFloat y / coeff)
        coeff        = 20
        toFloat x    = fromIntegral x :: Float