diff options
author | Matthias Schiffer <matthias@gamezock.de> | 2010-02-25 04:49:30 +0100 |
---|---|---|
committer | Matthias Schiffer <matthias@gamezock.de> | 2010-02-25 04:49:30 +0100 |
commit | 9ca9555fede912e5a3c9cebaa2050bb2c7cc7b1c (patch) | |
tree | db35235d4d497aa694bcadddedcbcee7e01a5c55 /Bindings/GLX.chs | |
parent | b4f295da9183d442b87396f07284b7624b90892e (diff) | |
download | htanks-9ca9555fede912e5a3c9cebaa2050bb2c7cc7b1c.tar htanks-9ca9555fede912e5a3c9cebaa2050bb2c7cc7b1c.zip |
Renamed some files and added Makefile
Diffstat (limited to 'Bindings/GLX.chs')
-rw-r--r-- | Bindings/GLX.chs | 265 |
1 files changed, 0 insertions, 265 deletions
diff --git a/Bindings/GLX.chs b/Bindings/GLX.chs deleted file mode 100644 index d5fed4d..0000000 --- a/Bindings/GLX.chs +++ /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 () |