Croco Magneto remake in Haskell

croco.hs

module Main where

import Data.List
import Data.Maybe
import Control.Monad
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT
import qualified Graphics.UI.GLUT.Callbacks.Window as W
import qualified Data.Map as M
import Graphics.UI.GLUT.State
import Graphics.UI.GLUT (get, set, ($=), Position)
import Data.IORef

data Brick = White | Green | Red deriving (Show, Eq)

type Time = Int

type Speed = Float

type Maze = M.Map (Int, Int) Brick

type Coord = GLUT.GLfloat

data GameStatus = InProgress | GameOver deriving (Show)

data Direction = MovingLeft | MovingRight deriving (Show)

data KeyState = MovingUp | MovingDown | NoKeyState deriving (Show)

data GameState = GameState
  { gsLastTime  :: Maybe Time
  , gsMaze      :: Maze
  , gsPosX      :: Coord
  , gsPosY      :: Coord
  , gsSpeed     :: Speed
  , gsStatus    :: GameStatus
  , gsKeyState  :: KeyState
  , gsDirection :: Direction } deriving (Show)
  
parseMaze :: [String] -> Maze
parseMaze = M.fromList . map (\(k, v) -> (k, fromJust v)) . filter (isJust . snd) . concat . snd . mapAccumL (\n s -> (n + 1, parseLine n s)) 0
  where
  parseLine n = snd . mapAccumL (\m c -> (m + 1, ((m, n), parseChar c))) 0
  parseChar '#' = Just White
  parseChar 'R' = Just Red
  parseChar 'G' = Just Green
  parseChar _ = Nothing
  
defaultMaze :: Maze
defaultMaze = parseMaze 
  [ "######################################################################"
  , "#G                  #R         G#GG   RRR                            #"
  , "#G       R#R        #          G#GG         #########                #"
  , "#G        #         #          G#############RGG    #########        #"
  , "#G        #                                                          #"
  , "#G        #         #R         G#############       #########        #"
  , "#G       R#R        #          G#GG         #########                #"
  , "#G                  #          G#GG   RRR                            #"
  , "#################################GG###################################"
  , "#G                             G#GG                                 R#"
  , "#G       R#R        #          G#RRRRRRRRRR                ###########"
  , "#G        #G       G#                                            GGGG#"
  , "#G        #        R#          G#RRRRRRRRRR                ###########"
  , "#G       R#G       G#          G#                                GGGG#"
  , "#R                             G#GGGGGG                          GGGG#"
  , "###########################################RRRRRRRRRRRRRRRR###########" ]
  
defaultOptions :: GameState
defaultOptions = GameState
  { gsLastTime   = Nothing
  , gsMaze       = defaultMaze
  , gsPosX       = 4.0
  , gsPosY       = 4.0
  , gsSpeed      = 10.0
  , gsStatus     = GameOver
  , gsKeyState   = NoKeyState
  , gsDirection  = MovingRight }

square :: IO ()
square = GL.renderPrimitive GL.TriangleFan $ do
  GL.vertex ((GL.Vertex2 (-1.0) (-1.0)) :: GL.Vertex2 GLUT.GLfloat)  
  GL.vertex ((GL.Vertex2   1.0  (-1.0)) :: GL.Vertex2 GLUT.GLfloat)
  GL.vertex ((GL.Vertex2   1.0    1.0 ) :: GL.Vertex2 GLUT.GLfloat)
  GL.vertex ((GL.Vertex2 (-1.0)   1.0 ) :: GL.Vertex2 GLUT.GLfloat)

circle :: IO ()
circle = GL.renderPrimitive GL.TriangleFan $ mapM_ GL.vertex points where
  points = flip map [0..20] $ \deg -> 
    GL.Vertex2 (sin (2 * pi * deg / 20)) 
               (cos (2 * pi * deg / 20)) :: GL.Vertex2 GLUT.GLfloat  


