Added bullet texture and movement; restructured game state

CPUPlayer.hs

@@ -10,11 +10,10 @@ import Data.Typeable
 
 import GLDriver
 import Player
-import Tank
 
 
 data CPUPlayer = CPUPlayer Micro
                  deriving (Typeable, Show)
 
 instance Player CPUPlayer where
-    playerUpdate (CPUPlayer angle) _ = (CPUPlayer (if (angle+0.1) > 180 then angle-359.9 else angle+0.1), Just angle, True, Just (-angle))
+    playerUpdate (CPUPlayer angle) _ = (CPUPlayer (if (angle+0.1) > 180 then angle-359.9 else angle+0.1), Just angle, True, Just (-angle), False)

DefaultPlayer.hs

@@ -9,16 +9,16 @@ import Data.Fixed
 import Data.Ratio ((%))
 import Data.Typeable
 
+import Game (Tank(..))
 import GLDriver
 import Player
-import Tank
 
 
-data DefaultPlayer = DefaultPlayer (S.Set Key) Float Float
+data DefaultPlayer = DefaultPlayer (S.Set Key) Float Float Bool
                      deriving (Typeable, Show)
 
 instance Player DefaultPlayer where
-    playerUpdate (DefaultPlayer keys aimx aimy) tank =
+    playerUpdate (DefaultPlayer keys aimx aimy shoot) tank =
         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)
             ax = aimx - (fromRational . toRational $ posx tank)
@@ -26,10 +26,11 @@ instance Player DefaultPlayer where
             move = (x /= 0 || y /= 0)
             angle = if move then Just $ fromRational $ round ((atan2 y x)*1000000*180/pi)%1000000 else Nothing
             aangle = if (ax /= 0 || ay /= 0) then Just $ fromRational $ round ((atan2 ay ax)*1000000*180/pi)%1000000 else Nothing
-        in (DefaultPlayer keys aimx aimy, angle, move, aangle)
+        in (DefaultPlayer keys aimx aimy False, angle, move, aangle, shoot)
     
-    handleEvent (DefaultPlayer keys aimx aimy) ev
-        | Just (KeyPressEvent key)    <- fromEvent ev = DefaultPlayer (S.insert key keys) aimx aimy
-        | Just (KeyReleaseEvent key)  <- fromEvent ev = DefaultPlayer (S.delete key keys) aimx aimy
-        | Just (MouseMotionEvent x y) <- fromEvent ev = DefaultPlayer keys x y
-        | otherwise = DefaultPlayer keys aimx aimy
+    handleEvent (DefaultPlayer keys aimx aimy shoot) ev
+        | Just (KeyPressEvent key)    <- fromEvent ev = DefaultPlayer (S.insert key keys) aimx aimy shoot
+        | Just (KeyReleaseEvent key)  <- fromEvent ev = DefaultPlayer (S.delete key keys) aimx aimy shoot
+        | Just (MouseMotionEvent x y) <- fromEvent ev = DefaultPlayer keys x y shoot
+        | Just (MousePressEvent x y) <- fromEvent ev = DefaultPlayer keys x y True
+        | otherwise = DefaultPlayer keys aimx aimy shoot

GLDriver.hs

@@ -10,6 +10,7 @@ module GLDriver ( Driver(..)
                 , KeyPressEvent(..)
                 , KeyReleaseEvent(..)
                 , MouseMotionEvent(..)
+                , MousePressEvent(..)
                 ) where
 
 import Data.Typeable
@@ -60,4 +61,7 @@ instance Event KeyReleaseEvent
 
 
 data MouseMotionEvent = MouseMotionEvent Float Float deriving (Typeable, Show)
-instance Event MouseMotionEvent
+instance Event MouseMotionEvent
+
+data MousePressEvent = MousePressEvent Float Float deriving (Typeable, Show)
+instance Event MousePressEvent

GLX.hs

