diff options
| -rw-r--r-- | Bindings/GLX.chs | 27 | ||||
| -rw-r--r-- | Bindings/GLX.hs | 148 | ||||
| -rw-r--r-- | GLDriver.hs | 2 | ||||
| -rw-r--r-- | GLX.hs | 15 | ||||
| -rw-r--r-- | HTanks.hs | 39 | ||||
| -rw-r--r-- | Render.hs | 14 |
6 files changed, 166 insertions, 79 deletions
diff --git a/Bindings/GLX.chs b/Bindings/GLX.chs index 37669f3..0f31106 100644 --- a/Bindings/GLX.chs +++ b/Bindings/GLX.chs @@ -2,6 +2,7 @@ module Bindings.GLX ( createColormap , createWindow + , setClassHint , chooseFBConfig , getVisualFromFBConfig , VisualInfo(..) @@ -18,28 +19,33 @@ module Bindings.GLX ( createColormap , createContext , makeCurrent , destroyContext + , swapBuffers , Context(..) + , Drawable ) where import Data.Generics import Data.Int import Data.Word +import Foreign.C.String (withCString) import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Ptr -import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Alloc (alloca, allocaBytes) import Foreign.Marshal.Array (peekArray, withArray0) import Foreign.Storable import Graphics.X11.Types (AttributeMask, Colormap, ColormapAlloc, Cursor, EventMask, Pixmap, Window, WindowClass, VisualID, XID) -import Graphics.X11.Xlib.Extras (none, xFree) +import Graphics.X11.Xlib.Extras (none, xFree, ClassHint, resName, resClass, TextProperty) import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position) #include <GL/glx.h> +type Drawable = XID + newtype FBConfig = FBConfig (Ptr FBConfig) deriving (Eq, Ord, Show, Typeable, Data, Storable) @@ -189,6 +195,16 @@ foreign import ccall unsafe "GL/glx.h XCreateWindow" Dimension -> Dimension -> CInt -> CInt -> WindowClass -> Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window +foreign import ccall unsafe "GL/glx.h XSetClassHint" + xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO () + +setClassHint :: Display -> Window -> ClassHint -> IO () +setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p -> + withCString (resName hint) $ \res_name -> + withCString (resClass hint) $ \res_class -> do + (#poke XClassHint, res_name) p res_name + (#poke XClassHint, res_class) p res_class + xSetClassHint disp wnd p foreign import ccall unsafe "GL/glx.h glXChooseFBConfig" @@ -241,7 +257,10 @@ foreign import ccall unsafe "GL/glx.h glXCreateContext" createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context foreign import ccall unsafe "GL/glx.h glXMakeCurrent" - makeCurrent :: Display -> XID -> Context -> IO Bool + makeCurrent :: Display -> Drawable -> Context -> IO Bool foreign import ccall unsafe "GL/glx.h glXDestroyContext" - destroyContext :: Display -> Context -> IO ()
\ No newline at end of file + destroyContext :: Display -> Context -> IO () + +foreign import ccall unsafe "GL/glx.h glXSwapBuffers" + swapBuffers :: Display -> Drawable -> IO () diff --git a/Bindings/GLX.hs b/Bindings/GLX.hs index 78fe0e3..4f364e4 100644 --- a/Bindings/GLX.hs +++ b/Bindings/GLX.hs @@ -5,6 +5,7 @@ module Bindings.GLX ( createColormap , createWindow + , setClassHint , chooseFBConfig , getVisualFromFBConfig , VisualInfo(..) @@ -21,29 +22,34 @@ module Bindings.GLX ( createColormap , createContext , makeCurrent , destroyContext + , swapBuffers , Context(..) + , Drawable ) where import Data.Generics import Data.Int import Data.Word +import Foreign.C.String (withCString) import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Ptr -import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Alloc (alloca, allocaBytes) import Foreign.Marshal.Array (peekArray, withArray0) import Foreign.Storable import Graphics.X11.Types (AttributeMask, Colormap, ColormapAlloc, Cursor, EventMask, Pixmap, Window, WindowClass, VisualID, XID) -import Graphics.X11.Xlib.Extras (none, xFree) +import Graphics.X11.Xlib.Extras (none, xFree, ClassHint, resName, resClass, TextProperty) import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position) -{-# LINE 41 "GLX.chs" #-} +{-# LINE 45 "GLX.chs" #-} +type Drawable = XID + newtype FBConfig = FBConfig (Ptr FBConfig) deriving (Eq, Ord, Show, Typeable, Data, Storable) @@ -68,55 +74,55 @@ data VisualInfo = VisualInfo instance Storable VisualInfo where sizeOf _ = ((40)) -{-# LINE 67 "GLX.chs" #-} +{-# LINE 73 "GLX.chs" #-} alignment _ = alignment (undefined :: CULong) peek vi = do visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi -{-# LINE 71 "GLX.chs" #-} +{-# LINE 77 "GLX.chs" #-} visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi -{-# LINE 72 "GLX.chs" #-} +{-# LINE 78 "GLX.chs" #-} screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi -{-# LINE 73 "GLX.chs" #-} +{-# LINE 79 "GLX.chs" #-} depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi -{-# LINE 74 "GLX.chs" #-} +{-# LINE 80 "GLX.chs" #-} viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi -{-# LINE 75 "GLX.chs" #-} +{-# LINE 81 "GLX.chs" #-} red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi -{-# LINE 76 "GLX.chs" #-} +{-# LINE 82 "GLX.chs" #-} green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi -{-# LINE 77 "GLX.chs" #-} +{-# LINE 83 "GLX.chs" #-} blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi -{-# LINE 78 "GLX.chs" #-} +{-# LINE 84 "GLX.chs" #-} colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi -{-# LINE 79 "GLX.chs" #-} +{-# LINE 85 "GLX.chs" #-} bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi -{-# LINE 80 "GLX.chs" #-} +{-# LINE 86 "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 86 "GLX.chs" #-} +{-# LINE 92 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid -{-# LINE 87 "GLX.chs" #-} +{-# LINE 93 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen -{-# LINE 88 "GLX.chs" #-} +{-# LINE 94 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth -{-# LINE 89 "GLX.chs" #-} +{-# LINE 95 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass -{-# LINE 90 "GLX.chs" #-} +{-# LINE 96 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask -{-# LINE 91 "GLX.chs" #-} +{-# LINE 97 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask -{-# LINE 92 "GLX.chs" #-} +{-# LINE 98 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask -{-# LINE 93 "GLX.chs" #-} +{-# LINE 99 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size -{-# LINE 94 "GLX.chs" #-} +{-# LINE 100 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb -{-# LINE 95 "GLX.chs" #-} +{-# LINE 101 "GLX.chs" #-} data SetWindowAttributes = SetWindowAttributes @@ -138,38 +144,38 @@ data SetWindowAttributes = SetWindowAttributes instance Storable SetWindowAttributes where sizeOf _ = ((60)) -{-# LINE 116 "GLX.chs" #-} +{-# LINE 122 "GLX.chs" #-} alignment _ = alignment (undefined :: CULong) peek swa = do background_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) swa -{-# LINE 120 "GLX.chs" #-} +{-# LINE 126 "GLX.chs" #-} background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa -{-# LINE 121 "GLX.chs" #-} +{-# LINE 127 "GLX.chs" #-} border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa -{-# LINE 122 "GLX.chs" #-} +{-# LINE 128 "GLX.chs" #-} bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa -{-# LINE 123 "GLX.chs" #-} +{-# LINE 129 "GLX.chs" #-} win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa -{-# LINE 124 "GLX.chs" #-} +{-# LINE 130 "GLX.chs" #-} backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa -{-# LINE 125 "GLX.chs" #-} +{-# LINE 131 "GLX.chs" #-} backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa -{-# LINE 126 "GLX.chs" #-} +{-# LINE 132 "GLX.chs" #-} backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa -{-# LINE 127 "GLX.chs" #-} +{-# LINE 133 "GLX.chs" #-} save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa -{-# LINE 128 "GLX.chs" #-} +{-# LINE 134 "GLX.chs" #-} event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa -{-# LINE 129 "GLX.chs" #-} +{-# LINE 135 "GLX.chs" #-} do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa -{-# LINE 130 "GLX.chs" #-} +{-# LINE 136 "GLX.chs" #-} override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa -{-# LINE 131 "GLX.chs" #-} +{-# LINE 137 "GLX.chs" #-} colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa -{-# LINE 132 "GLX.chs" #-} +{-# LINE 138 "GLX.chs" #-} cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa -{-# LINE 133 "GLX.chs" #-} +{-# LINE 139 "GLX.chs" #-} return (SetWindowAttributes background_pixmap @@ -203,33 +209,33 @@ instance Storable SetWindowAttributes where colormap cursor) = do ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) swa background_pixmap -{-# LINE 166 "GLX.chs" #-} +{-# LINE 172 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel -{-# LINE 167 "GLX.chs" #-} +{-# LINE 173 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap -{-# LINE 168 "GLX.chs" #-} +{-# LINE 174 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity -{-# LINE 169 "GLX.chs" #-} +{-# LINE 175 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity -{-# LINE 170 "GLX.chs" #-} +{-# LINE 176 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store -{-# LINE 171 "GLX.chs" #-} +{-# LINE 177 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes -{-# LINE 172 "GLX.chs" #-} +{-# LINE 178 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel -{-# LINE 173 "GLX.chs" #-} +{-# LINE 179 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under -{-# LINE 174 "GLX.chs" #-} +{-# LINE 180 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask -{-# LINE 175 "GLX.chs" #-} +{-# LINE 181 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask -{-# LINE 176 "GLX.chs" #-} +{-# LINE 182 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect -{-# LINE 177 "GLX.chs" #-} +{-# LINE 183 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap -{-# LINE 178 "GLX.chs" #-} +{-# LINE 184 "GLX.chs" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor -{-# LINE 179 "GLX.chs" #-} +{-# LINE 185 "GLX.chs" #-} nullSetWindowAttributes :: SetWindowAttributes nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0) @@ -243,6 +249,19 @@ foreign import ccall unsafe "GL/glx.h XCreateWindow" Dimension -> Dimension -> CInt -> CInt -> WindowClass -> Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window +foreign import ccall unsafe "GL/glx.h XSetClassHint" + xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO () + +setClassHint :: Display -> Window -> ClassHint -> IO () +setClassHint disp wnd hint = allocaBytes ((8)) $ \p -> +{-# LINE 203 "GLX.chs" #-} + withCString (resName hint) $ \res_name -> + withCString (resClass hint) $ \res_class -> do + ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p res_name +{-# LINE 206 "GLX.chs" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p res_class +{-# LINE 207 "GLX.chs" #-} + xSetClassHint disp wnd p foreign import ccall unsafe "GL/glx.h glXChooseFBConfig" @@ -259,35 +278,35 @@ chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (con renderType :: CInt renderType = (32785) -{-# LINE 208 "GLX.chs" #-} +{-# LINE 224 "GLX.chs" #-} rgbaBit :: CInt rgbaBit = (1) -{-# LINE 211 "GLX.chs" #-} +{-# LINE 227 "GLX.chs" #-} drawableType :: CInt drawableType = (32784) -{-# LINE 214 "GLX.chs" #-} +{-# LINE 230 "GLX.chs" #-} windowBit :: CInt windowBit = (1) -{-# LINE 217 "GLX.chs" #-} +{-# LINE 233 "GLX.chs" #-} xRenderable :: CInt xRenderable = (32786) -{-# LINE 220 "GLX.chs" #-} +{-# LINE 236 "GLX.chs" #-} doublebuffer :: CInt doublebuffer = (5) -{-# LINE 223 "GLX.chs" #-} +{-# LINE 239 "GLX.chs" #-} depthSize :: CInt depthSize = (12) -{-# LINE 226 "GLX.chs" #-} +{-# LINE 242 "GLX.chs" #-} stencilSize :: CInt stencilSize = (13) -{-# LINE 229 "GLX.chs" #-} +{-# LINE 245 "GLX.chs" #-} foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig" glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo) @@ -303,7 +322,10 @@ foreign import ccall unsafe "GL/glx.h glXCreateContext" createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context foreign import ccall unsafe "GL/glx.h glXMakeCurrent" - makeCurrent :: Display -> XID -> Context -> IO Bool + makeCurrent :: Display -> Drawable -> Context -> IO Bool foreign import ccall unsafe "GL/glx.h glXDestroyContext" - destroyContext :: Display -> Context -> IO ()
\ No newline at end of file + destroyContext :: Display -> Context -> IO () + +foreign import ccall unsafe "GL/glx.h glXSwapBuffers" + swapBuffers :: Display -> Drawable -> IO () diff --git a/GLDriver.hs b/GLDriver.hs index 74c02e2..bc55720 100644 --- a/GLDriver.hs +++ b/GLDriver.hs @@ -16,6 +16,8 @@ class Driver a where initGL :: a -> IO a deinitGL :: a -> IO () + swapBuffers :: a -> IO () + nextEvent :: a -> IO (Maybe SomeEvent) @@ -13,10 +13,10 @@ import Graphics.X11.Types import Graphics.X11.Xlib.Atom (internAtom) import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow) 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.Extras (ClassHint(..), 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 (destroyWindow, mapWindow) +import Graphics.X11.Xlib.Window (destroyWindow, mapWindow, storeName) import Foreign.Marshal.Utils (with) import Foreign.Ptr @@ -41,10 +41,10 @@ glxDriver = GLX instance Driver GLX where - initialized glx = ((glxContext glx) == (Context nullPtr)) + initialized glx = ((glxContext glx) /= (Context nullPtr)) initGL glx = do - when ((glxContext glx) /= (Context nullPtr)) $ fail "GLX already initialized" + when (initialized glx) $ fail "GLX already initialized" disp <- openDisplay "" delwnd <- internAtom disp "WM_DELETE_WINDOW" False @@ -64,8 +64,11 @@ instance Driver GLX where wnd <- with swa $ \swaptr -> createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr + setClassHint disp wnd (ClassHint "HTanks" "htanks") setWMProtocols disp wnd [delwnd] - + + storeName disp wnd "HTanks" + mapWindow disp wnd waitForMapNotify disp wnd @@ -84,6 +87,8 @@ instance Driver GLX where destroyWindow (glxDisplay glx) (glxWindow glx) destroyContext (glxDisplay glx) (glxContext glx) + swapBuffers glx = Bindings.GLX.swapBuffers (glxDisplay glx) (glxWindow glx) + nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx @@ -2,6 +2,7 @@ import Game import Level +import Render import Tank import GLDriver @@ -10,6 +11,7 @@ import GLX import Control.Concurrent (threadDelay) import Control.Monad.State import Data.Maybe +import System.Time main :: IO () @@ -18,16 +20,39 @@ main = do let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]} - runGame gameState $ mainLoop gl - - deinitGL gl + when (initialized gl) $ do + time <- getClockTime + runGame gameState $ mainLoop gl time + + deinitGL gl + +minFrameTime :: Integer +minFrameTime = 10000 -mainLoop :: Driver a => a -> Game () -mainLoop gl = do +mainLoop :: Driver a => a -> ClockTime -> Game () +mainLoop gl time = do run <- liftIO $ handleEvents gl - liftIO $ threadDelay 10000 - when run $ mainLoop gl + render + + liftIO $ swapBuffers gl + + newTime <- liftIO getClockTime + let td = timeDiff newTime time + when (td < minFrameTime) $ + liftIO $ threadDelay $ fromIntegral (minFrameTime - td) + + newTime <- liftIO getClockTime + + liftIO $ print $ timeDiff newTime time + + when run $ mainLoop gl newTime + + +timeDiff :: ClockTime -> ClockTime -> Integer +timeDiff (TOD s1 ps1) (TOD s2 ps2) = (s1-s2)*1000000 + (ps1-ps2)`div`1000000 + + handleEvents :: Driver a => a -> IO Bool handleEvents gl = do event <- nextEvent gl diff --git a/Render.hs b/Render.hs new file mode 100644 index 0000000..d871678 --- /dev/null +++ b/Render.hs @@ -0,0 +1,14 @@ +module Render ( render + ) where + + +import Game + +import Control.Monad.State +import Graphics.Rendering.OpenGL.GL.Framebuffer (clear, ClearBuffer(..)) + + +render :: Game () +render = do + liftIO $ clear [ColorBuffer] +
\ No newline at end of file |