diff options
Diffstat (limited to 'Bindings')
| -rw-r--r-- | Bindings/GLPng.hsc | 158 | ||||
| -rw-r--r-- | Bindings/GLX.hsc | 265 |
2 files changed, 0 insertions, 423 deletions
diff --git a/Bindings/GLPng.hsc b/Bindings/GLPng.hsc deleted file mode 100644 index 453bddc..0000000 --- a/Bindings/GLPng.hsc +++ /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 <GL/gl.h> -#include <GL/glpng.h> - - -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.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 () |