Render cannon direction; handle resize in GLX driver

CPUPlayer.hs

@@ -17,4 +17,4 @@ data CPUPlayer = CPUPlayer Micro
                  deriving (Typeable, Show)
 
 instance Player CPUPlayer where
-    playerMovement (CPUPlayer angle) _ = (CPUPlayer (if (angle+0.1) > 180 then angle-359.9 else angle+0.1), Just angle, True)
+    playerUpdate (CPUPlayer angle) _ = (CPUPlayer (if (angle+0.1) > 180 then angle-359.9 else angle+0.1), Just angle, True, Just (-angle))

DefaultPlayer.hs

@@ -14,20 +14,20 @@ import Player
 import Tank
 
 
-data DefaultPlayer = DefaultPlayer (S.Set Key)
+data DefaultPlayer = DefaultPlayer (S.Set Key) Micro Micro
                      deriving (Typeable, Show)
 
 instance Player DefaultPlayer where
-    playerMovement (DefaultPlayer keys) _ = playerMovement' keys
+    playerUpdate (DefaultPlayer keys aimx aimy) tank = playerUpdate' keys aimx aimy tank
     
-    handleEvent (DefaultPlayer keys) ev
+    handleEvent (DefaultPlayer keys aimx aimy) ev
-        | Just (KeyPressEvent key)   <- fromEvent ev = DefaultPlayer $ S.insert key keys
+        | Just (KeyPressEvent key)   <- fromEvent ev = DefaultPlayer (S.insert key keys) aimx aimy
-        | Just (KeyReleaseEvent key) <- fromEvent ev = DefaultPlayer $ S.delete key keys
+        | Just (KeyReleaseEvent key) <- fromEvent ev = DefaultPlayer (S.delete key keys) aimx aimy
-        | otherwise = DefaultPlayer keys
+        | otherwise = DefaultPlayer keys aimx aimy
 
 
-playerMovement' :: S.Set Key -> (DefaultPlayer, Maybe Micro, Bool)
+playerUpdate' :: S.Set Key -> Micro -> Micro -> Tank -> (DefaultPlayer, Maybe Micro, Bool, Maybe Micro)
-playerMovement' keys = (DefaultPlayer keys, angle, move)
+playerUpdate' keys aimx aimy tank = (DefaultPlayer keys aimx aimy, angle, move, Nothing)
     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)

GLDriver.hs

@@ -6,7 +6,7 @@ module GLDriver ( Driver(..)
                 , SomeEvent(..)
                 , fromEvent
                 , QuitEvent(..)
-                , ResizeEvent(..)
+                --, ResizeEvent(..)
                 , Key(..)
                 , KeyPressEvent(..)
                 , KeyReleaseEvent(..)
@@ -48,9 +48,6 @@ fromEvent (SomeEvent a) = cast a
 data QuitEvent = QuitEvent deriving (Typeable, Show)
 instance Event QuitEvent
 
-data ResizeEvent = ResizeEvent Int Int deriving (Typeable, Show)
-instance Event ResizeEvent
-
 
 data Key = KeyLeft | KeyRight | KeyUp | KeyDown
          deriving (Eq, Ord, Show)

GLX.hs

@@ -9,6 +9,9 @@ import Control.Monad (when, unless)
 import Data.Bits ((.|.))
 import Data.Maybe (isJust)
 
+import Graphics.Rendering.OpenGL.GL (($=), GLdouble, Capability(..))
+import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, ortho)
+
 import Graphics.X11.Types
 import Graphics.X11.Xlib.Atom (internAtom)
 import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow)
@@ -29,6 +32,7 @@ data GLX = GLX
     , glxWindow  :: !Window
     , glxContext :: !Context
     , glxDeleteWindow :: !Atom
+    , glxScale   :: !GLdouble
     }
 
 glxDriver :: GLX
@@ -37,6 +41,7 @@ glxDriver = GLX
             , glxWindow = 0
             , glxContext = Context nullPtr
             , glxDeleteWindow = 0
+            , glxScale = 1
             }
 
 
@@ -60,7 +65,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}
+      let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask .|. pointerMotionMask}
       
       wnd <- with swa $ \swaptr ->
              createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr
@@ -77,11 +82,14 @@ instance Driver GLX where
       ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
       makeCurrent disp wnd ctx
       
+      resize 800 600
+      
       return GLX
                  { glxDisplay = disp
                  , glxWindow = wnd
                  , glxContext = ctx
                  , glxDeleteWindow = delwnd
+                 , glxScale = 1
                  }
 
     deinitGL glx = do
@@ -90,33 +98,34 @@ instance Driver GLX where
     
     swapBuffers glx = Bindings.GLX.swapBuffers (glxDisplay glx) (glxWindow glx)
     
-    nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx
+    nextEvent glx = allocaXEvent $ nextEvent' glx
 
 
-nextEvent' :: GLX -> Display -> XEventPtr -> IO (Maybe SomeEvent)
+nextEvent' :: GLX -> XEventPtr -> IO (Maybe SomeEvent)
-nextEvent' glx disp xevent = do
+nextEvent' glx xevent = do
-  p <- pending disp
+  p <- pending $ glxDisplay glx
   if (p > 0) then do
