From f10352a0f1626ce1475acb9c27067e52e90a20fb Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Mon, 22 Feb 2010 22:25:06 +0100 Subject: Handle quit events --- Bindings/GLX.chs | 4 ++ Bindings/GLX.hs | 122 ++++++++++++++++++++++++++++--------------------------- GLDriver.hs | 3 +- GLX.hs | 84 ++++++++++++++++++++++++++++++++------ HTanks.hs | 11 +++-- 5 files changed, 149 insertions(+), 75 deletions(-) diff --git a/Bindings/GLX.chs b/Bindings/GLX.chs index 58bc8cf..37669f3 100644 --- a/Bindings/GLX.chs +++ b/Bindings/GLX.chs @@ -17,6 +17,7 @@ module Bindings.GLX ( createColormap , stencilSize , createContext , makeCurrent + , destroyContext , Context(..) ) where @@ -241,3 +242,6 @@ foreign import ccall unsafe "GL/glx.h glXCreateContext" foreign import ccall unsafe "GL/glx.h glXMakeCurrent" makeCurrent :: Display -> XID -> Context -> IO Bool + +foreign import ccall unsafe "GL/glx.h glXDestroyContext" + destroyContext :: Display -> Context -> IO () \ No newline at end of file diff --git a/Bindings/GLX.hs b/Bindings/GLX.hs index d281f55..78fe0e3 100644 --- a/Bindings/GLX.hs +++ b/Bindings/GLX.hs @@ -20,6 +20,7 @@ module Bindings.GLX ( createColormap , stencilSize , createContext , makeCurrent + , destroyContext , Context(..) ) 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) @@ -67,55 +68,55 @@ data VisualInfo = VisualInfo instance Storable VisualInfo where sizeOf _ = ((40)) -{-# LINE 66 "GLX.chs" #-} +{-# LINE 67 "GLX.chs" #-} alignment _ = alignment (undefined :: CULong) peek vi = do visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi -{-# LINE 70 "GLX.chs" #-} - visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi {-# LINE 71 "GLX.chs" #-} - screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi + visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi {-# LINE 72 "GLX.chs" #-} - depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi + screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi {-# LINE 73 "GLX.chs" #-} - viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi + depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi {-# 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" #-} - green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi + red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi {-# 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" #-} - colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi + blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi {-# 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" #-} + 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) 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 -{-# LINE 85 "GLX.chs" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid {-# LINE 86 "GLX.chs" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen + ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid {-# LINE 87 "GLX.chs" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth + ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen {-# LINE 88 "GLX.chs" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass + ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth {-# 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" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask + ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask {-# 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" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size + ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask {-# 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" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb +{-# LINE 95 "GLX.chs" #-} data SetWindowAttributes = SetWindowAttributes @@ -137,38 +138,38 @@ data SetWindowAttributes = SetWindowAttributes instance Storable SetWindowAttributes where sizeOf _ = ((60)) -{-# LINE 115 "GLX.chs" #-} +{-# LINE 116 "GLX.chs" #-} alignment _ = alignment (undefined :: CULong) peek swa = do 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" #-} - border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa + background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa {-# 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" #-} - win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa + bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa {-# 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" #-} - backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa + backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa {-# 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" #-} - save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa + backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa {-# 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" #-} - do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa + event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa {-# 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" #-} - colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa + override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa {-# LINE 131 "GLX.chs" #-} - cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa + colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa {-# LINE 132 "GLX.chs" #-} + cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa +{-# LINE 133 "GLX.chs" #-} return (SetWindowAttributes background_pixmap @@ -202,33 +203,33 @@ instance Storable SetWindowAttributes where colormap cursor) = do ((\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" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap + ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel {-# 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" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity + ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity {-# 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" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes + ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store {-# 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" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under + ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel {-# 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" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask + ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask {-# 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" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap + ((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect {-# LINE 177 "GLX.chs" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor + ((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap {-# LINE 178 "GLX.chs" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor +{-# LINE 179 "GLX.chs" #-} nullSetWindowAttributes :: SetWindowAttributes 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 = (32785) -{-# LINE 207 "GLX.chs" #-} +{-# LINE 208 "GLX.chs" #-} rgbaBit :: CInt rgbaBit = (1) -{-# LINE 210 "GLX.chs" #-} +{-# LINE 211 "GLX.chs" #-} drawableType :: CInt drawableType = (32784) -{-# LINE 213 "GLX.chs" #-} +{-# LINE 214 "GLX.chs" #-} windowBit :: CInt windowBit = (1) -{-# LINE 216 "GLX.chs" #-} +{-# LINE 217 "GLX.chs" #-} xRenderable :: CInt xRenderable = (32786) -{-# LINE 219 "GLX.chs" #-} +{-# LINE 220 "GLX.chs" #-} doublebuffer :: CInt doublebuffer = (5) -{-# LINE 222 "GLX.chs" #-} +{-# LINE 223 "GLX.chs" #-} depthSize :: CInt depthSize = (12) -{-# LINE 225 "GLX.chs" #-} +{-# LINE 226 "GLX.chs" #-} stencilSize :: CInt stencilSize = (13) -{-# LINE 228 "GLX.chs" #-} +{-# LINE 229 "GLX.chs" #-} foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig" 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" makeCurrent :: Display -> XID -> Context -> IO Bool + +foreign import ccall unsafe "GL/glx.h glXDestroyContext" + destroyContext :: Display -> Context -> IO () \ No newline at end of file diff --git a/GLDriver.hs b/GLDriver.hs index 45ce982..74c02e2 100644 --- a/GLDriver.hs +++ b/GLDriver.hs @@ -3,7 +3,8 @@ module GLDriver ( Driver(..) , Event , SomeEvent(..) - , QuitEvent + , QuitEvent(..) + , fromEvent ) where import Data.Typeable diff --git a/GLX.hs b/GLX.hs index 35705d9..a50dbab 100644 --- a/GLX.hs +++ b/GLX.hs @@ -7,12 +7,16 @@ import Bindings.GLX import Control.Monad (when, unless) import Data.Bits ((.|.)) +import Data.Maybe (isJust) import Graphics.X11.Types +import Graphics.X11.Xlib.Atom (internAtom) 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.Window (mapWindow) +import Graphics.X11.Xlib.Window (destroyWindow, mapWindow) import Foreign.Marshal.Utils (with) 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 False +glxDriver = GLX + { glxDisplay = Display nullPtr + , glxWindow = 0 + , glxContext = Context nullPtr + , glxDeleteWindow = 0 + } instance Driver GLX where - initialized (GLX inited) = inited + initialized glx = ((glxContext glx) == (Context nullPtr)) - initGL (GLX inited) = do - when (inited) $ fail "GLX already initialized" + initGL glx = do + when ((glxContext glx) /= (Context nullPtr)) $ fail "GLX already initialized" disp <- openDisplay "" + delwnd <- internAtom disp "WM_DELETE_WINDOW" False fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp) [(renderType, rgbaBit) , (drawableType, windowBit) @@ -46,7 +61,11 @@ instance Driver GLX where 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 waitForMapNotify disp wnd @@ -54,11 +73,52 @@ instance Driver GLX where ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True makeCurrent disp wnd ctx - return (GLX True) - - deinitGL _ = return () + return GLX + { glxDisplay = disp + , glxWindow = wnd + , glxContext = ctx + , glxDeleteWindow = delwnd + } + + deinitGL glx = do + destroyWindow (glxDisplay glx) (glxWindow glx) + destroyContext (glxDisplay glx) (glxContext glx) - nextEvent _ = return Nothing + nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx + + +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 () diff --git a/HTanks.hs b/HTanks.hs index 1ca97c2..7f611f5 100644 --- a/HTanks.hs +++ b/HTanks.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternGuards #-} + import Game import Level import Tank @@ -16,8 +18,9 @@ main = do let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]} - (_, gameState) <- runGame gameState $ mainLoop gl - print $ tanks gameState + runGame gameState $ mainLoop gl + + deinitGL gl mainLoop :: Driver a => a -> Game () mainLoop gl = do @@ -35,4 +38,6 @@ handleEvents gl = do return True handleEvent :: SomeEvent -> IO Bool -handleEvent ev = return True \ No newline at end of file +handleEvent ev + | Just QuitEvent <- fromEvent ev = return False + | otherwise = return True -- cgit v1.2.3