From 9ca9555fede912e5a3c9cebaa2050bb2c7cc7b1c Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 25 Feb 2010 04:49:30 +0100 Subject: Renamed some files and added Makefile --- Bindings/GLPng.chs | 158 -------------------------------- Bindings/GLPng.hs | 58 ++++++------ Bindings/GLPng.hsc | 158 ++++++++++++++++++++++++++++++++ Bindings/GLX.chs | 265 ----------------------------------------------------- Bindings/GLX.hs | 128 +++++++++++++------------- Bindings/GLX.hsc | 265 +++++++++++++++++++++++++++++++++++++++++++++++++++++ Makefile | 7 ++ 7 files changed, 523 insertions(+), 516 deletions(-) delete mode 100644 Bindings/GLPng.chs create mode 100644 Bindings/GLPng.hsc delete mode 100644 Bindings/GLX.chs create mode 100644 Bindings/GLX.hsc create mode 100644 Makefile diff --git a/Bindings/GLPng.chs b/Bindings/GLPng.chs deleted file mode 100644 index 453bddc..0000000 --- a/Bindings/GLPng.chs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-} - -module Bindings.GLPng ( PngInfo(..) - , Mipmap(..) - , Trans (..) - , pngBind - ) where - -import Data.Generics - -import Foreign.C.String (CString, withCString) -import Foreign.C.Types -import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr -import Foreign.Storable - -import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clamping(..), TextureFilter(..), MinificationFilter, MagnificationFilter) - - -#include -#include - - -data PngInfo = PngInfo - { pngWidth :: !CUInt - , pngHeight :: !CUInt - , pngDepth :: !CUInt - , pngAlpha :: !CUInt - } deriving (Eq, Ord, Show, Typeable) - -instance Storable PngInfo where - sizeOf _ = (#size pngInfo) - alignment _ = alignment (undefined :: CUInt) - - peek pi = do - w <- (#peek pngInfo, Width) pi - h <- (#peek pngInfo, Height) pi - d <- (#peek pngInfo, Depth) pi - a <- (#peek pngInfo, Alpha) pi - - return (PngInfo w h d a) - - poke pi (PngInfo w h d a) = do - (#poke pngInfo, Width) pi w - (#poke pngInfo, Height) pi h - (#poke pngInfo, Depth) pi d - (#poke pngInfo, Alpha) pi a - - - - -png_NoMipmap :: CInt -png_NoMipmap = (#const PNG_NOMIPMAP) - -png_BuildMipmap :: CInt -png_BuildMipmap = (#const PNG_BUILDMIPMAP) - -png_SimpleMipmap :: CInt -png_SimpleMipmap = (#const PNG_SIMPLEMIPMAP) - - -data Mipmap = NoMipmap | BuildMipmap | SimpleMipmap - deriving (Eq, Show) - -marshalMipmap :: Mipmap -> CInt -marshalMipmap m - | m == NoMipmap = png_NoMipmap - | m == BuildMipmap = png_BuildMipmap - | m == SimpleMipmap = png_SimpleMipmap - - -png_Alpha :: CInt -png_Alpha = (#const PNG_ALPHA) - -png_Solid :: CInt -png_Solid = (#const PNG_SOLID) - -data Trans = Alpha | Solid - deriving (Eq, Show) - -marshalTrans :: Trans -> CInt -marshalTrans t - | t == Alpha = png_Alpha - | t == Solid = png_Solid - - -magToMin :: MagnificationFilter -> MinificationFilter -magToMin magFilter = (magFilter, Nothing) - - -gl_NEAREST :: CInt -gl_NEAREST = (#const GL_NEAREST) - -gl_LINEAR :: CInt -gl_LINEAR = (#const GL_LINEAR) - -gl_NEAREST_MIPMAP_NEAREST :: CInt -gl_NEAREST_MIPMAP_NEAREST = (#const GL_NEAREST_MIPMAP_NEAREST) - -gl_LINEAR_MIPMAP_NEAREST :: CInt -gl_LINEAR_MIPMAP_NEAREST = (#const GL_LINEAR_MIPMAP_NEAREST) - -gl_NEAREST_MIPMAP_LINEAR :: CInt -gl_NEAREST_MIPMAP_LINEAR = (#const GL_NEAREST_MIPMAP_LINEAR) - -gl_LINEAR_MIPMAP_LINEAR :: CInt -gl_LINEAR_MIPMAP_LINEAR = (#const GL_LINEAR_MIPMAP_LINEAR) - - -marshalMinificationFilter :: MinificationFilter -> CInt -marshalMinificationFilter x = fromIntegral $ case x of - (Nearest, Nothing ) -> gl_NEAREST - (Linear', Nothing ) -> gl_LINEAR - (Nearest, Just Nearest) -> gl_NEAREST_MIPMAP_NEAREST - (Linear', Just Nearest) -> gl_LINEAR_MIPMAP_NEAREST - (Nearest, Just Linear') -> gl_NEAREST_MIPMAP_LINEAR - (Linear', Just Linear') -> gl_LINEAR_MIPMAP_LINEAR - -marshalMagnificationFilter :: MagnificationFilter -> CInt -marshalMagnificationFilter = marshalMinificationFilter . magToMin - - -gl_CLAMP :: CInt -gl_CLAMP = (#const GL_CLAMP) - -gl_REPEAT :: CInt -gl_REPEAT = (#const GL_REPEAT) - -gl_CLAMP_TO_EDGE :: CInt -gl_CLAMP_TO_EDGE = (#const GL_CLAMP_TO_EDGE) - -gl_CLAMP_TO_BORDER :: CInt -gl_CLAMP_TO_BORDER = (#const GL_CLAMP_TO_BORDER) - -gl_MIRRORED_REPEAT :: CInt -gl_MIRRORED_REPEAT = (#const GL_MIRRORED_REPEAT) - - -marshalTextureWrapMode :: (Repetition, Clamping) -> CInt -marshalTextureWrapMode x = fromIntegral $ case x of - (Repeated, Clamp) -> gl_CLAMP - (Repeated, Repeat) -> gl_REPEAT - (Repeated, ClampToEdge) -> gl_CLAMP_TO_EDGE - (Repeated, ClampToBorder) -> gl_CLAMP_TO_BORDER - (Mirrored, Repeat) -> gl_MIRRORED_REPEAT - _ -> error ("marshalTextureWrapMode: illegal value " ++ show x) - -foreign import ccall unsafe "GL/glpng.h pngBind" - rawPngBind :: CString -> CInt -> CInt -> Ptr PngInfo -> CInt -> CInt -> CInt -> IO CUInt - - -pngBind :: String -> Mipmap -> Trans -> (Repetition, Clamping) -> MinificationFilter -> MagnificationFilter -> IO (CUInt, PngInfo) -pngBind name mipmap trans wrapst minfilter magfilter = alloca $ \infop -> withCString name $ \cname -> do - ret <- rawPngBind cname (marshalMipmap mipmap) (marshalTrans trans) infop (marshalTextureWrapMode wrapst) - (marshalMinificationFilter minfilter) (marshalMagnificationFilter magfilter) - info <- peek infop - return (ret, info) - \ No newline at end of file diff --git a/Bindings/GLPng.hs b/Bindings/GLPng.hs index 6be3b82..3a6baab 100644 --- a/Bindings/GLPng.hs +++ b/Bindings/GLPng.hs @@ -1,8 +1,8 @@ {-# INCLUDE #-} {-# INCLUDE #-} -{-# LINE 1 "GLPng.chs" #-} +{-# LINE 1 "Bindings/GLPng.hsc" #-} {-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-} -{-# LINE 2 "GLPng.chs" #-} +{-# LINE 2 "Bindings/GLPng.hsc" #-} module Bindings.GLPng ( PngInfo(..) , Mipmap(..) @@ -22,9 +22,9 @@ import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clampi -{-# LINE 21 "GLPng.chs" #-} +{-# LINE 21 "Bindings/GLPng.hsc" #-} -{-# LINE 22 "GLPng.chs" #-} +{-# LINE 22 "Bindings/GLPng.hsc" #-} data PngInfo = PngInfo @@ -36,45 +36,45 @@ data PngInfo = PngInfo instance Storable PngInfo where sizeOf _ = ((16)) -{-# LINE 33 "GLPng.chs" #-} +{-# LINE 33 "Bindings/GLPng.hsc" #-} alignment _ = alignment (undefined :: CUInt) peek pi = do w <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) pi -{-# LINE 37 "GLPng.chs" #-} +{-# LINE 37 "Bindings/GLPng.hsc" #-} h <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) pi -{-# LINE 38 "GLPng.chs" #-} +{-# LINE 38 "Bindings/GLPng.hsc" #-} d <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) pi -{-# LINE 39 "GLPng.chs" #-} +{-# LINE 39 "Bindings/GLPng.hsc" #-} a <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) pi -{-# LINE 40 "GLPng.chs" #-} +{-# LINE 40 "Bindings/GLPng.hsc" #-} return (PngInfo w h d a) poke pi (PngInfo w h d a) = do ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) pi w -{-# LINE 45 "GLPng.chs" #-} +{-# LINE 45 "Bindings/GLPng.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) pi h -{-# LINE 46 "GLPng.chs" #-} +{-# LINE 46 "Bindings/GLPng.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) pi d -{-# LINE 47 "GLPng.chs" #-} +{-# LINE 47 "Bindings/GLPng.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) pi a -{-# LINE 48 "GLPng.chs" #-} +{-# LINE 48 "Bindings/GLPng.hsc" #-} png_NoMipmap :: CInt png_NoMipmap = (0) -{-# LINE 54 "GLPng.chs" #-} +{-# LINE 54 "Bindings/GLPng.hsc" #-} png_BuildMipmap :: CInt png_BuildMipmap = (-1) -{-# LINE 57 "GLPng.chs" #-} +{-# LINE 57 "Bindings/GLPng.hsc" #-} png_SimpleMipmap :: CInt png_SimpleMipmap = (-2) -{-# LINE 60 "GLPng.chs" #-} +{-# LINE 60 "Bindings/GLPng.hsc" #-} data Mipmap = NoMipmap | BuildMipmap | SimpleMipmap @@ -89,11 +89,11 @@ marshalMipmap m png_Alpha :: CInt png_Alpha = (-2) -{-# LINE 74 "GLPng.chs" #-} +{-# LINE 74 "Bindings/GLPng.hsc" #-} png_Solid :: CInt png_Solid = (-1) -{-# LINE 77 "GLPng.chs" #-} +{-# LINE 77 "Bindings/GLPng.hsc" #-} data Trans = Alpha | Solid deriving (Eq, Show) @@ -110,27 +110,27 @@ magToMin magFilter = (magFilter, Nothing) gl_NEAREST :: CInt gl_NEAREST = (9728) -{-# LINE 93 "GLPng.chs" #-} +{-# LINE 93 "Bindings/GLPng.hsc" #-} gl_LINEAR :: CInt gl_LINEAR = (9729) -{-# LINE 96 "GLPng.chs" #-} +{-# LINE 96 "Bindings/GLPng.hsc" #-} gl_NEAREST_MIPMAP_NEAREST :: CInt gl_NEAREST_MIPMAP_NEAREST = (9984) -{-# LINE 99 "GLPng.chs" #-} +{-# LINE 99 "Bindings/GLPng.hsc" #-} gl_LINEAR_MIPMAP_NEAREST :: CInt gl_LINEAR_MIPMAP_NEAREST = (9985) -{-# LINE 102 "GLPng.chs" #-} +{-# LINE 102 "Bindings/GLPng.hsc" #-} gl_NEAREST_MIPMAP_LINEAR :: CInt gl_NEAREST_MIPMAP_LINEAR = (9986) -{-# LINE 105 "GLPng.chs" #-} +{-# LINE 105 "Bindings/GLPng.hsc" #-} gl_LINEAR_MIPMAP_LINEAR :: CInt gl_LINEAR_MIPMAP_LINEAR = (9987) -{-# LINE 108 "GLPng.chs" #-} +{-# LINE 108 "Bindings/GLPng.hsc" #-} marshalMinificationFilter :: MinificationFilter -> CInt @@ -148,23 +148,23 @@ marshalMagnificationFilter = marshalMinificationFilter . magToMin gl_CLAMP :: CInt gl_CLAMP = (10496) -{-# LINE 125 "GLPng.chs" #-} +{-# LINE 125 "Bindings/GLPng.hsc" #-} gl_REPEAT :: CInt gl_REPEAT = (10497) -{-# LINE 128 "GLPng.chs" #-} +{-# LINE 128 "Bindings/GLPng.hsc" #-} gl_CLAMP_TO_EDGE :: CInt gl_CLAMP_TO_EDGE = (33071) -{-# LINE 131 "GLPng.chs" #-} +{-# LINE 131 "Bindings/GLPng.hsc" #-} gl_CLAMP_TO_BORDER :: CInt gl_CLAMP_TO_BORDER = (33069) -{-# LINE 134 "GLPng.chs" #-} +{-# LINE 134 "Bindings/GLPng.hsc" #-} gl_MIRRORED_REPEAT :: CInt gl_MIRRORED_REPEAT = (33648) -{-# LINE 137 "GLPng.chs" #-} +{-# LINE 137 "Bindings/GLPng.hsc" #-} marshalTextureWrapMode :: (Repetition, Clamping) -> CInt diff --git a/Bindings/GLPng.hsc b/Bindings/GLPng.hsc new file mode 100644 index 0000000..453bddc --- /dev/null +++ b/Bindings/GLPng.hsc @@ -0,0 +1,158 @@ +{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-} + +module Bindings.GLPng ( PngInfo(..) + , Mipmap(..) + , Trans (..) + , pngBind + ) where + +import Data.Generics + +import Foreign.C.String (CString, withCString) +import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr +import Foreign.Storable + +import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clamping(..), TextureFilter(..), MinificationFilter, MagnificationFilter) + + +#include +#include + + +data PngInfo = PngInfo + { pngWidth :: !CUInt + , pngHeight :: !CUInt + , pngDepth :: !CUInt + , pngAlpha :: !CUInt + } deriving (Eq, Ord, Show, Typeable) + +instance Storable PngInfo where + sizeOf _ = (#size pngInfo) + alignment _ = alignment (undefined :: CUInt) + + peek pi = do + w <- (#peek pngInfo, Width) pi + h <- (#peek pngInfo, Height) pi + d <- (#peek pngInfo, Depth) pi + a <- (#peek pngInfo, Alpha) pi + + return (PngInfo w h d a) + + poke pi (PngInfo w h d a) = do + (#poke pngInfo, Width) pi w + (#poke pngInfo, Height) pi h + (#poke pngInfo, Depth) pi d + (#poke pngInfo, Alpha) pi a + + + + +png_NoMipmap :: CInt +png_NoMipmap = (#const PNG_NOMIPMAP) + +png_BuildMipmap :: CInt +png_BuildMipmap = (#const PNG_BUILDMIPMAP) + +png_SimpleMipmap :: CInt +png_SimpleMipmap = (#const PNG_SIMPLEMIPMAP) + + +data Mipmap = NoMipmap | BuildMipmap | SimpleMipmap + deriving (Eq, Show) + +marshalMipmap :: Mipmap -> CInt +marshalMipmap m + | m == NoMipmap = png_NoMipmap + | m == BuildMipmap = png_BuildMipmap + | m == SimpleMipmap = png_SimpleMipmap + + +png_Alpha :: CInt +png_Alpha = (#const PNG_ALPHA) + +png_Solid :: CInt +png_Solid = (#const PNG_SOLID) + +data Trans = Alpha | Solid + deriving (Eq, Show) + +marshalTrans :: Trans -> CInt +marshalTrans t + | t == Alpha = png_Alpha + | t == Solid = png_Solid + + +magToMin :: MagnificationFilter -> MinificationFilter +magToMin magFilter = (magFilter, Nothing) + + +gl_NEAREST :: CInt +gl_NEAREST = (#const GL_NEAREST) + +gl_LINEAR :: CInt +gl_LINEAR = (#const GL_LINEAR) + +gl_NEAREST_MIPMAP_NEAREST :: CInt +gl_NEAREST_MIPMAP_NEAREST = (#const GL_NEAREST_MIPMAP_NEAREST) + +gl_LINEAR_MIPMAP_NEAREST :: CInt +gl_LINEAR_MIPMAP_NEAREST = (#const GL_LINEAR_MIPMAP_NEAREST) + +gl_NEAREST_MIPMAP_LINEAR :: CInt +gl_NEAREST_MIPMAP_LINEAR = (#const GL_NEAREST_MIPMAP_LINEAR) + +gl_LINEAR_MIPMAP_LINEAR :: CInt +gl_LINEAR_MIPMAP_LINEAR = (#const GL_LINEAR_MIPMAP_LINEAR) + + +marshalMinificationFilter :: MinificationFilter -> CInt +marshalMinificationFilter x = fromIntegral $ case x of + (Nearest, Nothing ) -> gl_NEAREST + (Linear', Nothing ) -> gl_LINEAR + (Nearest, Just Nearest) -> gl_NEAREST_MIPMAP_NEAREST + (Linear', Just Nearest) -> gl_LINEAR_MIPMAP_NEAREST + (Nearest, Just Linear') -> gl_NEAREST_MIPMAP_LINEAR + (Linear', Just Linear') -> gl_LINEAR_MIPMAP_LINEAR + +marshalMagnificationFilter :: MagnificationFilter -> CInt +marshalMagnificationFilter = marshalMinificationFilter . magToMin + + +gl_CLAMP :: CInt +gl_CLAMP = (#const GL_CLAMP) + +gl_REPEAT :: CInt +gl_REPEAT = (#const GL_REPEAT) + +gl_CLAMP_TO_EDGE :: CInt +gl_CLAMP_TO_EDGE = (#const GL_CLAMP_TO_EDGE) + +gl_CLAMP_TO_BORDER :: CInt +gl_CLAMP_TO_BORDER = (#const GL_CLAMP_TO_BORDER) + +gl_MIRRORED_REPEAT :: CInt +gl_MIRRORED_REPEAT = (#const GL_MIRRORED_REPEAT) + + +marshalTextureWrapMode :: (Repetition, Clamping) -> CInt +marshalTextureWrapMode x = fromIntegral $ case x of + (Repeated, Clamp) -> gl_CLAMP + (Repeated, Repeat) -> gl_REPEAT + (Repeated, ClampToEdge) -> gl_CLAMP_TO_EDGE + (Repeated, ClampToBorder) -> gl_CLAMP_TO_BORDER + (Mirrored, Repeat) -> gl_MIRRORED_REPEAT + _ -> error ("marshalTextureWrapMode: illegal value " ++ show x) + +foreign import ccall unsafe "GL/glpng.h pngBind" + rawPngBind :: CString -> CInt -> CInt -> Ptr PngInfo -> CInt -> CInt -> CInt -> IO CUInt + + +pngBind :: String -> Mipmap -> Trans -> (Repetition, Clamping) -> MinificationFilter -> MagnificationFilter -> IO (CUInt, PngInfo) +pngBind name mipmap trans wrapst minfilter magfilter = alloca $ \infop -> withCString name $ \cname -> do + ret <- rawPngBind cname (marshalMipmap mipmap) (marshalTrans trans) infop (marshalTextureWrapMode wrapst) + (marshalMinificationFilter minfilter) (marshalMagnificationFilter magfilter) + info <- peek infop + return (ret, info) + \ No newline at end of file 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 - - -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 () diff --git a/Bindings/GLX.hs b/Bindings/GLX.hs index 65fad11..f2fab65 100644 --- a/Bindings/GLX.hs +++ b/Bindings/GLX.hs @@ -1,7 +1,7 @@ {-# INCLUDE #-} -{-# LINE 1 "GLX.chs" #-} +{-# LINE 1 "Bindings/GLX.hsc" #-} {-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -{-# LINE 2 "GLX.chs" #-} +{-# LINE 2 "Bindings/GLX.hsc" #-} module Bindings.GLX ( createColormap , createWindow @@ -44,7 +44,7 @@ import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position) -{-# LINE 44 "GLX.chs" #-} +{-# LINE 44 "Bindings/GLX.hsc" #-} type Drawable = XID @@ -73,55 +73,55 @@ data VisualInfo = VisualInfo instance Storable VisualInfo where sizeOf _ = ((40)) -{-# LINE 72 "GLX.chs" #-} +{-# LINE 72 "Bindings/GLX.hsc" #-} alignment _ = alignment (undefined :: CULong) peek vi = do visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi -{-# LINE 76 "GLX.chs" #-} +{-# LINE 76 "Bindings/GLX.hsc" #-} visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi -{-# LINE 77 "GLX.chs" #-} +{-# LINE 77 "Bindings/GLX.hsc" #-} screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi -{-# LINE 78 "GLX.chs" #-} +{-# LINE 78 "Bindings/GLX.hsc" #-} depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi -{-# LINE 79 "GLX.chs" #-} +{-# LINE 79 "Bindings/GLX.hsc" #-} viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi -{-# LINE 80 "GLX.chs" #-} +{-# LINE 80 "Bindings/GLX.hsc" #-} red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi -{-# LINE 81 "GLX.chs" #-} +{-# LINE 81 "Bindings/GLX.hsc" #-} green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi -{-# LINE 82 "GLX.chs" #-} +{-# LINE 82 "Bindings/GLX.hsc" #-} blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi -{-# LINE 83 "GLX.chs" #-} +{-# LINE 83 "Bindings/GLX.hsc" #-} colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi -{-# LINE 84 "GLX.chs" #-} +{-# LINE 84 "Bindings/GLX.hsc" #-} bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi -{-# LINE 85 "GLX.chs" #-} +{-# LINE 85 "Bindings/GLX.hsc" #-} 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 91 "GLX.chs" #-} +{-# LINE 91 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid -{-# LINE 92 "GLX.chs" #-} +{-# LINE 92 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen -{-# LINE 93 "GLX.chs" #-} +{-# LINE 93 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth -{-# LINE 94 "GLX.chs" #-} +{-# LINE 94 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass -{-# LINE 95 "GLX.chs" #-} +{-# LINE 95 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask -{-# LINE 96 "GLX.chs" #-} +{-# LINE 96 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask -{-# LINE 97 "GLX.chs" #-} +{-# LINE 97 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask -{-# LINE 98 "GLX.chs" #-} +{-# LINE 98 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size -{-# LINE 99 "GLX.chs" #-} +{-# LINE 99 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb -{-# LINE 100 "GLX.chs" #-} +{-# LINE 100 "Bindings/GLX.hsc" #-} data SetWindowAttributes = SetWindowAttributes @@ -143,38 +143,38 @@ data SetWindowAttributes = SetWindowAttributes instance Storable SetWindowAttributes where sizeOf _ = ((60)) -{-# LINE 121 "GLX.chs" #-} +{-# LINE 121 "Bindings/GLX.hsc" #-} alignment _ = alignment (undefined :: CULong) peek swa = do background_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) swa -{-# LINE 125 "GLX.chs" #-} +{-# LINE 125 "Bindings/GLX.hsc" #-} background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa -{-# LINE 126 "GLX.chs" #-} +{-# LINE 126 "Bindings/GLX.hsc" #-} border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa -{-# LINE 127 "GLX.chs" #-} +{-# LINE 127 "Bindings/GLX.hsc" #-} bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa -{-# LINE 128 "GLX.chs" #-} +{-# LINE 128 "Bindings/GLX.hsc" #-} win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa -{-# LINE 129 "GLX.chs" #-} +{-# LINE 129 "Bindings/GLX.hsc" #-} backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa -{-# LINE 130 "GLX.chs" #-} +{-# LINE 130 "Bindings/GLX.hsc" #-} backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa -{-# LINE 131 "GLX.chs" #-} +{-# LINE 131 "Bindings/GLX.hsc" #-} backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa -{-# LINE 132 "GLX.chs" #-} +{-# LINE 132 "Bindings/GLX.hsc" #-} save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa -{-# LINE 133 "GLX.chs" #-} +{-# LINE 133 "Bindings/GLX.hsc" #-} event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa -{-# LINE 134 "GLX.chs" #-} +{-# LINE 134 "Bindings/GLX.hsc" #-} do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa -{-# LINE 135 "GLX.chs" #-} +{-# LINE 135 "Bindings/GLX.hsc" #-} override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa -{-# LINE 136 "GLX.chs" #-} +{-# LINE 136 "Bindings/GLX.hsc" #-} colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa -{-# LINE 137 "GLX.chs" #-} +{-# LINE 137 "Bindings/GLX.hsc" #-} cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa -{-# LINE 138 "GLX.chs" #-} +{-# LINE 138 "Bindings/GLX.hsc" #-} return (SetWindowAttributes background_pixmap @@ -208,33 +208,33 @@ instance Storable SetWindowAttributes where colormap cursor) = do ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) swa background_pixmap -{-# LINE 171 "GLX.chs" #-} +{-# LINE 171 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel -{-# LINE 172 "GLX.chs" #-} +{-# LINE 172 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap -{-# LINE 173 "GLX.chs" #-} +{-# LINE 173 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity -{-# LINE 174 "GLX.chs" #-} +{-# LINE 174 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity -{-# LINE 175 "GLX.chs" #-} +{-# LINE 175 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store -{-# LINE 176 "GLX.chs" #-} +{-# LINE 176 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes -{-# LINE 177 "GLX.chs" #-} +{-# LINE 177 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel -{-# LINE 178 "GLX.chs" #-} +{-# LINE 178 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under -{-# LINE 179 "GLX.chs" #-} +{-# LINE 179 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask -{-# LINE 180 "GLX.chs" #-} +{-# LINE 180 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask -{-# LINE 181 "GLX.chs" #-} +{-# LINE 181 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect -{-# LINE 182 "GLX.chs" #-} +{-# LINE 182 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap -{-# LINE 183 "GLX.chs" #-} +{-# LINE 183 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor -{-# LINE 184 "GLX.chs" #-} +{-# LINE 184 "Bindings/GLX.hsc" #-} nullSetWindowAttributes :: SetWindowAttributes nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0) @@ -253,13 +253,13 @@ foreign import ccall unsafe "GL/glx.h XSetClassHint" setClassHint :: Display -> Window -> ClassHint -> IO () setClassHint disp wnd hint = allocaBytes ((8)) $ \p -> -{-# LINE 202 "GLX.chs" #-} +{-# LINE 202 "Bindings/GLX.hsc" #-} withCString (resName hint) $ \res_name -> withCString (resClass hint) $ \res_class -> do ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p res_name -{-# LINE 205 "GLX.chs" #-} +{-# LINE 205 "Bindings/GLX.hsc" #-} ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p res_class -{-# LINE 206 "GLX.chs" #-} +{-# LINE 206 "Bindings/GLX.hsc" #-} xSetClassHint disp wnd p @@ -277,35 +277,35 @@ chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (con renderType :: CInt renderType = (32785) -{-# LINE 223 "GLX.chs" #-} +{-# LINE 223 "Bindings/GLX.hsc" #-} rgbaBit :: CInt rgbaBit = (1) -{-# LINE 226 "GLX.chs" #-} +{-# LINE 226 "Bindings/GLX.hsc" #-} drawableType :: CInt drawableType = (32784) -{-# LINE 229 "GLX.chs" #-} +{-# LINE 229 "Bindings/GLX.hsc" #-} windowBit :: CInt windowBit = (1) -{-# LINE 232 "GLX.chs" #-} +{-# LINE 232 "Bindings/GLX.hsc" #-} xRenderable :: CInt xRenderable = (32786) -{-# LINE 235 "GLX.chs" #-} +{-# LINE 235 "Bindings/GLX.hsc" #-} doublebuffer :: CInt doublebuffer = (5) -{-# LINE 238 "GLX.chs" #-} +{-# LINE 238 "Bindings/GLX.hsc" #-} depthSize :: CInt depthSize = (12) -{-# LINE 241 "GLX.chs" #-} +{-# LINE 241 "Bindings/GLX.hsc" #-} stencilSize :: CInt stencilSize = (13) -{-# LINE 244 "GLX.chs" #-} +{-# LINE 244 "Bindings/GLX.hsc" #-} foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig" glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo) diff --git a/Bindings/GLX.hsc b/Bindings/GLX.hsc new file mode 100644 index 0000000..d5fed4d --- /dev/null +++ b/Bindings/GLX.hsc @@ -0,0 +1,265 @@ +{-# 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 + + +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 () diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..7492b7a --- /dev/null +++ b/Makefile @@ -0,0 +1,7 @@ +all: HTanks + +HTanks : Bindings/GLX.hs Bindings/GLPng.hs GLDriver.hs GLX.hs Texture.hs Tank.hs Level.hs Game.hs Render.hs HTanks.hs + ghc --make HTanks -lGL -lglpng + +%.hs : %.hsc + hsc2hs $< -- cgit v1.2.3