@@ -70,7 +70,7 @@ instance Driver GLX where
       rootwindow <- rootWindow disp (fromIntegral $ viScreen visualinfo)
       cmap <- createColormap disp rootwindow (viVisual visualinfo) allocNone
       
-      let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask .|. pointerMotionMask}
+      let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask .|. pointerMotionMask .|. buttonPressMask}
       
       wnd <- with swa $ \swaptr ->
              createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr
@@ -162,18 +162,29 @@ handleEvent glx xevent = do
                                else
                                    return (glx, Nothing)
       | evtype == motionNotify    -> do
+                           (x, y) <- windowToGameCoords glx (ev_x event) (ev_y event)
                            wa <- getWindowAttributes (glxDisplay glx) (glxWindow glx)
-                           let x = fromIntegral . ev_x $ event
-                               y = fromIntegral . ev_y $ event
-                               w = fromIntegral . wa_width $ wa
-                               h = fromIntegral . wa_height $ wa
-                               s = fromRational . glxScale $ glx
-                               lw = fromIntegral . glxLevelWidth $ glx
-                               lh = fromIntegral . glxLevelHeight $ glx
-                           return (glx, Just $ SomeEvent $ MouseMotionEvent ((-w/2+x)/s + lw/2) ((h/2-y)/s + lh/2))
+                           return (glx, Just $ SomeEvent $ MouseMotionEvent x y)
+      | evtype == buttonPress     -> do
+                           (x, y) <- windowToGameCoords glx (ev_x event) (ev_y event)
+                           wa <- getWindowAttributes (glxDisplay glx) (glxWindow glx)
+                           return (glx, Just $ SomeEvent $ MousePressEvent x y)
+
       | otherwise -> return (glx, Nothing)
 
 
+windowToGameCoords :: Integral a => GLX -> a -> a -> IO (Float, Float)
+windowToGameCoords glx x y = getWindowAttributes (glxDisplay glx) (glxWindow glx) >>= \wa ->
+                             let w = fromIntegral . wa_width $ wa
+                                 h = fromIntegral . wa_height $ wa
+                             in return (((-w/2 + wx)/s + lw/2), ((h/2 - wy)/s + lh/2))
+                                 where s = fromRational . glxScale $ glx
+                                       lw = fromIntegral . glxLevelWidth $ glx
+                                       lh = fromIntegral . glxLevelHeight $ glx
+                                       wx = fromIntegral x
+                                       wy = fromIntegral y
+
+
 resize :: Int -> Int -> Int -> Int -> IO Rational
 resize lw lh w h = do
   let aspect = (fromIntegral w)%(fromIntegral h)
@@ -201,5 +212,3 @@ waitForMapNotify disp wnd = allocaXEvent waitForMapNotify'
         eventType <- get_EventType event
         unless (window == wnd && eventType == mapNotify) $
                waitForMapNotify' event
-
-        

Game.hs

