summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--CPUPlayer.hs2
-rw-r--r--DefaultPlayer.hs16
-rw-r--r--GLDriver.hs5
-rw-r--r--GLX.hs49
-rw-r--r--HTanks.hs20
-rw-r--r--Player.hs6
-rw-r--r--Render.hs54
-rw-r--r--Texture.hs2
-rw-r--r--tex/Cannon.pngbin0 -> 584 bytes
-rw-r--r--tex/Tank.pngbin537 -> 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)
diff --git a/GLX.hs b/GLX.hs
index 3dbb362..4e9abc4 100644
--- a/GLX.hs
+++ b/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 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
diff --git a/HTanks.hs b/HTanks.hs
index 1f6ac11..1bbae03 100644
--- a/HTanks.hs
+++ b/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 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 ()
diff --git a/Player.hs b/Player.hs
index f3303f8..5c41841 100644
--- a/Player.hs
+++ b/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
diff --git a/Render.hs b/Render.hs
index 8832d3b..145dc8b 100644
--- a/Render.hs
+++ b/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 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
diff --git a/Texture.hs b/Texture.hs
index 35c48e8..ca5266b 100644
--- a/Texture.hs
+++ b/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)
\ No newline at end of file
diff --git a/tex/Cannon.png b/tex/Cannon.png
new file mode 100644
index 0000000..9494702
--- /dev/null
+++ b/tex/Cannon.png
Binary files differ
diff --git a/tex/Tank.png b/tex/Tank.png
index 3e7b6b3..c87098d 100644
--- a/tex/Tank.png
+++ b/tex/Tank.png
Binary files differ