From 8586ef7b8502bc8be2f37026b6e443b5a6cf0868 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Tue, 2 Mar 2010 21:36:37 +0100 Subject: New generic player implementation --- DefaultPlayer.hs | 35 +++++++++++++++ HTanks.hs | 127 +++++++++++++++++++++++++++++-------------------------- Makefile | 2 +- Player.hs | 25 +++++++++++ 4 files changed, 128 insertions(+), 61 deletions(-) create mode 100644 DefaultPlayer.hs create mode 100644 Player.hs diff --git a/DefaultPlayer.hs b/DefaultPlayer.hs new file mode 100644 index 0000000..351928f --- /dev/null +++ b/DefaultPlayer.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} + +module DefaultPlayer ( DefaultPlayer(..) + ) where + + +import qualified Data.Set as S +import Data.Fixed +import Data.Ratio ((%)) +import Data.Typeable + +import GLDriver +import Player +import Tank + + +data DefaultPlayer = DefaultPlayer (S.Set Key) + deriving (Typeable, Show) + +instance Player DefaultPlayer where + playerMovement (DefaultPlayer keys) _ = playerMovement' keys + + handleEvent (DefaultPlayer keys) ev + | Just (KeyPressEvent key) <- fromEvent ev = DefaultPlayer $ S.insert key keys + | Just (KeyReleaseEvent key) <- fromEvent ev = DefaultPlayer $ S.delete key keys + | otherwise = DefaultPlayer keys + + +playerMovement' :: S.Set Key -> (DefaultPlayer, Maybe Micro, Bool) +playerMovement' keys = (DefaultPlayer keys, angle, move) + where + 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) + move = (x /= 0 || y /= 0) + angle = if move then Just $ fromRational $ round ((atan2 y x)*1000000*180/pi)%1000000 else Nothing diff --git a/HTanks.hs b/HTanks.hs index 22b8309..871b455 100644 --- a/HTanks.hs +++ b/HTanks.hs @@ -4,6 +4,8 @@ import Game import Level import Render import Tank +import Player +import DefaultPlayer import GLDriver import GLX @@ -22,7 +24,7 @@ data MainState = MainState { run :: !Bool , driver :: !SomeDriver , time :: !UTCTime - , keyset :: !(S.Set Key) + , players :: ![SomePlayer] } newtype MainT m a = MainT (StateT MainState m a) @@ -40,7 +42,7 @@ main = do when (initialized gl) $ do currentTime <- getCurrentTime - let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, keyset = S.empty} + let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, players = [SomePlayer $ DefaultPlayer S.empty]} gameState = GameState {level = testLevel, tanks = [Tank 0.0 0.0 0 0 2 360 False], textures = M.empty} runGame gameState $ do @@ -80,82 +82,87 @@ mainLoop = do when runnext mainLoop -playerMovement :: Main (Maybe Micro, Bool) -playerMovement = do - keys <- gets keyset + +updateAngle :: Micro -> State Tank () +updateAngle angle = do + oldangle <- gets dir + tspeed <- gets turnspeed >>= return . (/1000) - 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) + let diff = angle - oldangle + let diff360 = if (diff > 180) + then (diff-360) + else if (diff <= -180) + then (diff+360) + else diff - 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 + let (diff180, angle180) = if (diff360 > 90) + then (diff360-180, oldangle+180) + else if (diff360 <= -90) + then (diff360+180, oldangle-180) + else (diff360, oldangle) - 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)} + 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 - tank <- lift $ gets (head . tanks) - let moved = moving tank + tdir <- gets dir + tspeed <- gets speed + moved <- gets moving - 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) + 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) - lift $ modify $ \state -> state {tanks = (tank {posx = x + posx tank, posy = y + posy tank, moving = True}):(tail . tanks $ state)} + modify $ \tank -> tank {posx = x + posx tank, posy = y + posy tank, moving = True} when (not move) $ do - tank <- lift $ gets (head . tanks) - lift $ modify $ \state -> state {tanks = (tank {moving = False}):(tail . tanks $ state)} + 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 - handleEvent $ fromJust event + 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 (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 () diff --git a/Makefile b/Makefile index f28968b..5064c3b 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ HSCFILES = Bindings/GLX.hsc Bindings/GLPng.hsc -HSFILES = $(HSCFILES:%.hsc=%.hs) GLDriver.hs GLX.hs Texture.hs Tank.hs Level.hs Game.hs Render.hs HTanks.hs +HSFILES = $(HSCFILES:%.hsc=%.hs) GLDriver.hs GLX.hs Texture.hs Tank.hs Player.hs DefaultPlayer.hs Level.hs Game.hs Render.hs HTanks.hs all: HTanks diff --git a/Player.hs b/Player.hs new file mode 100644 index 0000000..f3303f8 --- /dev/null +++ b/Player.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} + +module Player ( Player(..) + , SomePlayer(..) + ) where + +import Data.Fixed +import Data.Typeable + +import Tank +import GLDriver (SomeEvent) + + +class Player a where + playerMovement :: a -> Tank -> (a, Maybe Micro, Bool) + handleEvent :: a -> SomeEvent -> a + + handleEvent player _ = player + + +data SomePlayer = forall a. Player a => SomePlayer a + +instance Player SomePlayer where + playerMovement (SomePlayer player) tank = (\(p, angle, move) -> (SomePlayer p, angle, move)) $ playerMovement player tank + handleEvent (SomePlayer player) event = SomePlayer $ handleEvent player event -- cgit v1.2.3