@@ -1,22 +1,45 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module Game ( GameState(..)
+module Game ( Tank(..)
+            , Shoot(..)
+            , GameState(..)
             , Game
             , runGame
             ) where
 
 import Level
-import Tank
 import Texture
 
 import Control.Monad
 import Control.Monad.State
+import Data.Fixed
 import qualified Data.Map as M
 
 
+data Tank = Tank
+          { posx  :: !Micro
+          , posy  :: !Micro
+          , dir   :: !Micro
+          , aim   :: !Micro
+          , speed :: !Micro
+          , turnspeed :: !Micro
+          , moving :: !Bool
+          , tankShootSpeed :: !Micro
+          , tankShootBounces :: !Int
+          } deriving Show
+
+data Shoot = Shoot
+    { shootX   :: !Micro
+    , shootY   :: !Micro
+    , shootDir :: !Micro
+    , shootSpeed :: !Micro
+    , bouncesLeft :: !Int
+    } deriving Show
+
 data GameState = GameState
     { level    :: !Level
     , tanks    :: ![Tank]
+    , shoots   :: ![Shoot]
     , textures :: !(M.Map Texture TextureObject)
     } deriving (Show)
 

HTanks.hs

@@ -3,7 +3,6 @@
 import Game
 import Level
 import Render
-import Tank
 import Player
 import CPUPlayer
 import DefaultPlayer
@@ -45,12 +44,12 @@ main = do
   when (initialized gl) $ do
          currentTime <- getCurrentTime
          let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, players =
-                                          [ SomePlayer $ DefaultPlayer S.empty 0 0
+                                          [ 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
-                                                               , Tank 5.0 3.5 0 0 2 270 False
-                                                               ], textures = M.empty}
+             gameState = GameState {level = theLevel, tanks = [ Tank 5.0 5.0 0 0 2 270 False 3 2
+                                                              , Tank 5.0 3.5 0 0 2 270 False 3 2
+                                                              ], shoots = [], textures = M.empty}
          
          runGame gameState $ do
                             setup
@@ -148,6 +147,14 @@ updateTank angle move aangle = 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
@@ -156,9 +163,9 @@ simulationStep = do
   let pt = unzip $ map updateTank' $ zip oldplayers oldtanks
   
   modify $ \state -> state {players = fst pt}
-  lift $ modify $ \state -> state {tanks = snd pt}
+  lift $ modify $ \state -> state {tanks = snd pt, shoots = map (execState updateShoot) $ shoots state}
     where
-      updateTank' (player, tank) = let (p, angle, move, aangle) = playerUpdate player tank
+      updateTank' (player, tank) = let (p, angle, move, aangle, shoot) = playerUpdate player tank
                                        t = execState (updateTank angle move aangle) tank
                                    in (p, t)
       

Makefile

@@ -1,5 +1,5 @@
 HSCFILES = Bindings/GLX.hsc Bindings/GLPng.hsc
-HSFILES = $(HSCFILES:%.hsc=%.hs) GLDriver.hs GLX.hs Texture.hs Tank.hs Player.hs DefaultPlayer.hs CPUPlayer.hs Level.hs Game.hs Render.hs HTanks.hs
+HSFILES = $(HSCFILES:%.hsc=%.hs) GLDriver.hs GLX.hs Texture.hs Player.hs DefaultPlayer.hs CPUPlayer.hs Level.hs Game.hs Render.hs HTanks.hs
 
 all: HTanks
 

Player.hs

@@ -7,12 +7,12 @@ module Player ( Player(..)
 import Data.Fixed
 import Data.Typeable
 
-import Tank
+import Game (Tank(..))
 import GLDriver (SomeEvent)
 
 
 class Player a where
-    playerUpdate :: a -> Tank -> (a, Maybe Micro, Bool, Maybe Micro)
+    playerUpdate :: a -> Tank -> (a, Maybe Micro, Bool, Maybe Micro, Bool)
     handleEvent :: a -> SomeEvent -> a
     
     handleEvent player _ = player
@@ -22,6 +22,6 @@ data SomePlayer = forall a. Player a => SomePlayer a
 
 instance Player SomePlayer where
     playerUpdate (SomePlayer player) tank = 
-        let (p, angle, move, aangle) = playerUpdate player tank
-        in (SomePlayer p, angle, move, aangle)
+        let (p, angle, move, aangle, shoot) = playerUpdate player tank
+        in (SomePlayer p, angle, move, aangle, shoot)
     handleEvent (SomePlayer player) event = SomePlayer $ handleEvent player event

Render.hs

@@ -5,7 +5,6 @@ module Render ( setup
 
 import Game
 import Level
-import Tank
 import Texture
 
 import Control.Monad.State
@@ -34,6 +33,7 @@ texturePath t
     | t == TextureWood = "tex/Wood.png"
     | t == TextureTank = "tex/Tank.png"
     | t == TextureCannon = "tex/Cannon.png"
+    | t == TextureBullet = "tex/Bullet.png"
 
 getTexture :: Texture -> Game TextureObject
 getTexture t = do
@@ -59,6 +59,7 @@ setup = do
   getTexture TextureWood
   getTexture TextureTank
   getTexture TextureCannon
+  getTexture TextureBullet
   
   return ()
 
@@ -66,9 +67,12 @@ setup = do
 render :: Game ()
 render = do
   tanklist <- gets tanks
+  shootlist <- gets shoots
+  
   textureWood <- getTexture TextureWood
   textureTank <- getTexture TextureTank
   textureCannon <- getTexture TextureCannon
+  textureBullet <- getTexture TextureBullet
   
   (lw, lh) <- gets level >>= \l -> return (fromIntegral . levelWidth $ l :: GLfloat, fromIntegral . levelHeight $ l :: GLfloat)
   
@@ -94,8 +98,8 @@ render = do
            forM_ tanklist $ \tank -> preservingMatrix $ do
                                        let x = fromReal . posx $ tank
                                            y = fromReal . posy $ tank
-                                           rotDir = 90 + (fromReal . dir $ tank)
-                                           rotAim = 90 + (fromReal . aim $ tank)
+                                           rotDir = fromReal . dir $ tank
+                                           rotAim = fromReal . aim $ tank
                                        
                                        translate $ Vector3 x y (0 :: GLfloat)
                                        rotate rotDir $ Vector3 0 0 (1 :: GLfloat)
@@ -131,7 +135,30 @@ render = do
                                                           
                                                           texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
                                                           vertex $ Vertex2 (0.5 :: GLfloat) (-0.5 :: GLfloat)
-
+           
+           forM_ shootlist $ \shoot -> preservingMatrix $ do
+                                       let x = fromReal . shootX $ shoot
+                                           y = fromReal . shootY $ shoot
+                                           rotDir = fromReal . shootDir $ shoot
+                                       
+                                       translate $ Vector3 x y (0 :: GLfloat)
+                                       rotate rotDir $ Vector3 0 0 (1 :: GLfloat)
+                                       
+                                       textureBinding Texture2D $= Just textureBullet
+                                       
+                                       renderPrimitive Quads $ do
+                                                          texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
+                                                          vertex $ Vertex2 (-0.2 :: GLfloat) (-0.2 :: GLfloat)
+                                                          
+                                                          texCoord $ TexCoord2 (0 :: GLfloat) (1 :: GLfloat)
+                                                          vertex $ Vertex2 (-0.2 :: GLfloat) (0.2 :: GLfloat)
+                                                          
+                                                          texCoord $ TexCoord2 (1 :: GLfloat) (1 :: GLfloat)
+                                                          vertex $ Vertex2 (0.2 :: GLfloat) (0.2 :: GLfloat)
+                                                          
+                                                          texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
+                                                          vertex $ Vertex2 (0.2 :: GLfloat) (-0.2 :: GLfloat)
+           
 
 fromReal :: (Real a, Fractional b) => a -> b
 fromReal = fromRational . toRational

Tank.hs

@@ -1,14 +0,0 @@
-module Tank ( Tank(..)
-            ) where
-
-import Data.Fixed
-
-data Tank = Tank
-          { posx  :: !Micro
-          , posy  :: !Micro
-          , dir   :: !Micro
-          , aim   :: !Micro
-          , speed :: !Micro
-          , turnspeed :: !Micro
-          , moving :: !Bool
-          } deriving Show

Texture.hs

@@ -4,6 +4,5 @@ module Texture ( Texture(..)
 
 import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
 
-data Texture = TextureWood | TextureTank | TextureCannon
-             deriving (Eq, Ord, Show)
-  
+data Texture = TextureWood | TextureTank | TextureCannon | TextureBullet
+               deriving (Eq, Ord, Show)