summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--CPUPlayer.hs3
-rw-r--r--DefaultPlayer.hs19
-rw-r--r--GLDriver.hs6
-rw-r--r--GLX.hs31
-rw-r--r--Game.hs27
-rw-r--r--HTanks.hs21
-rw-r--r--Makefile2
-rw-r--r--Player.hs8
-rw-r--r--Render.hs35
-rw-r--r--Tank.hs14
-rw-r--r--Texture.hs5
-rw-r--r--tex/Bullet.pngbin0 -> 223 bytes
-rw-r--r--tex/Cannon.pngbin584 -> 581 bytes
-rw-r--r--tex/Tank.pngbin284 -> 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
diff --git a/GLX.hs b/GLX.hs
index 3f3aec3..6f5b0fc 100644
--- a/GLX.hs
+++ b/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
-
- \ No newline at end of file
diff --git a/Game.hs b/Game.hs
index 9097bca..c782465 100644
--- a/Game.hs
+++ b/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)
diff --git a/HTanks.hs b/HTanks.hs
index c75aba2..7c648c1 100644
--- a/HTanks.hs
+++ b/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)
diff --git a/Makefile b/Makefile
index a396650..8cb0488 100644
--- a/Makefile
+++ b/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
diff --git a/Player.hs b/Player.hs
index 5c41841..baf1cbe 100644
--- a/Player.hs
+++ b/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
diff --git a/Render.hs b/Render.hs
index bd989b3..e51b2fb 100644
--- a/Render.hs
+++ b/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 \ 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
diff --git a/Texture.hs b/Texture.hs
index ca5266b..bf89cf9 100644
--- a/Texture.hs
+++ b/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)
- \ 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
new file mode 100644
index 0000000..021121f
--- /dev/null
+++ b/tex/Bullet.png
Binary files differ
diff --git a/tex/Cannon.png b/tex/Cannon.png
index 9494702..7ab3f67 100644
--- a/tex/Cannon.png
+++ b/tex/Cannon.png
Binary files differ
diff --git a/tex/Tank.png b/tex/Tank.png
index b6dd9a3..f17cdd5 100644
--- a/tex/Tank.png
+++ b/tex/Tank.png
Binary files differ