Moved source files to src directory
This commit is contained in:
Matthias Schiffer
parent
2bb8561836
commit
7327695ca3
14 changed files with 3 additions and 6 deletions
158
src/Bindings/GLPng.hsc
Normal file
158
src/Bindings/GLPng.hsc
Normal file
|
|
@ -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)
|
||||
|
||||
265
src/Bindings/GLX.hsc
Normal file
265
src/Bindings/GLX.hsc
Normal file
|
|
@ -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 ()
|
||||
Reference in a new issue