-               Graphics.X11.Xlib.Event.nextEvent disp xevent
+               Graphics.X11.Xlib.Event.nextEvent (glxDisplay glx) xevent
-               ev <- handleEvent glx disp xevent
+               ev <- handleEvent glx xevent
                
                if isJust ev then
                    return ev
                             else
-                   nextEvent' glx disp xevent
+                   nextEvent' glx xevent
              else
                return Nothing
 
 
-handleEvent :: GLX -> Display -> XEventPtr -> IO (Maybe SomeEvent)
+handleEvent :: GLX -> XEventPtr -> IO (Maybe SomeEvent)
-handleEvent glx disp xevent = do
+handleEvent glx xevent = do
   event <- getEvent xevent
   let evtype = ev_event_type event
   case () of
     _ | evtype == configureNotify -> do
-                                return $ Just $ SomeEvent $ ResizeEvent (fromIntegral . ev_width $ event) (fromIntegral . ev_height $ event)
+                                resize (fromIntegral . ev_width $ event) (fromIntegral . ev_height $ event)
+                                return Nothing
       | evtype == keyPress        -> do
-                                keysym <- keycodeToKeysym disp (ev_keycode event) 0
+                                keysym <- keycodeToKeysym (glxDisplay glx) (ev_keycode event) 0
                                 case () of
                                   _ | keysym == xK_Escape -> return $ Just $ SomeEvent QuitEvent
                                     | keysym == xK_Up     -> return $ Just $ SomeEvent $ KeyPressEvent KeyUp
@@ -125,7 +134,7 @@ handleEvent glx disp xevent = do
                                     | keysym == xK_Right  -> return $ Just $ SomeEvent $ KeyPressEvent KeyRight
                                     | otherwise           -> return Nothing
       | evtype == keyRelease      -> do
-                                keysym <- keycodeToKeysym disp (ev_keycode event) 0
+                                keysym <- keycodeToKeysym (glxDisplay glx) (ev_keycode event) 0
                                 case () of
                                   _ | keysym == xK_Up     -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyUp
                                     | keysym == xK_Down   -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyDown
@@ -141,6 +150,20 @@ handleEvent glx disp xevent = do
       | otherwise -> return Nothing
 
 
+resize :: Int -> Int -> IO ()
+resize w h = do
+  let aspect = (fromIntegral w)/(fromIntegral h)
+      s = max (5/aspect) 5 :: GLdouble
+  
+  matrixMode $= Projection
+  loadIdentity
+  ortho (-s*aspect) (s*aspect) (-s) s (-1) 1
+  
+  matrixMode $= Modelview 0
+  
+  viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h)))
+
+
 waitForMapNotify :: Display -> Window -> IO ()
 waitForMapNotify disp wnd = allocaXEvent waitForMapNotify'
     where

HTanks.hs

@@ -44,7 +44,7 @@ main = do
   when (initialized gl) $ do
          currentTime <- getCurrentTime
          let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, players =
-                                          [ SomePlayer $ DefaultPlayer S.empty
+                                          [ SomePlayer $ DefaultPlayer S.empty 0 0
                                           , SomePlayer $ CPUPlayer 0
                                           ]}
              gameState = GameState {level = testLevel, tanks = [ Tank 0.0 0.0 0 0 2 360 False
@@ -52,7 +52,7 @@ main = do
                                                                ], textures = M.empty}
          
          runGame gameState $ do
-                            setup 800 600
+                            setup
                             runMain mainState mainLoop
          
          deinitGL gl
@@ -123,11 +123,14 @@ updateAngle angle = do
   modify $ \tank -> tank {dir = newangle180}
 
 
-updateTank :: Maybe Micro -> Bool -> State Tank ()
+updateTank :: Maybe Micro -> Bool -> Maybe Micro -> State Tank ()
-updateTank angle move = do
+updateTank angle move aangle = do
   when (isJust angle) $
        updateAngle $ fromJust angle
-                   
+  
+  when (isJust aangle) $
+       modify $ \tank -> tank {aim = fromJust aangle}
+  
   when move $ do
     tdir <- gets dir
     tspeed <- gets speed
@@ -154,8 +157,8 @@ simulationStep = do
   modify $ \state -> state {players = fst pt}
   lift $ modify $ \state -> state {tanks = snd pt}
     where
-      updateTank' (player, tank) = let (p, angle, move) = playerMovement player tank
+      updateTank' (player, tank) = let (p, angle, move, aangle) = playerUpdate player tank
-                                       t = execState (updateTank angle move) tank
+                                       t = execState (updateTank angle move aangle) tank
                                    in (p, t)
       
 
@@ -169,6 +172,5 @@ handleEvents = do
 
 handleEvent :: SomeEvent -> Main ()
 handleEvent ev
-    | Just (ResizeEvent w h)     <- fromEvent ev = lift $ resize w h
+    | Just QuitEvent         <- fromEvent ev = modify $ \state -> state {run = False}
-    | Just QuitEvent             <- fromEvent ev = modify $ \state -> state {run = False}
     | otherwise = return ()

