summaryrefslogtreecommitdiffstats
path: root/Bindings/GLX.hsc
diff options
context:
space:
mode:
authorMatthias Schiffer <matthias@gamezock.de>2010-03-09 03:49:15 +0100
committerMatthias Schiffer <matthias@gamezock.de>2010-03-09 03:49:15 +0100
commit7327695ca3d9aee5da1d0bc98572d877dd8c8546 (patch)
treee733714968ae0a041f76b213ffe31cca70ada6fb /Bindings/GLX.hsc
parent2bb85618366681c7c97f8b36cc85a18c45beb924 (diff)
downloadhtanks-7327695ca3d9aee5da1d0bc98572d877dd8c8546.tar
htanks-7327695ca3d9aee5da1d0bc98572d877dd8c8546.zip
Moved source files to src directory
Diffstat (limited to 'Bindings/GLX.hsc')
-rw-r--r--Bindings/GLX.hsc265
1 files changed, 0 insertions, 265 deletions
diff --git a/Bindings/GLX.hsc b/Bindings/GLX.hsc
deleted file mode 100644
index d5fed4d..0000000
--- a/Bindings/GLX.hsc
+++ /dev/null
@@ -1,265 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-
-module Bindings.GLX ( createColormap
- , createWindow
- , setClassHint
- , chooseFBConfig
- , getVisualFromFBConfig
- , VisualInfo(..)
- , SetWindowAttributes(..)
- , nullSetWindowAttributes
- , renderType
- , rgbaBit
- , drawableType
- , windowBit
- , xRenderable
- , doublebuffer
- , depthSize
- , stencilSize
- , 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.Ptr
-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, 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)
-
-newtype Context = Context (Ptr Context)
- deriving (Eq, Ord, Show, Typeable, Data, Storable)
-
-newtype Visual = Visual (Ptr Visual)
- deriving (Eq, Ord, Show, Typeable, Data, Storable)
-
-data VisualInfo = VisualInfo
- { viVisual :: !Visual
- , viVisualid :: !VisualID
- , viScreen :: !CInt
- , viDepth :: !CInt
- , viClass :: !CInt
- , viRedMask :: !CULong
- , viGreenMask :: !CULong
- , viBlueMask :: !CULong
- , viColormapSize :: !CInt
- , viBitsPerRgb :: !CInt
- } deriving (Eq, Ord, Show, Typeable)
-
-instance Storable VisualInfo where
- sizeOf _ = (#size XVisualInfo)
- alignment _ = alignment (undefined :: CULong)
-
- peek vi = do
- visual <- (#peek XVisualInfo, visual) vi
- visualid <- (#peek XVisualInfo, visualid) vi
- screen <- (#peek XVisualInfo, screen) vi
- depth <- (#peek XVisualInfo, depth) vi
- viclass <- (#peek XVisualInfo, class) vi
- red_mask <- (#peek XVisualInfo, red_mask) vi
- green_mask <- (#peek XVisualInfo, green_mask) vi
- blue_mask <- (#peek XVisualInfo, blue_mask) vi
- colormap_size <- (#peek XVisualInfo, colormap_size) vi
- bits_per_rgb <- (#peek XVisualInfo, bits_per_rgb) vi
-
- 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 XVisualInfo, visual) vi visual
- (#poke XVisualInfo, visualid) vi visualid
- (#poke XVisualInfo, screen) vi screen
- (#poke XVisualInfo, depth) vi depth
- (#poke XVisualInfo, class) vi viclass
- (#poke XVisualInfo, red_mask) vi red_mask
- (#poke XVisualInfo, green_mask) vi green_mask
- (#poke XVisualInfo, blue_mask) vi blue_mask
- (#poke XVisualInfo, colormap_size) vi colormap_size
- (#poke XVisualInfo, bits_per_rgb) vi bits_per_rgb
-
-
-data SetWindowAttributes = SetWindowAttributes
- { swaBackgroundPixmap :: !Pixmap
- , swaBackgroundPixel :: !Pixel
- , swaBorderPixmap :: !Pixmap
- , swaBitGravity :: !CInt
- , swaWinGravity :: !CInt
- , swaBackingStore :: !CInt
- , swaBackingPlanes :: !CULong
- , swaBackingPixel :: !CULong
- , swaSaveUnder :: !Bool
- , swaEventMask :: !EventMask
- , swaDoNotPropagateMask :: !CULong
- , swaOverrideRedirect :: !Bool
- , swaColormap :: !Colormap
- , swaCursor :: !Cursor
- } deriving (Eq, Ord, Show, Typeable)
-
-instance Storable SetWindowAttributes where
- sizeOf _ = (#size XSetWindowAttributes)
- alignment _ = alignment (undefined :: CULong)
-
- peek swa = do
- background_pixmap <- (#peek XSetWindowAttributes, background_pixmap) swa
- background_pixel <- (#peek XSetWindowAttributes, background_pixel) swa
- border_pixmap <- (#peek XSetWindowAttributes, border_pixmap) swa
- bit_gravity <- (#peek XSetWindowAttributes, bit_gravity) swa
- win_gravity <- (#peek XSetWindowAttributes, win_gravity) swa
- backing_store <- (#peek XSetWindowAttributes, backing_store) swa
- backing_planes <- (#peek XSetWindowAttributes, backing_planes) swa
- backing_pixel <- (#peek XSetWindowAttributes, backing_pixel) swa
- save_under <- (#peek XSetWindowAttributes, save_under) swa
- event_mask <- (#peek XSetWindowAttributes, event_mask) swa
- do_not_propagate_mask <- (#peek XSetWindowAttributes, do_not_propagate_mask) swa
- override_redirect <- (#peek XSetWindowAttributes, override_redirect) swa
- colormap <- (#peek XSetWindowAttributes, colormap) swa
- cursor <- (#peek XSetWindowAttributes, cursor) swa
-
- return (SetWindowAttributes
- background_pixmap
- background_pixel
- border_pixmap
- bit_gravity
- win_gravity
- backing_store
- backing_planes
- backing_pixel
- save_under
- event_mask
- do_not_propagate_mask
- override_redirect
- colormap
- cursor)
-
- poke swa (SetWindowAttributes
- background_pixmap
- background_pixel
- border_pixmap
- bit_gravity
- win_gravity
- backing_store
- backing_planes
- backing_pixel
- save_under
- event_mask
- do_not_propagate_mask
- override_redirect
- colormap
- cursor) = do
- (#poke XSetWindowAttributes, background_pixmap) swa background_pixmap
- (#poke XSetWindowAttributes, background_pixel) swa background_pixel
- (#poke XSetWindowAttributes, border_pixmap) swa border_pixmap
- (#poke XSetWindowAttributes, bit_gravity) swa bit_gravity
- (#poke XSetWindowAttributes, win_gravity) swa win_gravity
- (#poke XSetWindowAttributes, backing_store) swa backing_store
- (#poke XSetWindowAttributes, backing_planes) swa backing_planes
- (#poke XSetWindowAttributes, backing_pixel) swa backing_pixel
- (#poke XSetWindowAttributes, save_under) swa save_under
- (#poke XSetWindowAttributes, event_mask) swa event_mask
- (#poke XSetWindowAttributes, do_not_propagate_mask) swa do_not_propagate_mask
- (#poke XSetWindowAttributes, override_redirect) swa override_redirect
- (#poke XSetWindowAttributes, colormap) swa colormap
- (#poke XSetWindowAttributes, cursor) swa cursor
-
-nullSetWindowAttributes :: SetWindowAttributes
-nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0)
-
-
-foreign import ccall unsafe "GL/glx.h XCreateColormap"
- createColormap :: Display -> Window -> Visual -> ColormapAlloc -> IO Colormap
-
-foreign import ccall unsafe "GL/glx.h XCreateWindow"
- createWindow :: Display -> Window -> Position -> Position ->
- 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"
- glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr FBConfig)
-
-chooseFBConfig :: Display -> CInt -> [(CInt, CInt)] -> IO [FBConfig]
-chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (concatMap (\(a,b) -> [a,b]) attr) $ \attrp -> do
- configs <- glXChooseFBConfig disp sc attrp n
- nelements <- peek n
- configlist <- peekArray (fromIntegral nelements) configs
- xFree configs
- return configlist
-
-
-renderType :: CInt
-renderType = (#const GLX_RENDER_TYPE)
-
-rgbaBit :: CInt
-rgbaBit = (#const GLX_RGBA_BIT)
-
-drawableType :: CInt
-drawableType = (#const GLX_DRAWABLE_TYPE)
-
-windowBit :: CInt
-windowBit = (#const GLX_WINDOW_BIT)
-
-xRenderable :: CInt
-xRenderable = (#const GLX_X_RENDERABLE)
-
-doublebuffer :: CInt
-doublebuffer = (#const GLX_DOUBLEBUFFER)
-
-depthSize :: CInt
-depthSize = (#const GLX_DEPTH_SIZE)
-
-stencilSize :: CInt
-stencilSize = (#const GLX_STENCIL_SIZE)
-
-foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
- glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo)
-
-getVisualFromFBConfig :: Display -> FBConfig -> IO (VisualInfo)
-getVisualFromFBConfig disp config = do
- viptr <- glXGetVisualFromFBConfig disp config
- vi <- peek viptr
- xFree viptr
- return vi
-
-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 -> Drawable -> Context -> IO Bool
-
-foreign import ccall unsafe "GL/glx.h glXDestroyContext"
- destroyContext :: Display -> Context -> IO ()
-
-foreign import ccall unsafe "GL/glx.h glXSwapBuffers"
- swapBuffers :: Display -> Drawable -> IO ()