htanks/HTanks.hs

{-# LANGUAGE PatternGuards, GeneralizedNewtypeDeriving #-}

import Game
import Level
import Render
import Tank

import GLDriver
import GLX

import Control.Concurrent (threadDelay)
import Control.Monad.State
import Data.Fixed
import Data.Maybe
import qualified Data.Map as M
import Data.Ratio
import qualified Data.Set as S
import Data.Time.Clock


data MainState = MainState
               { run      :: !Bool
               , driver   :: !SomeDriver
               , time     :: !UTCTime
               , keyset   :: !(S.Set Key)
               }

newtype MainT m a = MainT (StateT MainState m a)
    deriving (Monad, MonadState MainState, MonadIO, MonadTrans)

type Main = MainT Game

runMain :: MainState -> Main a -> Game (a, MainState)
runMain st (MainT a) = runStateT a st


main :: IO ()
main = do
  gl <- initGL glxDriver
  
  when (initialized gl) $ do
         currentTime <- getCurrentTime
         let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, keyset = S.empty}
             gameState = GameState {level = testLevel, tanks = [Tank 0.0 0.0 0 0 2 360 False], textures = M.empty}
         
         runGame gameState $ do
                            setup 800 600
                            runMain mainState mainLoop
         
         deinitGL gl

minFrameTime :: NominalDiffTime
minFrameTime = 0.01

mainLoop :: Main ()
mainLoop = do
  gl <- gets driver
  t <- gets time
  handleEvents
  
  lift render
  
  liftIO $ swapBuffers gl
  
  rtime <- liftIO getCurrentTime
  let drender = diffUTCTime rtime t
  when (drender < minFrameTime) $
       liftIO $ threadDelay $ truncate $ 1e6*(minFrameTime - drender)
  
  currenttime <- liftIO getCurrentTime
  let d = round $ 1e3*(diffUTCTime currenttime t)
  
  replicateM_ d simulationStep
  
  let newtime = addUTCTime ((1e-3)*(fromIntegral d)) t
  
  modify $ \state -> state {time = newtime}
  
  runnext <- gets run
  when runnext mainLoop


playerMovement :: Main (Maybe Micro, Bool)
playerMovement = do
  keys <- gets keyset
  
  let x = (if (S.member KeyLeft keys) then (-1) else 0) + (if (S.member KeyRight keys) then 1 else 0)
      y = (if (S.member KeyDown keys) then (-1) else 0) + (if (S.member KeyUp keys) then 1 else 0)
  
  if (x /= 0 || y /= 0)
    then return (Just $ fromRational $ round ((atan2 y x)*1000000*180/pi)%1000000, True)
    else return (Nothing, False)


simulationStep :: Main ()
simulationStep = do
  (angle, move) <- playerMovement
  
  when (isJust angle) $ do
                   tank <- lift $ gets (head . tanks)
                   let oldangle = dir tank
                   
                   let diff = fromJust angle - oldangle
                   let diff360 = if (diff > 180)
                              then (diff-360)
                              else if (diff <= -180)
                                   then (diff+360)
                                   else diff
                   
                   let (diff180, angle180) = if (diff360 > 90)
                                          then (diff360-180, oldangle+180)
                                          else if (diff360 <= -90)
                                               then (diff360+180, oldangle-180)
                                               else (diff360, oldangle)
                   
                   let tspeed = (turnspeed tank)/1000
                   let turn = if (diff180 > tspeed)
                              then tspeed
                              else if (diff180 < -tspeed)
                                   then (-tspeed)
                                   else diff180
                   
                   let newangle = angle180 + turn
                   
                   let newangle180 = if (newangle > 180)
                                     then (newangle-360)
                                     else if (newangle <= -180)
                                          then (newangle+360)
                                          else newangle
                   
                   lift $ modify $ \state -> state {tanks = (tank {dir = newangle180}):(tail . tanks $ state)}
  
  when move $ do
    tank <- lift $ gets (head . tanks)
    let moved = moving tank
    
    when (isNothing angle || (isJust angle && (dir tank == fromJust angle)) || moved) $ do
                   let angle = (fromRational . toRational $ dir tank)*pi/180
                       x = (speed tank) * fromRational (round ((cos angle)*1000)%1000000)
                       y = (speed tank) * fromRational (round ((sin angle)*1000)%1000000)
                   
                   lift $ modify $ \state -> state {tanks = (tank {posx = x + posx tank, posy = y + posy tank, moving = True}):(tail . tanks $ state)}
  
  when (not move) $ do
                   tank <- lift $ gets (head . tanks)
                   lift $ modify $ \state -> state {tanks = (tank {moving = False}):(tail . tanks $ state)}

handleEvents :: Main ()
handleEvents = do
  event <- gets driver >>= liftIO . nextEvent
  when (isJust event) $ do
                 handleEvent $ fromJust event
                 handleEvents

handleEvent :: SomeEvent -> Main ()
handleEvent ev
    | Just (ResizeEvent w h)     <- fromEvent ev = lift $ resize w h
    | Just (KeyPressEvent key)   <- fromEvent ev = modify $ \state -> state {keyset = S.insert key (keyset state)}
    | Just (KeyReleaseEvent key) <- fromEvent ev = modify $ \state -> state {keyset = S.delete key (keyset state)}
    | Just QuitEvent             <- fromEvent ev = modify $ \state -> state {run = False}
    | otherwise = return ()