Player.hs

@@ -12,7 +12,7 @@ import GLDriver (SomeEvent)
 
 
 class Player a where
-    playerMovement :: a -> Tank -> (a, Maybe Micro, Bool)
+    playerUpdate :: a -> Tank -> (a, Maybe Micro, Bool, Maybe Micro)
     handleEvent :: a -> SomeEvent -> a
     
     handleEvent player _ = player
@@ -21,5 +21,7 @@ class Player a where
 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
+    playerUpdate (SomePlayer player) tank = 
+        let (p, angle, move, aangle) = playerUpdate player tank
+        in (SomePlayer p, angle, move, aangle)
     handleEvent (SomePlayer player) event = SomePlayer $ handleEvent player event

Render.hs

@@ -1,5 +1,5 @@
 module Render ( setup
-              , resize
+              --, resize
               , render
               ) where
 
@@ -34,6 +34,7 @@ texturePath :: Texture -> String
 texturePath t
     | t == TextureWood = "tex/Wood.png"
     | t == TextureTank = "tex/Tank.png"
+    | t == TextureCannon = "tex/Cannon.png"
 
 getTexture :: Texture -> Game TextureObject
 getTexture t = do
@@ -49,9 +50,8 @@ getTexture t = do
           return tex
                                                
 
-setup :: Int -> Int -> Game ()
+setup :: Game ()
-setup w h = do
+setup = do
-  resize w h
   liftIO $ do
     blend $= Enabled
     blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
@@ -59,33 +59,17 @@ setup w h = do
   -- cache textures
   getTexture TextureWood
   getTexture TextureTank
+  getTexture TextureCannon
   
   return ()
 
-resize :: Int -> Int -> Game ()
-resize w h = do
-  let wn = fromIntegral w
-      hn = fromIntegral h
-      aspect = fromReal (wn/hn)
-  
-  lvl <- gets level
-  let s = max (0.5*(fromIntegral $ levelWidth lvl)/aspect) (0.5*(fromIntegral $ levelHeight lvl)) :: GLdouble
-  
-  liftIO $ do
-    matrixMode $= Projection
-    loadIdentity
-    ortho (-s*aspect) (s*aspect) (-s) s (-1) 1
-    
-    matrixMode $= Modelview 0
-    
-    viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h)))
-
 
 render :: Game ()
 render = do
   tanklist <- gets tanks
   textureWood <- getTexture TextureWood
   textureTank <- getTexture TextureTank
+  textureCannon <- getTexture TextureCannon
   
   (lw, lh) <- gets level >>= \l -> return (fromIntegral . levelWidth $ l :: GLfloat, fromIntegral . levelHeight $ l :: GLfloat)
   
@@ -108,14 +92,33 @@ render = do
              texCoord $ TexCoord2 lh (0 :: GLfloat)
              vertex $ Vertex2 (0.5*lw) (-0.5*lh)
              
-           textureBinding Texture2D $= Just textureTank
-           
            forM_ tanklist $ \tank -> preservingMatrix $ do
                                        let x = fromReal . posx $ tank
                                            y = fromReal . posy $ tank
+                                           rotDir = 90 + (fromReal . dir $ tank)
+                                           rotAim = 90 + (fromReal . aim $ tank)
                                        
                                        translate $ Vector3 x y (0 :: GLfloat)
-                                       rotate (90 + (fromReal . dir $ tank)) $ Vector3 0 0 (1 :: GLfloat)
+                                       rotate rotDir $ Vector3 0 0 (1 :: GLfloat)
+                                       
+                                       textureBinding Texture2D $= Just textureTank
+                                       
+                                       renderPrimitive Quads $ do
+                                                          texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
+                                                          vertex $ Vertex2 (-0.5 :: GLfloat) (-0.5 :: GLfloat)
+                                                          
+                                                          texCoord $ TexCoord2 (0 :: GLfloat) (1 :: GLfloat)
+                                                          vertex $ Vertex2 (-0.5 :: GLfloat) (0.5 :: GLfloat)
+                                                          
+                                                          texCoord $ TexCoord2 (1 :: GLfloat) (1 :: GLfloat)
+                                                          vertex $ Vertex2 (0.5 :: GLfloat) (0.5 :: GLfloat)
+                                                          
+                                                          texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
+                                                          vertex $ Vertex2 (0.5 :: GLfloat) (-0.5 :: GLfloat)
+                                       
+                                       rotate (rotAim-rotDir) $ Vector3 0 0 (1 :: GLfloat)
+                                       
+                                       textureBinding Texture2D $= Just textureCannon
                                        
                                        renderPrimitive Quads $ do
                                                           texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
@@ -130,5 +133,6 @@ render = do
                                                           texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
                                                           vertex $ Vertex2 (0.5 :: GLfloat) (-0.5 :: GLfloat)
 
+
 fromReal :: (Real a, Fractional b) => a -> b
 fromReal = fromRational . toRational

Texture.hs

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