checkCollision :: GameState -> (Coord, Coord) -> Maybe ((Int, Int), Brick)
checkCollision state (x, y) = 
  let (ix, iy) = nearestBrick (gsDirection state) x y in
  msum [ checkCollision' state (ix, iy), checkCollision' state (ix, iy - 1), checkCollision' state (ix, iy + 1) ]
  where 
    nearestBrick MovingLeft x y = (floor x, round y)
    nearestBrick MovingRight x y = (ceiling x, round y)
    checkCollision' state p@(ix,iy) = 
      let dist = sqrt $ (fromIntegral iy - y) ^ 2 + (fromIntegral ix - x) ^ 2 in
      if dist >= 0.7 then 
        Nothing 
      else 
        fmap (\b -> (p, b)) $ M.lookup p (gsMaze state)

brick :: Brick -> IO ()
brick White = do
  GL.color (GL.Color4 0.75 0.75 0 1 :: GL.Color4 GLUT.GLclampf)
  square
  GL.color (GL.Color4 0.75 0.5 0 1 :: GL.Color4 GLUT.GLclampf)
  GLUT.preservingMatrix $ do
    GL.scale (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat)
    square
brick Red = do
  GL.color (GL.Color4 0 1 0 1 :: GL.Color4 GLUT.GLclampf)
  circle
  GL.color (GL.Color4 0 0.5 0 1 :: GL.Color4 GLUT.GLclampf)
  GLUT.preservingMatrix $ do
    GL.scale (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat)
    circle
brick Green = do
  GL.color (GL.Color4 1 0 0 1 :: GL.Color4 GLUT.GLclampf)
  square
  GL.color (GL.Color4 0 0 1 1 :: GL.Color4 GLUT.GLclampf)
  GLUT.preservingMatrix $ do
    GL.scale (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat)
    square
  
maze :: Maze -> IO ()
maze m = flip mapM_ (M.toList m) $ \((x, y), b) ->  GL.preservingMatrix $ do
  GL.translate (GLUT.Vector3 (fromIntegral x) (fromIntegral y) 0 :: GLUT.Vector3 GLUT.GLfloat)
  GL.scale (0.4 :: GLUT.GLfloat) (0.4 :: GLUT.GLfloat) (1.0 :: GLUT.GLfloat)
  brick b
  
ball :: Coord -> Coord -> IO ()
ball x y = GL.preservingMatrix $ do
  GL.translate (GLUT.Vector3 x y 0 :: GLUT.Vector3 GLUT.GLfloat)
  GL.color (GL.Color4 0 0.5 1 1 :: GL.Color4 GLUT.GLclampf)
  GL.scale (0.3 :: GLUT.GLfloat) (0.3 :: GLUT.GLfloat) (1.0 :: GLUT.GLfloat)
  circle
             
applyKeyState :: GameState -> Float -> Coord
applyKeyState state d = case gsKeyState state of
  MovingUp -> 
    let location = nearestBrick (gsPosX state) (gsPosY state - d) in
    let brick = M.lookup location (gsMaze state) in
    if brick == Just White then gsPosY state else gsPosY state - d
    where nearestBrick x y = (round x, floor y)
  MovingDown ->
    let location = nearestBrick (gsPosX state) (gsPosY state + d) in
    let brick = M.lookup location (gsMaze state) in
    if brick == Just White then gsPosY state else gsPosY state + d
    where nearestBrick x y = (round x, ceiling y)
  NoKeyState -> gsPosY state
      
moveBall :: GameState -> Time -> (Coord, Coord)
moveBall state elapsed =
  let d = (fromIntegral elapsed) * (gsSpeed state) / 1000.0 in
  let newY = applyKeyState state d in
  case gsDirection state of 
    MovingLeft  -> (gsPosX state - d, newY)
    MovingRight -> (gsPosX state + d, newY)
             
collide :: GameState -> (Int, Int) -> (Coord, Coord) -> Brick -> GameState
collide state _ (x, y) White =
  case gsDirection state of
    MovingLeft  -> state { gsDirection = MovingRight }
    MovingRight -> state { gsDirection = MovingLeft }
collide state _ _ Red = 
  state { gsStatus = GameOver }
collide state key _ Green = 
  let newMaze = M.delete key (gsMaze state) in
  let newStatus = if null $ filter (== Green) $ map snd $ M.toList $ gsMaze state then GameOver else InProgress in
  case gsDirection state of
    MovingLeft  -> state { gsMaze = newMaze, gsDirection = MovingRight, gsStatus = newStatus }
    MovingRight -> state { gsMaze = newMaze, gsDirection = MovingLeft, gsStatus = newStatus }
             
updateGameState :: GameState -> Time -> GameState
updateGameState state elapsed =
  let (newX, newY) = moveBall state elapsed in
  case checkCollision state (newX, newY) of
    Nothing -> state { gsPosX = newX, gsPosY = newY }
    Just (key, brick) -> collide state key (newX, newY) brick
   
tick :: GameState -> Time -> GameState
tick state elapsedTime = do 
  case gsStatus state of
    GameOver -> state
    InProgress -> updateGameState state elapsedTime
   
render :: IORef GameState -> IO ()
render stateRef = do
  state <- get stateRef
  time <- get elapsedTime
  let lastTime = gsLastTime state
  let elapsedTime = maybe 0 id $ (time -) `fmap` lastTime
  let state' = tick state elapsedTime
  let state'' = state' { gsLastTime = Just time }
  stateRef $= state''
  GL.clearColor $= GL.Color4 0 0 0 1
  GL.clear [GL.ColorBuffer, GL.DepthBuffer]
  GL.matrixMode $= GL.Modelview 0
  GL.loadIdentity
  GL.translate (GLUT.Vector3 (-gsPosX state'') (-gsPosY state'') 0 :: GLUT.Vector3 GLUT.GLfloat)
  maze (gsMaze state'')
  ball (gsPosX state'') (gsPosY state'')
  GL.flush
  GLUT.swapBuffers
  GLUT.postRedisplay Nothing
  
changeKeyState :: IORef GameState -> KeyState -> IO ()
changeKeyState stateRef newState = do
  state <- get stateRef
  case gsStatus state of 
    InProgress -> stateRef $= state { gsKeyState = newState }
    _ -> return ()
  
keyboardMouse :: IORef GameState -> W.Key -> W.KeyState -> W.Modifiers -> Position -> IO ()
keyboardMouse stateRef (W.SpecialKey W.KeyUp)   W.Down _ _ = changeKeyState stateRef MovingUp
keyboardMouse stateRef (W.SpecialKey W.KeyDown) W.Down _ _ = changeKeyState stateRef MovingDown
keyboardMouse stateRef (W.SpecialKey _)         W.Up   _ _ = changeKeyState stateRef NoKeyState
keyboardMouse stateRef (W.Char ' ')             W.Down _ _ = do
  state <- get stateRef
  case gsStatus state of 
    GameOver -> stateRef $= defaultOptions { gsStatus = InProgress }
    _ -> return ()
keyboardMouse _ _ _ _ _ = return ()

resize :: GLUT.Size -> IO ()
resize s@(GLUT.Size w h) = do
  let aspect = fromIntegral w / fromIntegral h
  GL.matrixMode $= GL.Projection
  GL.loadIdentity
  GL.ortho (-10 * aspect) (10 * aspect) 10 (-10) (-10) 10
  GL.viewport $= (GLUT.Position 0 0, s) 

main :: IO ()
main = do
  state <- newIORef defaultOptions
  GLUT.initialDisplayMode $= [ GLUT.RGBAMode,
                               GLUT.Multisampling,
                               GLUT.DoubleBuffered,
                               GLUT.WithAlphaComponent ] 
  GLUT.initialWindowSize $= GL.Size 600 600
  _ <- GLUT.getArgsAndInitialize
  GLUT.createWindow "Croco Magneto"
  GLUT.displayCallback $= render state
  GLUT.keyboardMouseCallback $= Just (keyboardMouse state)
  GLUT.reshapeCallback $= Just resize
  GLUT.mainLoop