diff options
| -rw-r--r-- | CPUPlayer.hs | 3 | ||||
| -rw-r--r-- | DefaultPlayer.hs | 19 | ||||
| -rw-r--r-- | GLDriver.hs | 6 | ||||
| -rw-r--r-- | GLX.hs | 31 | ||||
| -rw-r--r-- | Game.hs | 27 | ||||
| -rw-r--r-- | HTanks.hs | 21 | ||||
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | Player.hs | 8 | ||||
| -rw-r--r-- | Render.hs | 35 | ||||
| -rw-r--r-- | Tank.hs | 14 | ||||
| -rw-r--r-- | Texture.hs | 5 | ||||
| -rw-r--r-- | tex/Bullet.png | bin | 0 -> 223 bytes | |||
| -rw-r--r-- | tex/Cannon.png | bin | 584 -> 581 bytes | |||
| -rw-r--r-- | tex/Tank.png | bin | 284 -> 288 bytes |
14 files changed, 113 insertions, 58 deletions
diff --git a/CPUPlayer.hs b/CPUPlayer.hs index 6677f9f..0276de3 100644 --- a/CPUPlayer.hs +++ b/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) diff --git a/DefaultPlayer.hs b/DefaultPlayer.hs index 6f80096..431b298 100644 --- a/DefaultPlayer.hs +++ b/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 diff --git a/GLDriver.hs b/GLDriver.hs index ce84563..7340075 100644 --- a/GLDriver.hs +++ b/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
\ No newline at end of file +instance Event MouseMotionEvent + +data MousePressEvent = MousePressEvent Float Float deriving (Typeable, Show) +instance Event MousePressEvent @@ -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 - -
\ No newline at end of file @@ -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) @@ -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) @@ -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 @@ -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 @@ -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
\ No newline at end of file diff --git a/Tank.hs b/Tank.hs deleted file mode 100644 index 4b68889..0000000 --- a/Tank.hs +++ /dev/null @@ -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 @@ -4,6 +4,5 @@ module Texture ( Texture(..) import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) -data Texture = TextureWood | TextureTank | TextureCannon - deriving (Eq, Ord, Show) -
\ No newline at end of file +data Texture = TextureWood | TextureTank | TextureCannon | TextureBullet + deriving (Eq, Ord, Show) diff --git a/tex/Bullet.png b/tex/Bullet.png Binary files differnew file mode 100644 index 0000000..021121f --- /dev/null +++ b/tex/Bullet.png diff --git a/tex/Cannon.png b/tex/Cannon.png Binary files differindex 9494702..7ab3f67 100644 --- a/tex/Cannon.png +++ b/tex/Cannon.png diff --git a/tex/Tank.png b/tex/Tank.png Binary files differindex b6dd9a3..f17cdd5 100644 --- a/tex/Tank.png +++ b/tex/Tank.png |
