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

Added buffer swap and some other things to the GLX backend and main loop

Browse source
This commit is contained in:
Matthias Schiffer 2010-02-23 15:05:31 +01:00
parent f10352a0f1
commit 9772130708
6 changed files with 186 additions and 99 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
Bindings/GLX.chs
View file

@ -2,6 +2,7 @@
module Bindings.GLX ( createColormap module Bindings.GLX ( createColormap
, createWindow , createWindow
, setClassHint
, chooseFBConfig , chooseFBConfig
, getVisualFromFBConfig , getVisualFromFBConfig
, VisualInfo(..) , VisualInfo(..)
@ -18,28 +19,33 @@ module Bindings.GLX ( createColormap
, createContext , createContext
, makeCurrent , makeCurrent
, destroyContext , destroyContext
, swapBuffers
, Context(..) , Context(..)
, Drawable
) where ) where
import Data.Generics import Data.Generics
import Data.Int import Data.Int
import Data.Word import Data.Word
import Foreign.C.String (withCString)
import Foreign.C.Types import Foreign.C.Types
import Foreign.ForeignPtr import Foreign.ForeignPtr
import Foreign.Ptr import Foreign.Ptr
import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Marshal.Array (peekArray, withArray0) import Foreign.Marshal.Array (peekArray, withArray0)
import Foreign.Storable import Foreign.Storable
import Graphics.X11.Types (AttributeMask, Colormap, ColormapAlloc, Cursor, EventMask, Pixmap, Window, WindowClass, VisualID, XID) 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) import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
#include <GL/glx.h> #include <GL/glx.h>
type Drawable = XID
newtype FBConfig = FBConfig (Ptr FBConfig) newtype FBConfig = FBConfig (Ptr FBConfig)
deriving (Eq, Ord, Show, Typeable, Data, Storable) deriving (Eq, Ord, Show, Typeable, Data, Storable)
@ -189,6 +195,16 @@ foreign import ccall unsafe "GL/glx.h XCreateWindow"
Dimension -> Dimension -> CInt -> CInt -> WindowClass -> Dimension -> Dimension -> CInt -> CInt -> WindowClass ->
Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window 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" 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 createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context
foreign import ccall unsafe "GL/glx.h glXMakeCurrent" 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" foreign import ccall unsafe "GL/glx.h glXDestroyContext"
destroyContext :: Display -> Context -> IO () destroyContext :: Display -> Context -> IO ()
foreign import ccall unsafe "GL/glx.h glXSwapBuffers"
swapBuffers :: Display -> Drawable -> IO ()

188
Bindings/GLX.hs
View file

