Initial commit
This commit is contained in:
Matthias Schiffer
commit
62fe58cb55
9 changed files with 727 additions and 0 deletions
6
.gitignore
vendored
Normal file
6
.gitignore
vendored
Normal file
|
|
@ -0,0 +1,6 @@
|
||||||
|
*.hi
|
||||||
|
*.o
|
||||||
|
*~
|
||||||
|
*.chs.h
|
||||||
|
|
||||||
|
HTanks
|
||||||
242
Bindings/GLX.chs
Normal file
242
Bindings/GLX.chs
Normal file
|
|
@ -0,0 +1,242 @@
|
||||||
|
{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
module Bindings.GLX ( createColormap
|
||||||
|
, createWindow
|
||||||
|
, chooseFBConfig
|
||||||
|
, getVisualFromFBConfig
|
||||||
|
, XVisualInfo(..)
|
||||||
|
, XSetWindowAttributes(..)
|
||||||
|
, nullSetWindowAttributes
|
||||||
|
, glXGetVisualFromFBConfig
|
||||||
|
, glxRenderType
|
||||||
|
, glxRgbaBit
|
||||||
|
, glxDrawableType
|
||||||
|
, glxWindowBit
|
||||||
|
, glxXRenderable
|
||||||
|
, glxDoublebuffer
|
||||||
|
, glxDepthSize
|
||||||
|
, glxStencilSize
|
||||||
|
, glxTrue
|
||||||
|
, glXCreateContext
|
||||||
|
, glXMakeCurrent
|
||||||
|
, GLXContext(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Generics
|
||||||
|
import Data.Int
|
||||||
|
import Data.Word
|
||||||
|
|
||||||
|
import Foreign.C.Types
|
||||||
|
import Foreign.Ptr
|
||||||
|
import Foreign.Marshal.Alloc (alloca)
|
||||||
|
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)
|
||||||
|
import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
|
||||||
|
|
||||||
|
|
||||||
|
#include <GL/glx.h>
|
||||||
|
|
||||||
|
|
||||||
|
newtype GLXFBConfig = GLXFBConfig (Ptr GLXFBConfig)
|
||||||
|
deriving (Eq, Ord, Show, Typeable, Data, Storable)
|
||||||
|
|
||||||
|
newtype GLXContext = GLXContext (Ptr GLXContext)
|
||||||
|
deriving (Eq, Ord, Show, Typeable, Data, Storable)
|
||||||
|
|
||||||
|
newtype Visual = Visual (Ptr Visual)
|
||||||
|
deriving (Eq, Ord, Show, Typeable, Data, Storable)
|
||||||
|
|
||||||
|
data XVisualInfo = XVisualInfo
|
||||||
|
{ vi_visual :: !Visual
|
||||||
|
, vi_visualid :: !VisualID
|
||||||
|
, vi_screen :: !CInt
|
||||||
|
, vi_depth :: !CInt
|
||||||
|
, vi_class :: !CInt
|
||||||
|
, vi_red_mask :: !CULong
|
||||||
|
, vi_green_mask :: !CULong
|
||||||
|
, vi_blue_mask :: !CULong
|
||||||
|
, vi_colormap_size :: !CInt
|
||||||
|
, vi_bits_per_rgb :: !CInt
|
||||||
|
} deriving (Eq, Ord, Show, Typeable)
|
||||||
|
|
||||||
|
instance Storable XVisualInfo 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 (XVisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb)
|
||||||
|
|
||||||
|
|
||||||
|
poke vi (XVisualInfo 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 XSetWindowAttributes = XSetWindowAttributes
|
||||||
|
{ swa_background_pixmap :: !Pixmap
|
||||||
|
, swa_packground_pixel :: !Pixel
|
||||||
|
, swa_border_pixmap :: !Pixmap
|
||||||
|
, swa_bit_gravity :: !CInt
|
||||||
|
, swa_win_gravity :: !CInt
|
||||||
|
, swa_backing_store :: !CInt
|
||||||
|
, swa_backing_planes :: !CULong
|
||||||
|
, swa_backing_pixel :: !CULong
|
||||||
|
, swa_save_under :: !Bool
|
||||||
|
, swa_event_mask :: !EventMask
|
||||||
|
, swa_do_not_propagate_mask :: !CULong
|
||||||
|
, swa_override_redirect :: !Bool
|
||||||
|
, swa_colormap :: !Colormap
|
||||||
|
, swa_cursor :: !Cursor
|
||||||
|
} deriving (Eq, Ord, Show, Typeable)
|
||||||
|
|
||||||
|
instance Storable XSetWindowAttributes 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 (XSetWindowAttributes
|
||||||
|
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 (XSetWindowAttributes
|
||||||
|
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 :: XSetWindowAttributes
|
||||||
|
nullSetWindowAttributes = (XSetWindowAttributes 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 XSetWindowAttributes -> IO Window
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
foreign import ccall unsafe "GL/glx.h glXChooseFBConfig"
|
||||||
|
glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr GLXFBConfig)
|
||||||
|
|
||||||
|
chooseFBConfig :: Display -> CInt -> [(CInt, CInt)] -> IO [GLXFBConfig]
|
||||||
|
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
|
||||||
|
peekArray (fromIntegral nelements) configs
|
||||||
|
|
||||||
|
glxRenderType :: CInt
|
||||||
|
glxRenderType = (#const GLX_RENDER_TYPE)
|
||||||
|
|
||||||
|
glxRgbaBit :: CInt
|
||||||
|
glxRgbaBit = (#const GLX_RGBA_BIT)
|
||||||
|
|
||||||
|
glxDrawableType :: CInt
|
||||||
|
glxDrawableType = (#const GLX_DRAWABLE_TYPE)
|
||||||
|
|
||||||
|
glxWindowBit :: CInt
|
||||||
|
glxWindowBit = (#const GLX_WINDOW_BIT)
|
||||||
|
|
||||||
|
glxXRenderable :: CInt
|
||||||
|
glxXRenderable = (#const GLX_X_RENDERABLE)
|
||||||
|
|
||||||
|
glxDoublebuffer :: CInt
|
||||||
|
glxDoublebuffer = (#const GLX_DOUBLEBUFFER)
|
||||||
|
|
||||||
|
glxDepthSize :: CInt
|
||||||
|
glxDepthSize = (#const GLX_DEPTH_SIZE)
|
||||||
|
|
||||||
|
glxStencilSize :: CInt
|
||||||
|
glxStencilSize = (#const GLX_STENCIL_SIZE)
|
||||||
|
|
||||||
|
glxTrue :: CInt
|
||||||
|
glxTrue = (#const True)
|
||||||
|
|
||||||
|
foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
|
||||||
|
glXGetVisualFromFBConfig :: Display -> GLXFBConfig -> IO (Ptr XVisualInfo)
|
||||||
|
|
||||||
|
getVisualFromFBConfig :: Display -> GLXFBConfig -> IO (XVisualInfo)
|
||||||
|
getVisualFromFBConfig disp config = do
|
||||||
|
vi <- glXGetVisualFromFBConfig disp config
|
||||||
|
peek vi
|
||||||
|
|
||||||
|
foreign import ccall unsafe "GL/glx.h glXCreateContext"
|
||||||
|
glXCreateContext :: Display -> Ptr XVisualInfo -> GLXContext -> Bool -> IO GLXContext
|
||||||
|
|
||||||
|
foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
|
||||||
|
glXMakeCurrent :: Display -> XID -> GLXContext -> IO Bool
|
||||||
305
Bindings/GLX.hs
Normal file
305
Bindings/GLX.hs
Normal file
|
|
@ -0,0 +1,305 @@
|
||||||
|
{-# INCLUDE <GL/glx.h> #-}
|
||||||
|
{-# LINE 1 "GLX.chs" #-}
|
||||||
|
{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LINE 2 "GLX.chs" #-}
|
||||||
|
|
||||||
|
module Bindings.GLX ( createColormap
|
||||||
|
, createWindow
|
||||||
|
, chooseFBConfig
|
||||||
|
, getVisualFromFBConfig
|
||||||
|
, XVisualInfo(..)
|
||||||
|
, XSetWindowAttributes(..)
|
||||||
|
, nullSetWindowAttributes
|
||||||
|
, glXGetVisualFromFBConfig
|
||||||
|
, glxRenderType
|
||||||
|
, glxRgbaBit
|
||||||
|
, glxDrawableType
|
||||||
|
, glxWindowBit
|
||||||
|
, glxXRenderable
|
||||||
|
, glxDoublebuffer
|
||||||
|
, glxDepthSize
|
||||||
|
, glxStencilSize
|
||||||
|
, glxTrue
|
||||||
|
, glXCreateContext
|
||||||
|
, glXMakeCurrent
|
||||||
|
, GLXContext(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Generics
|
||||||
|
import Data.Int
|
||||||
|
import Data.Word
|
||||||
|
|
||||||
|
import Foreign.C.Types
|
||||||
|
import Foreign.Ptr
|
||||||
|
import Foreign.Marshal.Alloc (alloca)
|
||||||
|
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)
|
||||||
|
import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
{-# LINE 41 "GLX.chs" #-}
|
||||||
|
|
||||||
|
|
||||||
|
newtype GLXFBConfig = GLXFBConfig (Ptr GLXFBConfig)
|
||||||
|
deriving (Eq, Ord, Show, Typeable, Data, Storable)
|
||||||
|
|
||||||
|
newtype GLXContext = GLXContext (Ptr GLXContext)
|
||||||
|
deriving (Eq, Ord, Show, Typeable, Data, Storable)
|
||||||
|
|
||||||
|
newtype Visual = Visual (Ptr Visual)
|
||||||
|
deriving (Eq, Ord, Show, Typeable, Data, Storable)
|
||||||
|
|
||||||
|
data XVisualInfo = XVisualInfo
|
||||||
|
{ vi_visual :: !Visual
|
||||||
|
, vi_visualid :: !VisualID
|
||||||
|
, vi_screen :: !CInt
|
||||||
|
, vi_depth :: !CInt
|
||||||
|
, vi_class :: !CInt
|
||||||
|
, vi_red_mask :: !CULong
|
||||||
|
, vi_green_mask :: !CULong
|
||||||
|
, vi_blue_mask :: !CULong
|
||||||
|
, vi_colormap_size :: !CInt
|
||||||
|
, vi_bits_per_rgb :: !CInt
|
||||||
|
} deriving (Eq, Ord, Show, Typeable)
|
||||||
|
|
||||||
|
instance Storable XVisualInfo where
|
||||||
|
sizeOf _ = ((40))
|
||||||
|
{-# LINE 67 "GLX.chs" #-}
|
||||||
|
alignment _ = alignment (undefined :: CULong)
|
||||||
|
|
||||||
|
peek vi = do
|
||||||
|
visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi
|
||||||
|
{-# LINE 71 "GLX.chs" #-}
|
||||||
|
visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
|
||||||
|
{-# LINE 72 "GLX.chs" #-}
|
||||||
|
screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi
|
||||||
|
{-# LINE 73 "GLX.chs" #-}
|
||||||
|
depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi
|
||||||
|
{-# LINE 74 "GLX.chs" #-}
|
||||||
|
viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi
|
||||||
|
{-# LINE 75 "GLX.chs" #-}
|
||||||
|
red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi
|
||||||
|
{-# LINE 76 "GLX.chs" #-}
|
||||||
|
green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi
|
||||||
|
{-# LINE 77 "GLX.chs" #-}
|
||||||
|
blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi
|
||||||
|
{-# LINE 78 "GLX.chs" #-}
|
||||||
|
colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi
|
||||||
|
{-# LINE 79 "GLX.chs" #-}
|
||||||
|
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi
|
||||||
|
{-# LINE 80 "GLX.chs" #-}
|
||||||
|
|
||||||
|
return (XVisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb)
|
||||||
|
|
||||||
|
|
||||||
|
poke vi (XVisualInfo 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 86 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
|
||||||
|
{-# LINE 87 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen
|
||||||
|
{-# LINE 88 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth
|
||||||
|
{-# LINE 89 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass
|
||||||
|
{-# LINE 90 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask
|
||||||
|
{-# LINE 91 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask
|
||||||
|
{-# LINE 92 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask
|
||||||
|
{-# LINE 93 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size
|
||||||
|
{-# LINE 94 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb
|
||||||
|
{-# LINE 95 "GLX.chs" #-}
|
||||||
|
|
||||||
|
|
||||||
|
data XSetWindowAttributes = XSetWindowAttributes
|
||||||
|
{ swa_background_pixmap :: !Pixmap
|
||||||
|
, swa_packground_pixel :: !Pixel
|
||||||
|
, swa_border_pixmap :: !Pixmap
|
||||||
|
, swa_bit_gravity :: !CInt
|
||||||
|
, swa_win_gravity :: !CInt
|
||||||
|
, swa_backing_store :: !CInt
|
||||||
|
, swa_backing_planes :: !CULong
|
||||||
|
, swa_backing_pixel :: !CULong
|
||||||
|
, swa_save_under :: !Bool
|
||||||
|
, swa_event_mask :: !EventMask
|
||||||
|
, swa_do_not_propagate_mask :: !CULong
|
||||||
|
, swa_override_redirect :: !Bool
|
||||||
|
, swa_colormap :: !Colormap
|
||||||
|
, swa_cursor :: !Cursor
|
||||||
|
} deriving (Eq, Ord, Show, Typeable)
|
||||||
|
|
||||||
|
instance Storable XSetWindowAttributes where
|
||||||
|
sizeOf _ = ((60))
|
||||||
|
{-# LINE 116 "GLX.chs" #-}
|
||||||
|
alignment _ = alignment (undefined :: CULong)
|
||||||
|
|
||||||
|
peek swa = do
|
||||||
|
background_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) swa
|
||||||
|
{-# LINE 120 "GLX.chs" #-}
|
||||||
|
background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
|
||||||
|
{-# LINE 121 "GLX.chs" #-}
|
||||||
|
border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa
|
||||||
|
{-# LINE 122 "GLX.chs" #-}
|
||||||
|
bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa
|
||||||
|
{-# LINE 123 "GLX.chs" #-}
|
||||||
|
win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa
|
||||||
|
{-# LINE 124 "GLX.chs" #-}
|
||||||
|
backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa
|
||||||
|
{-# LINE 125 "GLX.chs" #-}
|
||||||
|
backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa
|
||||||
|
{-# LINE 126 "GLX.chs" #-}
|
||||||
|
backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa
|
||||||
|
{-# LINE 127 "GLX.chs" #-}
|
||||||
|
save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa
|
||||||
|
{-# LINE 128 "GLX.chs" #-}
|
||||||
|
event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa
|
||||||
|
{-# LINE 129 "GLX.chs" #-}
|
||||||
|
do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa
|
||||||
|
{-# LINE 130 "GLX.chs" #-}
|
||||||
|
override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa
|
||||||
|
{-# LINE 131 "GLX.chs" #-}
|
||||||
|
colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa
|
||||||
|
{-# LINE 132 "GLX.chs" #-}
|
||||||
|
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
|
||||||
|
{-# LINE 133 "GLX.chs" #-}
|
||||||
|
|
||||||
|
return (XSetWindowAttributes
|
||||||
|
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 (XSetWindowAttributes
|
||||||
|
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
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) swa background_pixmap
|
||||||
|
{-# LINE 166 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
|
||||||
|
{-# LINE 167 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap
|
||||||
|
{-# LINE 168 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity
|
||||||
|
{-# LINE 169 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity
|
||||||
|
{-# LINE 170 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store
|
||||||
|
{-# LINE 171 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes
|
||||||
|
{-# LINE 172 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel
|
||||||
|
{-# LINE 173 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under
|
||||||
|
{-# LINE 174 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask
|
||||||
|
{-# LINE 175 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask
|
||||||
|
{-# LINE 176 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect
|
||||||
|
{-# LINE 177 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap
|
||||||
|
{-# LINE 178 "GLX.chs" #-}
|
||||||
|
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor
|
||||||
|
{-# LINE 179 "GLX.chs" #-}
|
||||||
|
|
||||||
|
nullSetWindowAttributes :: XSetWindowAttributes
|
||||||
|
nullSetWindowAttributes = (XSetWindowAttributes 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 XSetWindowAttributes -> IO Window
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
foreign import ccall unsafe "GL/glx.h glXChooseFBConfig"
|
||||||
|
glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr GLXFBConfig)
|
||||||
|
|
||||||
|
chooseFBConfig :: Display -> CInt -> [(CInt, CInt)] -> IO [GLXFBConfig]
|
||||||
|
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
|
||||||
|
peekArray (fromIntegral nelements) configs
|
||||||
|
|
||||||
|
glxRenderType :: CInt
|
||||||
|
glxRenderType = (32785)
|
||||||
|
{-# LINE 205 "GLX.chs" #-}
|
||||||
|
|
||||||
|
glxRgbaBit :: CInt
|
||||||
|
glxRgbaBit = (1)
|
||||||
|
{-# LINE 208 "GLX.chs" #-}
|
||||||
|
|
||||||
|
glxDrawableType :: CInt
|
||||||
|
glxDrawableType = (32784)
|
||||||
|
{-# LINE 211 "GLX.chs" #-}
|
||||||
|
|
||||||
|
glxWindowBit :: CInt
|
||||||
|
glxWindowBit = (1)
|
||||||
|
{-# LINE 214 "GLX.chs" #-}
|
||||||
|
|
||||||
|
glxXRenderable :: CInt
|
||||||
|
glxXRenderable = (32786)
|
||||||
|
{-# LINE 217 "GLX.chs" #-}
|
||||||
|
|
||||||
|
glxDoublebuffer :: CInt
|
||||||
|
glxDoublebuffer = (5)
|
||||||
|
{-# LINE 220 "GLX.chs" #-}
|
||||||
|
|
||||||
|
glxDepthSize :: CInt
|
||||||
|
glxDepthSize = (12)
|
||||||
|
{-# LINE 223 "GLX.chs" #-}
|
||||||
|
|
||||||
|
glxStencilSize :: CInt
|
||||||
|
glxStencilSize = (13)
|
||||||
|
{-# LINE 226 "GLX.chs" #-}
|
||||||
|
|
||||||
|
glxTrue :: CInt
|
||||||
|
glxTrue = (1)
|
||||||
|
{-# LINE 229 "GLX.chs" #-}
|
||||||
|
|
||||||
|
foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
|
||||||
|
glXGetVisualFromFBConfig :: Display -> GLXFBConfig -> IO (Ptr XVisualInfo)
|
||||||
|
|
||||||
|
getVisualFromFBConfig :: Display -> GLXFBConfig -> IO (XVisualInfo)
|
||||||
|
getVisualFromFBConfig disp config = do
|
||||||
|
vi <- glXGetVisualFromFBConfig disp config
|
||||||
|
peek vi
|
||||||
|
|
||||||
|
foreign import ccall unsafe "GL/glx.h glXCreateContext"
|
||||||
|
glXCreateContext :: Display -> Ptr XVisualInfo -> GLXContext -> Bool -> IO GLXContext
|
||||||
|
|
||||||
|
foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
|
||||||
|
glXMakeCurrent :: Display -> XID -> GLXContext -> IO Bool
|
||||||
25
GLDriver.hs
Normal file
25
GLDriver.hs
Normal file
|
|
@ -0,0 +1,25 @@
|
||||||
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
|
|
||||||
|
module GLDriver ( GLDriver(..)
|
||||||
|
, Event
|
||||||
|
, SomeEvent(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Typeable
|
||||||
|
|
||||||
|
|
||||||
|
class GLDriver a where
|
||||||
|
initialized :: a -> Bool
|
||||||
|
|
||||||
|
initGL :: a -> IO a
|
||||||
|
deinitGL :: a -> IO ()
|
||||||
|
|
||||||
|
nextEvent :: a -> IO (Maybe SomeEvent)
|
||||||
|
|
||||||
|
|
||||||
|
class Typeable a => Event a
|
||||||
|
|
||||||
|
data SomeEvent = forall a. Event a => SomeEvent a
|
||||||
|
|
||||||
|
fromEvent :: Event a => SomeEvent -> Maybe a
|
||||||
|
fromEvent (SomeEvent a) = cast a
|
||||||
74
GLX.hs
Normal file
74
GLX.hs
Normal file
|
|
@ -0,0 +1,74 @@
|
||||||
|
module GLX ( glxDriver
|
||||||
|
) where
|
||||||
|
|
||||||
|
import GLDriver
|
||||||
|
import Bindings.GLX
|
||||||
|
|
||||||
|
import Control.Monad (when, unless)
|
||||||
|
|
||||||
|
import Data.Bits ((.|.))
|
||||||
|
|
||||||
|
import Graphics.X11.Types
|
||||||
|
import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow)
|
||||||
|
import Graphics.X11.Xlib.Event (allocaXEvent, nextEvent, get_Window, get_EventType)
|
||||||
|
import Graphics.X11.Xlib.Types
|
||||||
|
import Graphics.X11.Xlib.Window (mapWindow)
|
||||||
|
|
||||||
|
import Foreign.Marshal.Utils (with)
|
||||||
|
import Foreign.Ptr
|
||||||
|
import Foreign.Storable
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
data GLX = GLX Bool
|
||||||
|
|
||||||
|
glxDriver :: GLX
|
||||||
|
glxDriver = GLX False
|
||||||
|
|
||||||
|
|
||||||
|
instance GLDriver GLX where
|
||||||
|
initialized (GLX inited) = inited
|
||||||
|
|
||||||
|
initGL (GLX inited) = do
|
||||||
|
when (inited) $ fail "GLX already initialized"
|
||||||
|
|
||||||
|
disp <- openDisplay ""
|
||||||
|
fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp)
|
||||||
|
[(glxRenderType, glxRgbaBit)
|
||||||
|
, (glxDrawableType, glxWindowBit)
|
||||||
|
, (glxXRenderable, glxTrue)
|
||||||
|
, (glxDepthSize, 1)
|
||||||
|
, (glxStencilSize, 1)
|
||||||
|
]
|
||||||
|
visualinfo <- getVisualFromFBConfig disp (head fbconfigs)
|
||||||
|
rootwindow <- rootWindow disp (fromIntegral $ vi_screen visualinfo)
|
||||||
|
cmap <- createColormap disp rootwindow (vi_visual visualinfo) allocNone
|
||||||
|
|
||||||
|
let swa = nullSetWindowAttributes {swa_colormap = cmap, swa_event_mask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask}
|
||||||
|
|
||||||
|
wnd <- with swa $ \swaptr -> createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ vi_depth visualinfo) inputOutput (vi_visual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr
|
||||||
|
mapWindow disp wnd
|
||||||
|
|
||||||
|
waitForMapNotify disp wnd
|
||||||
|
|
||||||
|
ctx <- with visualinfo $ \vi -> glXCreateContext disp vi (GLXContext nullPtr) True
|
||||||
|
glXMakeCurrent disp wnd ctx
|
||||||
|
|
||||||
|
return (GLX True)
|
||||||
|
|
||||||
|
deinitGL _ = return ()
|
||||||
|
|
||||||
|
nextEvent _ = return Nothing
|
||||||
|
|
||||||
|
|
||||||
|
waitForMapNotify :: Display -> Window -> IO ()
|
||||||
|
waitForMapNotify disp wnd = allocaXEvent waitForMapNotify'
|
||||||
|
where
|
||||||
|
waitForMapNotify' event = do
|
||||||
|
Graphics.X11.Xlib.Event.nextEvent disp event
|
||||||
|
window <- get_Window event
|
||||||
|
eventType <- get_EventType event
|
||||||
|
unless (window == wnd && eventType == mapNotify) $
|
||||||
|
waitForMapNotify' event
|
||||||
|
|
||||||
|
|
||||||
25
Game.hs
Normal file
25
Game.hs
Normal file
|
|
@ -0,0 +1,25 @@
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
module Game ( GameState(..)
|
||||||
|
, Game
|
||||||
|
, runGame
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Level
|
||||||
|
import Tank
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.State
|
||||||
|
|
||||||
|
|
||||||
|
data GameState = GameState
|
||||||
|
{ level :: !Level
|
||||||
|
, tanks :: ![Tank]
|
||||||
|
} deriving (Show)
|
||||||
|
|
||||||
|
|
||||||
|
newtype Game a = Game (StateT GameState IO a)
|
||||||
|
deriving (Monad, MonadIO, MonadState GameState)
|
||||||
|
|
||||||
|
runGame :: GameState -> Game a -> IO (a, GameState)
|
||||||
|
runGame st (Game a) = runStateT a st
|
||||||
24
HTanks.hs
Normal file
24
HTanks.hs
Normal file
|
|
@ -0,0 +1,24 @@
|
||||||
|
import Game
|
||||||
|
import Level
|
||||||
|
import Tank
|
||||||
|
import Control.Monad.State
|
||||||
|
|
||||||
|
import GLDriver
|
||||||
|
import GLX
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
glxContext <- initGL glxDriver
|
||||||
|
|
||||||
|
let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]}
|
||||||
|
|
||||||
|
(_, gameState) <- runGame gameState mainLoop
|
||||||
|
print $ tanks gameState
|
||||||
|
|
||||||
|
mainLoop :: Game ()
|
||||||
|
mainLoop = do
|
||||||
|
(tank:_) <- gets tanks
|
||||||
|
let newtank = tank {posx = 1 + posx tank}
|
||||||
|
modify $ \game -> game {tanks = newtank:(tail $ tanks game)}
|
||||||
|
gets tanks >>= \t -> liftIO $ print t
|
||||||
|
when (posx newtank < 10) mainLoop
|
||||||
18
Level.hs
Normal file
18
Level.hs
Normal file
|
|
@ -0,0 +1,18 @@
|
||||||
|
module Level ( Level(..)
|
||||||
|
, testLevel
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.List
|
||||||
|
|
||||||
|
data Level = Level
|
||||||
|
{ floorTiles :: ![[Int]]
|
||||||
|
, objectTiles :: ![[Int]]
|
||||||
|
} deriving (Show)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
testLevel :: Level
|
||||||
|
testLevel = Level
|
||||||
|
{ floorTiles = replicate 10 $ replicate 10 0
|
||||||
|
, objectTiles = replicate 10 $ replicate 10 0
|
||||||
|
}
|
||||||
8
Tank.hs
Normal file
8
Tank.hs
Normal file
|
|
@ -0,0 +1,8 @@
|
||||||
|
module Tank ( Tank(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
data Tank = Tank
|
||||||
|
{ posx :: !Float
|
||||||
|
, posy :: !Float
|
||||||
|
, dir :: !Float
|
||||||
|
} deriving Show
|
||||||
Reference in a new issue