Added player cursor

src/Game.hs

@@ -8,12 +8,10 @@ module Game ( Bullet(..)
 
 import Level
 import Tank
-import Texture
 
 import Control.Monad
 import Control.Monad.State
 import Data.Fixed
-import qualified Data.Map as M
 
 
 data Bullet = Bullet
@@ -29,7 +27,6 @@ data GameState = GameState
     { level    :: !Level
     , tanks    :: ![Tank]
     , bullets  :: ![Bullet]
-    , textures :: !(M.Map Texture TextureObject)
     } deriving (Show)
 
 newtype Game a = Game (StateT GameState IO a)

src/HTanks.hs

@@ -36,14 +36,14 @@ main = do
                                           [ --SomePlayer $ DefaultPlayer S.empty 0 0 False
                                             SomePlayer $ wiimotePlayer
                                           , SomePlayer $ CPUPlayer 0
-                                          ]}
+                                          ], textures = M.empty}
              gameState = GameState {level = theLevel, tanks = [ Tank 5.0 5.0 0 0 1.5 270 False 3 1 5 1
                                                               , Tank 5.0 3.5 0 0 1.5 270 False 3 1 5 1
-                                                              ], bullets = [], textures = M.empty}
+                                                              ], bullets = []}
          
-         runGame gameState $ do
+         runGame gameState $ runMain mainState $ do
                             setup
-                            runMain mainState mainLoop
+                            mainLoop
          
          deinitGL gl
 
@@ -56,7 +56,7 @@ mainLoop = do
   t <- gets time
   handleEvents
   
-  lift render
+  render
   
   liftIO $ swapBuffers gl
   

src/MainLoop.hs

@@ -9,10 +9,12 @@ module MainLoop ( MainState(..)
 import Game
 import GLDriver
 import Player
+import Texture
 
 import Control.Monad.State
 import Control.Monad.Trans
 import Data.Time
+import qualified Data.Map as M
 
 
 data MainState = MainState
@@ -20,6 +22,7 @@ data MainState = MainState
                , driver   :: !SomeDriver
                , time     :: !UTCTime
                , players  :: ![SomePlayer]
+               , textures :: !(M.Map Texture TextureObject)
                }
 
 newtype MainT m a = MainT (StateT MainState m a)

src/Player.hs

@@ -13,10 +13,13 @@ import GLDriver (SomeEvent)
 
 class Player a where
     playerUpdate :: a -> Tank -> IO (a, Maybe Micro, Bool, Maybe Micro, Bool)
-    handleEvent :: a -> SomeEvent -> a
     
+    handleEvent :: a -> SomeEvent -> a
     handleEvent player _ = player
     
+    renderPlayer :: a -> IO ()
+    renderPlayer _ = return ()
+
 
 data SomePlayer = forall a. Player a => SomePlayer a
 
@@ -25,3 +28,4 @@ instance Player SomePlayer where
                              (p, angle, move, aangle, shoot) <- playerUpdate player tank
                              return (SomePlayer p, angle, move, aangle, shoot)
     handleEvent (SomePlayer player) event = SomePlayer $ handleEvent player event
+    renderPlayer (SomePlayer player) = renderPlayer player

src/Render.hs

