htanks/HTanks.hs

{-# LANGUAGE PatternGuards, GeneralizedNewtypeDeriving #-}

import Game
import Level
import Render
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
  let theLevel = testLevel
  gl <- initGL $ glxDriver (levelWidth theLevel) (levelHeight theLevel)
  
  when (initialized gl) $ do
         currentTime <- getCurrentTime
         let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, players =
                                          [ SomePlayer $ DefaultPlayer S.empty 0 0 False
                                          , SomePlayer $ CPUPlayer 0
                                          ]}
             gameState = GameState {level = theLevel, tanks = [ Tank 5.0 5.0 0 0 2 270 False 3 2 5
                                                              , Tank 5.0 3.5 0 0 2 270 False 3 2 5
                                                              ], shoots = [], textures = M.empty}
         
         runGame gameState $ do
                            setup
                            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 -> Maybe Micro -> State Tank ()
updateTank angle move aangle = do
  when (isJust angle) $
       updateAngle $ fromJust angle
  
  when (isJust aangle) $
       modify $ \tank -> tank {aim = fromJust aangle}
  
  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}


updateShoot :: State Shoot ()
updateShoot = modify $ \shoot ->
              let angle = (fromRational . toRational . shootDir $ shoot)*pi/180
                  dx = (shootSpeed shoot) * fromRational (round ((cos angle)*1000)%1000000)
                  dy = (shootSpeed shoot) * fromRational (round ((sin angle)*1000)%1000000)
              in shoot {shootX = dx + shootX shoot, shootY = dy + shootY shoot}


simulationStep :: Main ()
simulationStep = do
  oldplayers <- gets players
  oldtanks <- lift $ gets tanks
  
  let (p, t, s) = unzip3 $ map updateTank' $ zip oldplayers oldtanks
      ts = zip3 t s [0..]
      shootingtanks = map (\(tank, _, n) -> (tank, n)) $ filter (\(tank, shoot, _) -> shoot && (shootsLeft tank) > 0) $ ts
      newtanks = map (\(tank, shoot, _) -> if shoot then tank {shootsLeft = (shootsLeft tank) - 1} else tank) $ ts
      newshoots = map (\(tank, n) -> Shoot
                                     { shootX = posx tank
                                     , shootY = posy tank
                                     , shootDir = aim tank
                                     , shootSpeed = tankShootSpeed tank
                                     , bouncesLeft = tankShootBounces tank
                                     , shootTank = n
                                     }) shootingtanks
  
  
  modify $ \state -> state {players = p}
  lift $ modify $ \state -> state {tanks = newtanks, shoots = map (execState updateShoot) (shoots state ++ newshoots)}
    where
      updateTank' (player, tank) = let (p, angle, move, aangle, shoot) = playerUpdate player tank
                                       t = execState (updateTank angle move aangle) tank
                                   in (p, t, shoot)
      

handleEvents :: Main ()
handleEvents = do
  (newgl, event) <- gets driver >>= liftIO . nextEvent
  modify $ \state -> state {driver = newgl}
  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 QuitEvent         <- fromEvent ev = modify $ \state -> state {run = False}
    | otherwise = return ()