Handle quit events

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