Moved source files to src directory

2 files changed, 423 insertions, 0 deletions

diff --git a/src/Bindings/GLPng.hsc b/src/Bindings/GLPng.hsc
new file mode 100644
index 0000000..453bddc
--- /dev/null
+++ b/src/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 <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/src/Bindings/GLX.hsc b/src/Bindings/GLX.hsc
new file mode 100644
index 0000000..d5fed4d
--- /dev/null
+++ b/src/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 <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 ()