@@ -5,7 +5,9 @@ module Render ( setup
 
 import Paths_htanks
 import Game
+import MainLoop
 import Level
+import Player
 import Tank
 import Texture
 
@@ -37,8 +39,9 @@ texturePath t = getDataFileName $ path t
       path TextureTank = "tex/Tank.png"
       path TextureCannon = "tex/Cannon.png"
       path TextureBullet = "tex/Bullet.png"
+      path TextureCrosshair = "tex/Crosshair.png"
 
-getTexture :: Texture -> Game TextureObject
+getTexture :: Texture -> Main TextureObject
 getTexture t = do
   ts <- gets textures
   let tobj = M.lookup t ts
@@ -53,7 +56,7 @@ getTexture t = do
           return tex
                                                
 
-setup :: Game ()
+setup :: Main ()
 setup = do
   liftIO $ do
     blend $= Enabled
@@ -64,21 +67,24 @@ setup = do
   getTexture TextureTank
   getTexture TextureCannon
   getTexture TextureBullet
+  getTexture TextureCrosshair
   
   return ()
 
 
-render :: Game ()
+render :: Main ()
 render = do
-  tanklist <- gets tanks
+  tanklist <- lift $ gets tanks
-  bulletlist <- gets bullets
+  bulletlist <- lift $ gets bullets
+  playerlist <- gets players
   
   textureWood <- getTexture TextureWood
   textureTank <- getTexture TextureTank
   textureCannon <- getTexture TextureCannon
   textureBullet <- getTexture TextureBullet
+  textureCrosshair <- getTexture TextureCrosshair
   
-  (lw, lh) <- gets level >>= \l -> return (fromIntegral . levelWidth $ l :: GLfloat, fromIntegral . levelHeight $ l :: GLfloat)
+  (lw, lh) <- lift $ gets level >>= \l -> return (fromIntegral . levelWidth $ l :: GLfloat, fromIntegral . levelHeight $ l :: GLfloat)
   
   liftIO $ do
            clear [ColorBuffer]
@@ -162,3 +168,6 @@ render = do
                                                           
                                                           texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
                                                           vertex $ Vertex2 (0.1 :: GLfloat) (-0.1 :: GLfloat)
+           
+           textureBinding Texture2D $= Just textureCrosshair
+           forM_ playerlist renderPlayer

src/Texture.hs

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

src/WiimotePlayer.hs

@@ -12,16 +12,21 @@ import Data.Maybe
 import Data.Ratio ((%))
 import Data.Typeable
 import HWiid
+import Graphics.Rendering.OpenGL.GL (GLfloat, Vector3(..))
+import Graphics.Rendering.OpenGL.GL.BeginEnd (unsafeRenderPrimitive, PrimitiveMode(..))
+import Graphics.Rendering.OpenGL.GL.CoordTrans (unsafePreservingMatrix, translate)
+import Graphics.Rendering.OpenGL.GL.VertexSpec
+
 
 import Player
 import Tank
 
 
-data WiimotePlayer = WiimotePlayer Wiimote
+data WiimotePlayer = WiimotePlayer Wiimote (Float, Float)
                      deriving (Typeable, Show)
 
 instance Player WiimotePlayer where
-    playerUpdate (WiimotePlayer wiimote) tank = do
+    playerUpdate (WiimotePlayer wiimote oldaim) tank = do
                                 state <- hwiidGetState wiimote
                                 messages <- hwiidGetMesg wiimote
                                 
@@ -39,22 +44,33 @@ instance Player WiimotePlayer where
                                                      ny = ((fromIntegral . extNunchukStickY $ ext) - 0x80)/0x80
                                                  in if (nx*nx + ny*ny) < 0.4 then (x, y) else (x+nx, y+ny)
                                     
-                                    aim = handleIR state
+                                    iraim = handleIR state
-                                    aangle = if isJust aim
+                                    (aimx, aimy) = if isJust iraim then fromJust iraim else oldaim
-                                             then
+                                    ax = aimx - (fromRational . toRational . tankX $ tank)
-                                                 let aimx = fst $ fromJust aim
+                                    ay = aimy - (fromRational . toRational . tankY $ tank)
-                                                     aimy = snd $ fromJust aim
+                                    aangle = if (ax /= 0 || ay /= 0) then Just $ fromRational $ round ((atan2 ay ax)*1000000*180/pi)%1000000 else Nothing
-                                                     ax = aimx - (fromRational . toRational . tankX $ tank)
-                                                     ay = aimy - (fromRational . toRational . tankY $ tank)
-                                                 in if (ax /= 0 || ay /= 0) then Just $ fromRational $ round ((atan2 ay ax)*1000000*180/pi)%1000000 else Nothing
-                                             else
-                                                 Nothing
                                                  
                                     move = (mx /= 0 || my /= 0)
                                     angle = atan2 my mx
                                     moveangle = if move then Just $ fromRational $ round ((angle - (sin $ 8*x)/8)*1000000*180/pi)%1000000 else Nothing
                                 when foo $ print $ state
-                                return (WiimotePlayer wiimote, moveangle, move, aangle, shoot)
+                                return (WiimotePlayer wiimote (aimx, aimy), moveangle, move, aangle, shoot)
+    
+    renderPlayer (WiimotePlayer _ (x, y)) = unsafePreservingMatrix $ do
+                                translate $ Vector3 x y (0 :: GLfloat)
+                                       
+                                unsafeRenderPrimitive 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)
            
 
 irXScale :: Float
@@ -110,7 +126,7 @@ newWiimotePlayer = do
   wiimote <- hwiidOpen bdAddrAny (hwiidFlagMesgInterface .|. hwiidFlagNonblock)
   when (wiimote == nullWiimote) $ fail "Wiimote error"
   hwiidSetReportMode wiimote (hwiidReportButtons .|. hwiidReportAcc .|. hwiidReportIR .|. hwiidReportNunchuk)
-  return $ WiimotePlayer wiimote
+  return $ WiimotePlayer wiimote (0, 0)
 
 test :: (Bits a) => a -> a -> Bool
 test field bits = (field .&. bits) == bits