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

Handle quit events

Browse source
This commit is contained in:
Matthias Schiffer 2010-02-22 22:25:06 +01:00
parent 8f693405d6
commit f10352a0f1
5 changed files with 149 additions and 75 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Bindings/GLX.chs
View file

@ -17,6 +17,7 @@ module Bindings.GLX ( createColormap
, stencilSize , stencilSize
, createContext , createContext
, makeCurrent , makeCurrent
, destroyContext
, Context(..) , Context(..)
) where ) where
@ -241,3 +242,6 @@ foreign import ccall unsafe "GL/glx.h glXCreateContext"
foreign import ccall unsafe "GL/glx.h glXMakeCurrent" foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
makeCurrent :: Display -> XID -> Context -> IO Bool makeCurrent :: Display -> XID -> Context -> IO Bool
foreign import ccall unsafe "GL/glx.h glXDestroyContext"
destroyContext :: Display -> Context -> IO ()

122
Bindings/GLX.hs
View file

@ -20,6 +20,7 @@ module Bindings.GLX ( createColormap
, stencilSize , stencilSize
, createContext , createContext
, makeCurrent , makeCurrent
, destroyContext
, Context(..) , Context(..)
) where ) where
@ -40,7 +41,7 @@ import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
{-# LINE 40 "GLX.chs" #-} {-# LINE 41 "GLX.chs" #-}
newtype FBConfig = FBConfig (Ptr FBConfig) newtype FBConfig = FBConfig (Ptr FBConfig)
@ -67,55 +68,55 @@ data VisualInfo = VisualInfo
instance Storable VisualInfo where instance Storable VisualInfo where
sizeOf _ = ((40)) sizeOf _ = ((40))
{-# LINE 66 "GLX.chs" #-} {-# LINE 67 "GLX.chs" #-}
alignment _ = alignment (undefined :: CULong) alignment _ = alignment (undefined :: CULong)
peek vi = do peek vi = do
visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi
{-# LINE 70 "GLX.chs" #-}
visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
{-# LINE 71 "GLX.chs" #-} {-# LINE 71 "GLX.chs" #-}
screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
{-# LINE 72 "GLX.chs" #-} {-# LINE 72 "GLX.chs" #-}
depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi
{-# LINE 73 "GLX.chs" #-} {-# LINE 73 "GLX.chs" #-}
viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi
{-# LINE 74 "GLX.chs" #-} {-# LINE 74 "GLX.chs" #-}
red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi
{-# LINE 75 "GLX.chs" #-} {-# LINE 75 "GLX.chs" #-}
green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi
{-# LINE 76 "GLX.chs" #-} {-# LINE 76 "GLX.chs" #-}
blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi
{-# LINE 77 "GLX.chs" #-} {-# LINE 77 "GLX.chs" #-}
colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi
{-# LINE 78 "GLX.chs" #-} {-# LINE 78 "GLX.chs" #-}
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi
{-# LINE 79 "GLX.chs" #-} {-# LINE 79 "GLX.chs" #-}
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi
{-# LINE 80 "GLX.chs" #-}
return (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb) return (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb)
poke vi (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb) = do poke vi (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb) = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) vi visual ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) vi visual
{-# LINE 85 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
{-# LINE 86 "GLX.chs" #-} {-# LINE 86 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
{-# LINE 87 "GLX.chs" #-} {-# LINE 87 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen
{-# LINE 88 "GLX.chs" #-} {-# LINE 88 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth
{-# LINE 89 "GLX.chs" #-} {-# LINE 89 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass
{-# LINE 90 "GLX.chs" #-} {-# LINE 90 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask
{-# LINE 91 "GLX.chs" #-} {-# LINE 91 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask
{-# LINE 92 "GLX.chs" #-} {-# LINE 92 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask
{-# LINE 93 "GLX.chs" #-} {-# LINE 93 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size
{-# LINE 94 "GLX.chs" #-} {-# LINE 94 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb
{-# LINE 95 "GLX.chs" #-}
data SetWindowAttributes = SetWindowAttributes data SetWindowAttributes = SetWindowAttributes
@ -137,38 +138,38 @@ data SetWindowAttributes = SetWindowAttributes
instance Storable SetWindowAttributes where instance Storable SetWindowAttributes where
sizeOf _ = ((60)) sizeOf _ = ((60))
{-# LINE 115 "GLX.chs" #-} {-# LINE 116 "GLX.chs" #-}
alignment _ = alignment (undefined :: CULong) alignment _ = alignment (undefined :: CULong)
peek swa = do peek swa = do
background_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) swa background_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) swa
{-# LINE 119 "GLX.chs" #-}
background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
{-# LINE 120 "GLX.chs" #-} {-# LINE 120 "GLX.chs" #-}
border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
{-# LINE 121 "GLX.chs" #-} {-# LINE 121 "GLX.chs" #-}
bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa
{-# LINE 122 "GLX.chs" #-} {-# LINE 122 "GLX.chs" #-}
win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa
{-# LINE 123 "GLX.chs" #-} {-# LINE 123 "GLX.chs" #-}
backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa
{-# LINE 124 "GLX.chs" #-} {-# LINE 124 "GLX.chs" #-}
backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa
{-# LINE 125 "GLX.chs" #-} {-# LINE 125 "GLX.chs" #-}
backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa
{-# LINE 126 "GLX.chs" #-} {-# LINE 126 "GLX.chs" #-}
save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa
{-# LINE 127 "GLX.chs" #-} {-# LINE 127 "GLX.chs" #-}
event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa
{-# LINE 128 "GLX.chs" #-} {-# LINE 128 "GLX.chs" #-}
do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa
{-# LINE 129 "GLX.chs" #-} {-# LINE 129 "GLX.chs" #-}
override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa
{-# LINE 130 "GLX.chs" #-} {-# LINE 130 "GLX.chs" #-}
colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa
{-# LINE 131 "GLX.chs" #-} {-# LINE 131 "GLX.chs" #-}
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa
{-# LINE 132 "GLX.chs" #-} {-# LINE 132 "GLX.chs" #-}
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
{-# LINE 133 "GLX.chs" #-}
return (SetWindowAttributes return (SetWindowAttributes
background_pixmap background_pixmap
@ -202,33 +203,33 @@ instance Storable SetWindowAttributes where
colormap colormap
cursor) = do cursor) = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) swa background_pixmap ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) swa background_pixmap
{-# LINE 165 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
{-# LINE 166 "GLX.chs" #-} {-# LINE 166 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
{-# LINE 167 "GLX.chs" #-} {-# LINE 167 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap
{-# LINE 168 "GLX.chs" #-} {-# LINE 168 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity
{-# LINE 169 "GLX.chs" #-} {-# LINE 169 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity
{-# LINE 170 "GLX.chs" #-} {-# LINE 170 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store
{-# LINE 171 "GLX.chs" #-} {-# LINE 171 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes
{-# LINE 172 "GLX.chs" #-} {-# LINE 172 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel
{-# LINE 173 "GLX.chs" #-} {-# LINE 173 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under
{-# LINE 174 "GLX.chs" #-} {-# LINE 174 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask
{-# LINE 175 "GLX.chs" #-} {-# LINE 175 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect ((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask
{-# LINE 176 "GLX.chs" #-} {-# LINE 176 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap ((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect
{-# LINE 177 "GLX.chs" #-} {-# LINE 177 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor ((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap
{-# LINE 178 "GLX.chs" #-} {-# LINE 178 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor
{-# LINE 179 "GLX.chs" #-}
nullSetWindowAttributes :: SetWindowAttributes nullSetWindowAttributes :: SetWindowAttributes
nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0) nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0)
@ -258,35 +259,35 @@ chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (con
renderType :: CInt renderType :: CInt
renderType = (32785) renderType = (32785)
{-# LINE 207 "GLX.chs" #-} {-# LINE 208 "GLX.chs" #-}
rgbaBit :: CInt rgbaBit :: CInt
rgbaBit = (1) rgbaBit = (1)
{-# LINE 210 "GLX.chs" #-} {-# LINE 211 "GLX.chs" #-}
drawableType :: CInt drawableType :: CInt
drawableType = (32784) drawableType = (32784)
{-# LINE 213 "GLX.chs" #-} {-# LINE 214 "GLX.chs" #-}
windowBit :: CInt windowBit :: CInt
windowBit = (1) windowBit = (1)
{-# LINE 216 "GLX.chs" #-} {-# LINE 217 "GLX.chs" #-}
xRenderable :: CInt xRenderable :: CInt
xRenderable = (32786) xRenderable = (32786)
{-# LINE 219 "GLX.chs" #-} {-# LINE 220 "GLX.chs" #-}
doublebuffer :: CInt doublebuffer :: CInt
doublebuffer = (5) doublebuffer = (5)
{-# LINE 222 "GLX.chs" #-} {-# LINE 223 "GLX.chs" #-}
depthSize :: CInt depthSize :: CInt
depthSize = (12) depthSize = (12)
{-# LINE 225 "GLX.chs" #-} {-# LINE 226 "GLX.chs" #-}
stencilSize :: CInt stencilSize :: CInt
stencilSize = (13) stencilSize = (13)
{-# LINE 228 "GLX.chs" #-} {-# LINE 229 "GLX.chs" #-}
foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig" foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo) glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo)
@ -303,3 +304,6 @@ foreign import ccall unsafe "GL/glx.h glXCreateContext"
foreign import ccall unsafe "GL/glx.h glXMakeCurrent" foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
makeCurrent :: Display -> XID -> Context -> IO Bool makeCurrent :: Display -> XID -> Context -> IO Bool
foreign import ccall unsafe "GL/glx.h glXDestroyContext"
destroyContext :: Display -> Context -> IO ()

3
GLDriver.hs
View file

@ -3,7 +3,8 @@
module GLDriver ( Driver(..) module GLDriver ( Driver(..)
, Event , Event
, SomeEvent(..) , SomeEvent(..)
, QuitEvent , QuitEvent(..)
, fromEvent
) where ) where
import Data.Typeable import Data.Typeable

84
GLX.hs
View file

@ -7,12 +7,16 @@ import Bindings.GLX
import Control.Monad (when, unless) import Control.Monad (when, unless)
import Data.Bits ((.|.)) import Data.Bits ((.|.))
import Data.Maybe (isJust)
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib.Atom (internAtom)
import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow) import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow)
import Graphics.X11.Xlib.Event (allocaXEvent, nextEvent, get_Window, get_EventType) import Graphics.X11.Xlib.Event (XEventPtr, allocaXEvent, nextEvent, get_Window, get_EventType, pending)
import Graphics.X11.Xlib.Extras (getEvent, ev_event_type, ev_keycode, ev_data)
import Graphics.X11.Xlib.Misc (keycodeToKeysym, setWMProtocols)
import Graphics.X11.Xlib.Types import Graphics.X11.Xlib.Types
import Graphics.X11.Xlib.Window (mapWindow) import Graphics.X11.Xlib.Window (destroyWindow, mapWindow)
import Foreign.Marshal.Utils (with) import Foreign.Marshal.Utils (with)
import Foreign.Ptr import Foreign.Ptr
@ -20,19 +24,30 @@ import Foreign.Storable
data GLX = GLX Bool data GLX = GLX
{ glxDisplay :: !Display
, glxWindow :: !Window
, glxContext :: !Context
, glxDeleteWindow :: !Atom
}
glxDriver :: GLX glxDriver :: GLX
glxDriver = GLX False glxDriver = GLX
{ glxDisplay = Display nullPtr
, glxWindow = 0
, glxContext = Context nullPtr
, glxDeleteWindow = 0
}
instance Driver GLX where instance Driver GLX where
initialized (GLX inited) = inited initialized glx = ((glxContext glx) == (Context nullPtr))
initGL (GLX inited) = do initGL glx = do
when (inited) $ fail "GLX already initialized" when ((glxContext glx) /= (Context nullPtr)) $ fail "GLX already initialized"
disp <- openDisplay "" disp <- openDisplay ""
delwnd <- internAtom disp "WM_DELETE_WINDOW" False
fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp) fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp)
[(renderType, rgbaBit) [(renderType, rgbaBit)
, (drawableType, windowBit) , (drawableType, windowBit)
@ -46,7 +61,11 @@ instance Driver GLX where
let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask} let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask}
wnd <- with swa $ \swaptr -> createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr wnd <- with swa $ \swaptr ->
createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr
setWMProtocols disp wnd [delwnd]
mapWindow disp wnd mapWindow disp wnd
waitForMapNotify disp wnd waitForMapNotify disp wnd
@ -54,11 +73,52 @@ instance Driver GLX where
ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
makeCurrent disp wnd ctx makeCurrent disp wnd ctx
return (GLX True) return GLX
{ glxDisplay = disp
, glxWindow = wnd
, glxContext = ctx
, glxDeleteWindow = delwnd
}
deinitGL glx = do
destroyWindow (glxDisplay glx) (glxWindow glx)
destroyContext (glxDisplay glx) (glxContext glx)
deinitGL _ = return () nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx
nextEvent _ = return Nothing
nextEvent' :: GLX -> Display -> XEventPtr -> IO (Maybe SomeEvent)
nextEvent' glx disp xevent = do
p <- pending disp
if (p > 0) then do
Graphics.X11.Xlib.Event.nextEvent disp xevent
ev <- handleEvent glx disp xevent
if isJust ev then
return ev
else
nextEvent' glx disp xevent
else
return Nothing
handleEvent :: GLX -> Display -> XEventPtr -> IO (Maybe SomeEvent)
handleEvent glx disp xevent = do
event <- getEvent xevent
let evtype = ev_event_type event
case () of
_ | evtype == keyPress -> do
keysym <- keycodeToKeysym disp (ev_keycode event) 0
case () of
_ | keysym == xK_Escape -> return $ Just $ SomeEvent QuitEvent
| otherwise -> return Nothing
| evtype == clientMessage -> do
if ((glxDeleteWindow glx) == (fromIntegral . head . ev_data $ event))
then
return $ Just $ SomeEvent QuitEvent
else
return Nothing
| otherwise -> return Nothing
waitForMapNotify :: Display -> Window -> IO () waitForMapNotify :: Display -> Window -> IO ()

11
HTanks.hs
View file

@ -1,3 +1,5 @@
{-# LANGUAGE PatternGuards #-}
import Game import Game
import Level import Level
import Tank import Tank
@ -16,8 +18,9 @@ main = do
let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]} let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]}
(_, gameState) <- runGame gameState $ mainLoop gl runGame gameState $ mainLoop gl
print $ tanks gameState
deinitGL gl
mainLoop :: Driver a => a -> Game () mainLoop :: Driver a => a -> Game ()
mainLoop gl = do mainLoop gl = do
@ -35,4 +38,6 @@ handleEvents gl = do
return True return True
handleEvent :: SomeEvent -> IO Bool handleEvent :: SomeEvent -> IO Bool
handleEvent ev = return True handleEvent ev
| Just QuitEvent <- fromEvent ev = return False
| otherwise = return True