{-# 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 ()