@ -5,6 +5,7 @@
module Bindings.GLX ( createColormap module Bindings.GLX ( createColormap
, createWindow , createWindow
, setClassHint
, chooseFBConfig , chooseFBConfig
, getVisualFromFBConfig , getVisualFromFBConfig
, VisualInfo(..) , VisualInfo(..)
@ -21,29 +22,34 @@ module Bindings.GLX ( createColormap
, createContext , createContext
, makeCurrent , makeCurrent
, destroyContext , destroyContext
, swapBuffers
, Context(..) , Context(..)
, Drawable
) where ) where
import Data.Generics import Data.Generics
import Data.Int import Data.Int
import Data.Word import Data.Word
import Foreign.C.String (withCString)
import Foreign.C.Types import Foreign.C.Types
import Foreign.ForeignPtr import Foreign.ForeignPtr
import Foreign.Ptr import Foreign.Ptr
import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Marshal.Array (peekArray, withArray0) import Foreign.Marshal.Array (peekArray, withArray0)
import Foreign.Storable import Foreign.Storable
import Graphics.X11.Types (AttributeMask, Colormap, ColormapAlloc, Cursor, EventMask, Pixmap, Window, WindowClass, VisualID, XID) 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) 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) newtype FBConfig = FBConfig (Ptr FBConfig)
deriving (Eq, Ord, Show, Typeable, Data, Storable) deriving (Eq, Ord, Show, Typeable, Data, Storable)
@ -68,55 +74,55 @@ data VisualInfo = VisualInfo
instance Storable VisualInfo where instance Storable VisualInfo where
sizeOf _ = ((40)) sizeOf _ = ((40))
{-# LINE 67 "GLX.chs" #-} {-# LINE 73 "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 71 "GLX.chs" #-}
visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
{-# LINE 72 "GLX.chs" #-}
screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi
{-# LINE 73 "GLX.chs" #-}
depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi
{-# LINE 74 "GLX.chs" #-}
viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi
{-# LINE 75 "GLX.chs" #-}
red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi
{-# LINE 76 "GLX.chs" #-}
green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi
{-# LINE 77 "GLX.chs" #-} {-# LINE 77 "GLX.chs" #-}
blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
{-# LINE 78 "GLX.chs" #-} {-# LINE 78 "GLX.chs" #-}
colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi
{-# LINE 79 "GLX.chs" #-} {-# LINE 79 "GLX.chs" #-}
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi
{-# LINE 80 "GLX.chs" #-} {-# LINE 80 "GLX.chs" #-}
viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi
{-# LINE 81 "GLX.chs" #-}
red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi
{-# LINE 82 "GLX.chs" #-}
green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi
{-# LINE 83 "GLX.chs" #-}
blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi
{-# LINE 84 "GLX.chs" #-}
colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi
{-# LINE 85 "GLX.chs" #-}
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi
{-# LINE 86 "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 86 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
{-# LINE 87 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen
{-# LINE 88 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth
{-# LINE 89 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass
{-# LINE 90 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask
{-# LINE 91 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask
{-# LINE 92 "GLX.chs" #-} {-# LINE 92 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
{-# LINE 93 "GLX.chs" #-} {-# LINE 93 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen
{-# LINE 94 "GLX.chs" #-} {-# LINE 94 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth
{-# LINE 95 "GLX.chs" #-} {-# LINE 95 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass
{-# LINE 96 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask
{-# LINE 97 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask
{-# LINE 98 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask
{-# LINE 99 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size
{-# LINE 100 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb
{-# LINE 101 "GLX.chs" #-}
data SetWindowAttributes = SetWindowAttributes data SetWindowAttributes = SetWindowAttributes
@ -138,38 +144,38 @@ data SetWindowAttributes = SetWindowAttributes
instance Storable SetWindowAttributes where instance Storable SetWindowAttributes where
sizeOf _ = ((60)) sizeOf _ = ((60))
{-# LINE 116 "GLX.chs" #-} {-# LINE 122 "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 120 "GLX.chs" #-}
background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
{-# LINE 121 "GLX.chs" #-}
border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa
{-# LINE 122 "GLX.chs" #-}
bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa
{-# LINE 123 "GLX.chs" #-}
win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa
{-# LINE 124 "GLX.chs" #-}
backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa
{-# LINE 125 "GLX.chs" #-}
backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa
{-# LINE 126 "GLX.chs" #-} {-# LINE 126 "GLX.chs" #-}
backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
{-# LINE 127 "GLX.chs" #-} {-# LINE 127 "GLX.chs" #-}
save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa
{-# LINE 128 "GLX.chs" #-} {-# LINE 128 "GLX.chs" #-}
event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa
{-# LINE 129 "GLX.chs" #-} {-# LINE 129 "GLX.chs" #-}
do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa
{-# LINE 130 "GLX.chs" #-} {-# LINE 130 "GLX.chs" #-}
override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa
{-# LINE 131 "GLX.chs" #-} {-# LINE 131 "GLX.chs" #-}
colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa
{-# LINE 132 "GLX.chs" #-} {-# LINE 132 "GLX.chs" #-}
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa
{-# LINE 133 "GLX.chs" #-} {-# LINE 133 "GLX.chs" #-}
save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa
{-# LINE 134 "GLX.chs" #-}
event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa
{-# LINE 135 "GLX.chs" #-}
do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa
{-# LINE 136 "GLX.chs" #-}
override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa
{-# LINE 137 "GLX.chs" #-}
colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa
{-# LINE 138 "GLX.chs" #-}
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
{-# LINE 139 "GLX.chs" #-}
return (SetWindowAttributes return (SetWindowAttributes
background_pixmap background_pixmap
@ -203,33 +209,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 166 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
{-# LINE 167 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap
{-# LINE 168 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity
{-# LINE 169 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity
{-# LINE 170 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store
{-# LINE 171 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes
{-# LINE 172 "GLX.chs" #-} {-# LINE 172 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
{-# LINE 173 "GLX.chs" #-} {-# LINE 173 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap
{-# LINE 174 "GLX.chs" #-} {-# LINE 174 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity
{-# LINE 175 "GLX.chs" #-} {-# LINE 175 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity
{-# LINE 176 "GLX.chs" #-} {-# LINE 176 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store
{-# LINE 177 "GLX.chs" #-} {-# LINE 177 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes
{-# LINE 178 "GLX.chs" #-} {-# LINE 178 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel
{-# LINE 179 "GLX.chs" #-} {-# LINE 179 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under
{-# LINE 180 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask
{-# LINE 181 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask
{-# LINE 182 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect
{-# LINE 183 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap
{-# LINE 184 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor
{-# LINE 185 "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)
@ -243,6 +249,19 @@ foreign import ccall unsafe "GL/glx.h XCreateWindow"
Dimension -> Dimension -> CInt -> CInt -> WindowClass -> Dimension -> Dimension -> CInt -> CInt -> WindowClass ->
Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window 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" 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 :: CInt
renderType = (32785) renderType = (32785)
{-# LINE 208 "GLX.chs" #-} {-# LINE 224 "GLX.chs" #-}
rgbaBit :: CInt rgbaBit :: CInt
rgbaBit = (1) rgbaBit = (1)
{-# LINE 211 "GLX.chs" #-} {-# LINE 227 "GLX.chs" #-}
drawableType :: CInt drawableType :: CInt
drawableType = (32784) drawableType = (32784)
{-# LINE 214 "GLX.chs" #-} {-# LINE 230 "GLX.chs" #-}
windowBit :: CInt windowBit :: CInt
windowBit = (1) windowBit = (1)
{-# LINE 217 "GLX.chs" #-} {-# LINE 233 "GLX.chs" #-}
xRenderable :: CInt xRenderable :: CInt
xRenderable = (32786) xRenderable = (32786)
{-# LINE 220 "GLX.chs" #-} {-# LINE 236 "GLX.chs" #-}
doublebuffer :: CInt doublebuffer :: CInt
doublebuffer = (5) doublebuffer = (5)
{-# LINE 223 "GLX.chs" #-} {-# LINE 239 "GLX.chs" #-}
depthSize :: CInt depthSize :: CInt
depthSize = (12) depthSize = (12)
{-# LINE 226 "GLX.chs" #-} {-# LINE 242 "GLX.chs" #-}
stencilSize :: CInt stencilSize :: CInt
stencilSize = (13) stencilSize = (13)
{-# LINE 229 "GLX.chs" #-} {-# LINE 245 "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,7 +322,10 @@ foreign import ccall unsafe "GL/glx.h glXCreateContext"
createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context
foreign import ccall unsafe "GL/glx.h glXMakeCurrent" 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" foreign import ccall unsafe "GL/glx.h glXDestroyContext"
destroyContext :: Display -> Context -> IO () destroyContext :: Display -> Context -> IO ()
foreign import ccall unsafe "GL/glx.h glXSwapBuffers"
swapBuffers :: Display -> Drawable -> IO ()

2
GLDriver.hs
View file

@ -16,6 +16,8 @@ class Driver a where
initGL :: a -> IO a initGL :: a -> IO a
deinitGL :: a -> IO () deinitGL :: a -> IO ()
swapBuffers :: a -> IO ()
nextEvent :: a -> IO (Maybe SomeEvent) nextEvent :: a -> IO (Maybe SomeEvent)

15
GLX.hs
View file

@ -13,10 +13,10 @@ import Graphics.X11.Types
import Graphics.X11.Xlib.Atom (internAtom) 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 (XEventPtr, allocaXEvent, nextEvent, get_Window, get_EventType, pending) 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.Misc (keycodeToKeysym, setWMProtocols)
import Graphics.X11.Xlib.Types 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.Marshal.Utils (with)
import Foreign.Ptr import Foreign.Ptr
@ -41,10 +41,10 @@ glxDriver = GLX
instance Driver GLX where instance Driver GLX where
initialized glx = ((glxContext glx) == (Context nullPtr)) initialized glx = ((glxContext glx) /= (Context nullPtr))
initGL glx = do initGL glx = do
when ((glxContext glx) /= (Context nullPtr)) $ fail "GLX already initialized" when (initialized glx) $ fail "GLX already initialized"
disp <- openDisplay "" disp <- openDisplay ""
delwnd <- internAtom disp "WM_DELETE_WINDOW" False delwnd <- internAtom disp "WM_DELETE_WINDOW" False
@ -64,8 +64,11 @@ instance Driver GLX where
wnd <- with swa $ \swaptr -> wnd <- with swa $ \swaptr ->
createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) 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] setWMProtocols disp wnd [delwnd]
storeName disp wnd "HTanks"
mapWindow disp wnd mapWindow disp wnd
waitForMapNotify disp wnd waitForMapNotify disp wnd
@ -84,6 +87,8 @@ instance Driver GLX where
destroyWindow (glxDisplay glx) (glxWindow glx) destroyWindow (glxDisplay glx) (glxWindow glx)
destroyContext (glxDisplay glx) (glxContext glx) destroyContext (glxDisplay glx) (glxContext glx)
swapBuffers glx = Bindings.GLX.swapBuffers (glxDisplay glx) (glxWindow glx)
nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx

39
HTanks.hs
View file

@ -2,6 +2,7 @@
import Game import Game
import Level import Level
import Render
import Tank import Tank
import GLDriver import GLDriver
@ -10,6 +11,7 @@ import GLX
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Monad.State import Control.Monad.State
import Data.Maybe import Data.Maybe
import System.Time
main :: IO () main :: IO ()
@ -18,16 +20,39 @@ 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]}
runGame gameState $ mainLoop gl when (initialized gl) $ do
time <- getClockTime
deinitGL gl runGame gameState $ mainLoop gl time
deinitGL gl
mainLoop :: Driver a => a -> Game () minFrameTime :: Integer
mainLoop gl = do minFrameTime = 10000
mainLoop :: Driver a => a -> ClockTime -> Game ()
mainLoop gl time = do
run <- liftIO $ handleEvents gl 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 :: Driver a => a -> IO Bool
handleEvents gl = do handleEvents gl = do
event <- nextEvent gl event <- nextEvent gl

14
Render.hs Normal file
View file

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