New generic player implementation

4 files changed, 128 insertions, 61 deletions

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