htanks/HTanks.hs

{-# LANGUAGE PatternGuards, GeneralizedNewtypeDeriving #-}

import Game
import Level
import Render
import Tank
import Player
import CPUPlayer
import DefaultPlayer

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
               , players  :: ![SomePlayer]
               }

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, players =
                                          [ SomePlayer $ DefaultPlayer S.empty
                                          , SomePlayer $ CPUPlayer 0
                                          ]}
             gameState = GameState {level = testLevel, tanks = [ Tank 0.0 0.0 0 0 2 360 False
                                                               , Tank 0.0 (-1.5) 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


updateAngle :: Micro -> State Tank ()
updateAngle angle = do
  oldangle <- gets dir
  tspeed <- gets turnspeed >>= return . (/1000)
  
  let diff = 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 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
  
  modify $ \tank -> tank {dir = newangle180}


updateTank :: Maybe Micro -> Bool -> State Tank ()
updateTank angle move = do
  when (isJust angle) $
       updateAngle $ fromJust angle
                   
  when move $ do
    tdir <- gets dir
    tspeed <- gets speed
    moved <- gets moving
    
    when (isNothing angle || (isJust angle && (tdir == fromJust angle)) || moved) $ do
                   let anglej = (fromRational . toRational $ tdir)*pi/180
                       x = tspeed * fromRational (round ((cos anglej)*1000)%1000000)
                       y = tspeed * fromRational (round ((sin anglej)*1000)%1000000)
                   
                   modify $ \tank -> tank {posx = x + posx tank, posy = y + posy tank, moving = True}
  
  when (not move) $ do
                   modify $ \tank -> tank {moving = False}


simulationStep :: Main ()
simulationStep = do
  oldplayers <- gets players
  oldtanks <- lift $ gets tanks
  
  let pt = unzip $ map updateTank' $ zip oldplayers oldtanks
  
  modify $ \state -> state {players = fst pt}
  lift $ modify $ \state -> state {tanks = snd pt}
    where
      updateTank' (player, tank) = let (p, angle, move) = playerMovement player tank
                                       t = execState (updateTank angle move) tank
                                   in (p, t)
      

handleEvents :: Main ()
handleEvents = do
  event <- gets driver >>= liftIO . nextEvent
  when (isJust event) $ do
                 Main.handleEvent $ fromJust event
                 modify $ \state -> state {players = map (\p -> Player.handleEvent p $ fromJust event) $ players state}
                 handleEvents

handleEvent :: SomeEvent -> Main ()
handleEvent ev
    | Just (ResizeEvent w h)     <- fromEvent ev = lift $ resize w h
    | Just QuitEvent             <- fromEvent ev = modify $ \state -> state {run = False}
    | otherwise = return ()