motion.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Data.Word
import Foreign.C.Types
import Graphics.UI.GLUT as GL hiding (Window, createWindow, bitmap, get, renderer)
import SDL hiding (get)

type Game = StateT GameState IO

data GameState = GameState
  { window    :: Window
  , timer     :: Word32
  , deltaTime :: CInt
  , pos       :: V2 Double
  , motion    :: V4 Bool
  }

windowWidth = 800
windowHeight = 800

movementSpeed = 0.003 

main :: IO ()
main = do
  initializeAll
  window <- createWindow "Motion"
    ( defaultWindow 
      { windowInitialSize = V2 windowWidth windowHeight
      , windowOpenGL = Just defaultOpenGL 
        { glMultisampleSamples = 16 }
      }
    )
  showWindow window
  glCreateContext window

  timer <- ticks
  runStateT gameLoop GameState
    { window    = window
    , timer     = timer
    , deltaTime = fromIntegral timer
    , pos       = V2 0 0
    , motion    = V4 False False False False
    }

  SDL.destroyWindow window
  SDL.quit


gameLoop :: Game ()
gameLoop = do
  -- handle events and update game state
  game

  -- render
  liftIO $ GL.clear [ColorBuffer]
  V2 x y <- gets pos
  drawPlayer x y
  liftIO $ flush
  window <- gets window
  SDL.glSwapWindow window

  -- update timer
  state <- get
  t <- gets timer
  t' <- ticks
  put state 
    { deltaTime = fromIntegral t' - fromIntegral t
    , timer = t'
    }

  gameLoop

clamp lim = max (-lim) . min lim

game = do
  mapEvents handleGameInput
  dt <- gets deltaTime
  let change = movementSpeed * fromIntegral dt
  let mot a b = if a then change else 0 + if b then -change else 0
  V4 w a s d <- gets motion
  V2 x y <- gets pos
  state <- get
  let newPos = V2 (clamp 0.9 (x + mot d a)) (clamp 0.9 (y + mot w s))
  put state { pos = newPos }
  return ()

color3 r g b = color $ Color3 r g (b :: GLfloat)
vertex3 x y z = vertex $ Vertex3 x y (z :: GLfloat)

drawPlayer x' y' =
  let x = realToFrac x'
      y = realToFrac y'
  in
  liftIO $ renderPrimitive Quads $ do
    color3 1 1 1
    vertex3 (x-0.1) (y-0.1) 0
    vertex3 (x-0.1) (y+0.1) 0
    vertex3 (x+0.1) (y+0.1) 0
    vertex3 (x+0.1) (y-0.1) 0

handleGameInput :: Event -> Game ()
handleGameInput event = do
  case eventPayload event of
    KeyboardEvent e -> do
      case keyboardEventKeyMotion e of
        Pressed -> setMotion e True
        Released -> setMotion e False
    _ -> return ()

setMotion :: KeyboardEventData -> Bool -> Game ()
setMotion e p = do
  state <- get
  V4 u d l r <- gets motion
  case keysymKeycode (keyboardEventKeysym e) of
    KeycodeW -> put state { motion = V4 p d l r }
    KeycodeA -> put state { motion = V4 u p l r }
    KeycodeS -> put state { motion = V4 u d p r }
    KeycodeD -> put state { motion = V4 u d l p }
    KeycodeEscape -> quit
    _ -> return ()