neocturne/htanks
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Render cannon direction; handle resize in GLX driver

Browse source
This commit is contained in:
Matthias Schiffer 2010-03-05 03:32:02 +01:00
parent 88fd16d930
commit 1020310190
10 changed files with 91 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CPUPlayer.hs
View file

@ -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))

16
DefaultPlayer.hs
View file

@ -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)

5
GLDriver.hs
View file

@ -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)

49
GLX.hs
View file

@ -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

20
HTanks.hs
View file

@ -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 ()

6
Player.hs
View file

@ -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

54
Render.hs
View file

@ -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

2
Texture.hs
View 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)

BIN
tex/Cannon.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 584 B

BIN
tex/Tank.png
View file

Binary file not shown.
Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 537 B

After

Width:  |  Height:  |  Size: 1.1 KiB