diff options
| -rw-r--r-- | CPUPlayer.hs | 2 | ||||
| -rw-r--r-- | DefaultPlayer.hs | 16 | ||||
| -rw-r--r-- | GLDriver.hs | 5 | ||||
| -rw-r--r-- | GLX.hs | 49 | ||||
| -rw-r--r-- | HTanks.hs | 20 | ||||
| -rw-r--r-- | Player.hs | 6 | ||||
| -rw-r--r-- | Render.hs | 54 | ||||
| -rw-r--r-- | Texture.hs | 2 | ||||
| -rw-r--r-- | tex/Cannon.png | bin | 0 -> 584 bytes | |||
| -rw-r--r-- | tex/Tank.png | bin | 537 -> 1076 bytes |
10 files changed, 91 insertions, 63 deletions
diff --git a/CPUPlayer.hs b/CPUPlayer.hs index e5fa77e..6677f9f 100644 --- a/CPUPlayer.hs +++ b/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)) diff --git a/DefaultPlayer.hs b/DefaultPlayer.hs index 351928f..d1c1e24 100644 --- a/DefaultPlayer.hs +++ b/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 - | Just (KeyPressEvent key) <- fromEvent ev = DefaultPlayer $ S.insert key keys - | Just (KeyReleaseEvent key) <- fromEvent ev = DefaultPlayer $ S.delete key keys - | otherwise = DefaultPlayer keys + 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 + | otherwise = DefaultPlayer keys aimx aimy -playerMovement' :: S.Set Key -> (DefaultPlayer, Maybe Micro, Bool) -playerMovement' keys = (DefaultPlayer keys, angle, move) +playerUpdate' :: S.Set Key -> Micro -> Micro -> Tank -> (DefaultPlayer, Maybe Micro, Bool, Maybe Micro) +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) diff --git a/GLDriver.hs b/GLDriver.hs index 44964d8..f4dca5e 100644 --- a/GLDriver.hs +++ b/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) @@ -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 disp xevent = do - p <- pending disp +nextEvent' :: GLX -> XEventPtr -> IO (Maybe SomeEvent) +nextEvent' glx xevent = do + p <- pending $ glxDisplay glx if (p > 0) then do - Graphics.X11.Xlib.Event.nextEvent disp xevent - ev <- handleEvent glx disp xevent + Graphics.X11.Xlib.Event.nextEvent (glxDisplay glx) 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 disp xevent = do +handleEvent :: GLX -> XEventPtr -> IO (Maybe SomeEvent) +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 @@ -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 angle move = do +updateTank :: Maybe Micro -> Bool -> Maybe Micro -> State Tank () +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 - t = execState (updateTank angle move) tank + updateTank' (player, tank) = let (p, angle, move, aangle) = playerUpdate player 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 () @@ -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 @@ -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 w h = do - resize w h +setup :: Game () +setup = do 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
\ No newline at end of file @@ -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)
\ No newline at end of file diff --git a/tex/Cannon.png b/tex/Cannon.png Binary files differnew file mode 100644 index 0000000..9494702 --- /dev/null +++ b/tex/Cannon.png diff --git a/tex/Tank.png b/tex/Tank.png Binary files differindex 3e7b6b3..c87098d 100644 --- a/tex/Tank.png +++ b/tex/Tank.png |
