Added simple main loop
This commit is contained in:
Matthias Schiffer
parent
62fe58cb55
commit
465bf68345
5 changed files with 197 additions and 177 deletions
152
Bindings/GLX.chs
152
Bindings/GLX.chs
|
|
@ -4,22 +4,22 @@ module Bindings.GLX ( createColormap
|
|||
, createWindow
|
||||
, chooseFBConfig
|
||||
, getVisualFromFBConfig
|
||||
, XVisualInfo(..)
|
||||
, XSetWindowAttributes(..)
|
||||
, VisualInfo(..)
|
||||
, SetWindowAttributes(..)
|
||||
, nullSetWindowAttributes
|
||||
, glXGetVisualFromFBConfig
|
||||
, glxRenderType
|
||||
, glxRgbaBit
|
||||
, glxDrawableType
|
||||
, glxWindowBit
|
||||
, glxXRenderable
|
||||
, glxDoublebuffer
|
||||
, glxDepthSize
|
||||
, glxStencilSize
|
||||
, glxTrue
|
||||
, glXCreateContext
|
||||
, glXMakeCurrent
|
||||
, GLXContext(..)
|
||||
, getVisualFromFBConfig
|
||||
, renderType
|
||||
, rgbaBit
|
||||
, drawableType
|
||||
, windowBit
|
||||
, xRenderable
|
||||
, doublebuffer
|
||||
, depthSize
|
||||
, stencilSize
|
||||
, true
|
||||
, createContext
|
||||
, makeCurrent
|
||||
, Context(..)
|
||||
) where
|
||||
|
||||
import Data.Generics
|
||||
|
|
@ -40,29 +40,29 @@ import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
|
|||
#include <GL/glx.h>
|
||||
|
||||
|
||||
newtype GLXFBConfig = GLXFBConfig (Ptr GLXFBConfig)
|
||||
newtype FBConfig = FBConfig (Ptr FBConfig)
|
||||
deriving (Eq, Ord, Show, Typeable, Data, Storable)
|
||||
|
||||
newtype GLXContext = GLXContext (Ptr GLXContext)
|
||||
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 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
|
||||
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 XVisualInfo where
|
||||
instance Storable VisualInfo where
|
||||
sizeOf _ = (#size XVisualInfo)
|
||||
alignment _ = alignment (undefined :: CULong)
|
||||
|
||||
|
|
@ -78,10 +78,10 @@ instance Storable XVisualInfo where
|
|||
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)
|
||||
return (VisualInfo 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 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
|
||||
|
|
@ -94,24 +94,24 @@ instance Storable XVisualInfo where
|
|||
(#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
|
||||
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 XSetWindowAttributes where
|
||||
instance Storable SetWindowAttributes where
|
||||
sizeOf _ = (#size XSetWindowAttributes)
|
||||
alignment _ = alignment (undefined :: CULong)
|
||||
|
||||
|
|
@ -131,7 +131,7 @@ instance Storable XSetWindowAttributes where
|
|||
colormap <- (#peek XSetWindowAttributes, colormap) swa
|
||||
cursor <- (#peek XSetWindowAttributes, cursor) swa
|
||||
|
||||
return (XSetWindowAttributes
|
||||
return (SetWindowAttributes
|
||||
background_pixmap
|
||||
background_pixel
|
||||
border_pixmap
|
||||
|
|
@ -147,7 +147,7 @@ instance Storable XSetWindowAttributes where
|
|||
colormap
|
||||
cursor)
|
||||
|
||||
poke swa (XSetWindowAttributes
|
||||
poke swa (SetWindowAttributes
|
||||
background_pixmap
|
||||
background_pixel
|
||||
border_pixmap
|
||||
|
|
@ -177,8 +177,8 @@ instance Storable XSetWindowAttributes where
|
|||
(#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)
|
||||
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"
|
||||
|
|
@ -187,56 +187,56 @@ foreign import ccall unsafe "GL/glx.h XCreateColormap"
|
|||
foreign import ccall unsafe "GL/glx.h XCreateWindow"
|
||||
createWindow :: Display -> Window -> Position -> Position ->
|
||||
Dimension -> Dimension -> CInt -> CInt -> WindowClass ->
|
||||
Visual -> AttributeMask -> Ptr XSetWindowAttributes -> IO Window
|
||||
Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window
|
||||
|
||||
|
||||
|
||||
foreign import ccall unsafe "GL/glx.h glXChooseFBConfig"
|
||||
glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr GLXFBConfig)
|
||||
glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr FBConfig)
|
||||
|
||||
chooseFBConfig :: Display -> CInt -> [(CInt, CInt)] -> IO [GLXFBConfig]
|
||||
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
|
||||
peekArray (fromIntegral nelements) configs
|
||||
|
||||
glxRenderType :: CInt
|
||||
glxRenderType = (#const GLX_RENDER_TYPE)
|
||||
renderType :: CInt
|
||||
renderType = (#const GLX_RENDER_TYPE)
|
||||
|
||||
glxRgbaBit :: CInt
|
||||
glxRgbaBit = (#const GLX_RGBA_BIT)
|
||||
rgbaBit :: CInt
|
||||
rgbaBit = (#const GLX_RGBA_BIT)
|
||||
|
||||
glxDrawableType :: CInt
|
||||
glxDrawableType = (#const GLX_DRAWABLE_TYPE)
|
||||
drawableType :: CInt
|
||||
drawableType = (#const GLX_DRAWABLE_TYPE)
|
||||
|
||||
glxWindowBit :: CInt
|
||||
glxWindowBit = (#const GLX_WINDOW_BIT)
|
||||
windowBit :: CInt
|
||||
windowBit = (#const GLX_WINDOW_BIT)
|
||||
|
||||
glxXRenderable :: CInt
|
||||
glxXRenderable = (#const GLX_X_RENDERABLE)
|
||||
xRenderable :: CInt
|
||||
xRenderable = (#const GLX_X_RENDERABLE)
|
||||
|
||||
glxDoublebuffer :: CInt
|
||||
glxDoublebuffer = (#const GLX_DOUBLEBUFFER)
|
||||
doublebuffer :: CInt
|
||||
doublebuffer = (#const GLX_DOUBLEBUFFER)
|
||||
|
||||
glxDepthSize :: CInt
|
||||
glxDepthSize = (#const GLX_DEPTH_SIZE)
|
||||
depthSize :: CInt
|
||||
depthSize = (#const GLX_DEPTH_SIZE)
|
||||
|
||||
glxStencilSize :: CInt
|
||||
glxStencilSize = (#const GLX_STENCIL_SIZE)
|
||||
stencilSize :: CInt
|
||||
stencilSize = (#const GLX_STENCIL_SIZE)
|
||||
|
||||
glxTrue :: CInt
|
||||
glxTrue = (#const True)
|
||||
true :: CInt
|
||||
true = (#const True)
|
||||
|
||||
foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
|
||||
glXGetVisualFromFBConfig :: Display -> GLXFBConfig -> IO (Ptr XVisualInfo)
|
||||
glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo)
|
||||
|
||||
getVisualFromFBConfig :: Display -> GLXFBConfig -> IO (XVisualInfo)
|
||||
getVisualFromFBConfig :: Display -> FBConfig -> IO (VisualInfo)
|
||||
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
|
||||
createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context
|
||||
|
||||
foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
|
||||
glXMakeCurrent :: Display -> XID -> GLXContext -> IO Bool
|
||||
makeCurrent :: Display -> XID -> Context -> IO Bool
|
||||
|
|
|
|||
152
Bindings/GLX.hs
152
Bindings/GLX.hs
|
|
@ -7,22 +7,22 @@ module Bindings.GLX ( createColormap
|
|||
, createWindow
|
||||
, chooseFBConfig
|
||||
, getVisualFromFBConfig
|
||||
, XVisualInfo(..)
|
||||
, XSetWindowAttributes(..)
|
||||
, VisualInfo(..)
|
||||
, SetWindowAttributes(..)
|
||||
, nullSetWindowAttributes
|
||||
, glXGetVisualFromFBConfig
|
||||
, glxRenderType
|
||||
, glxRgbaBit
|
||||
, glxDrawableType
|
||||
, glxWindowBit
|
||||
, glxXRenderable
|
||||
, glxDoublebuffer
|
||||
, glxDepthSize
|
||||
, glxStencilSize
|
||||
, glxTrue
|
||||
, glXCreateContext
|
||||
, glXMakeCurrent
|
||||
, GLXContext(..)
|
||||
, getVisualFromFBConfig
|
||||
, renderType
|
||||
, rgbaBit
|
||||
, drawableType
|
||||
, windowBit
|
||||
, xRenderable
|
||||
, doublebuffer
|
||||
, depthSize
|
||||
, stencilSize
|
||||
, true
|
||||
, createContext
|
||||
, makeCurrent
|
||||
, Context(..)
|
||||
) where
|
||||
|
||||
import Data.Generics
|
||||
|
|
@ -44,29 +44,29 @@ import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
|
|||
{-# LINE 41 "GLX.chs" #-}
|
||||
|
||||
|
||||
newtype GLXFBConfig = GLXFBConfig (Ptr GLXFBConfig)
|
||||
newtype FBConfig = FBConfig (Ptr FBConfig)
|
||||
deriving (Eq, Ord, Show, Typeable, Data, Storable)
|
||||
|
||||
newtype GLXContext = GLXContext (Ptr GLXContext)
|
||||
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 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
|
||||
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 XVisualInfo where
|
||||
instance Storable VisualInfo where
|
||||
sizeOf _ = ((40))
|
||||
{-# LINE 67 "GLX.chs" #-}
|
||||
alignment _ = alignment (undefined :: CULong)
|
||||
|
|
@ -93,10 +93,10 @@ instance Storable XVisualInfo where
|
|||
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)
|
||||
return (VisualInfo 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 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 86 "GLX.chs" #-}
|
||||
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
|
||||
|
|
@ -119,24 +119,24 @@ instance Storable XVisualInfo where
|
|||
{-# 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
|
||||
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 XSetWindowAttributes where
|
||||
instance Storable SetWindowAttributes where
|
||||
sizeOf _ = ((60))
|
||||
{-# LINE 116 "GLX.chs" #-}
|
||||
alignment _ = alignment (undefined :: CULong)
|
||||
|
|
@ -171,7 +171,7 @@ instance Storable XSetWindowAttributes where
|
|||
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
|
||||
{-# LINE 133 "GLX.chs" #-}
|
||||
|
||||
return (XSetWindowAttributes
|
||||
return (SetWindowAttributes
|
||||
background_pixmap
|
||||
background_pixel
|
||||
border_pixmap
|
||||
|
|
@ -187,7 +187,7 @@ instance Storable XSetWindowAttributes where
|
|||
colormap
|
||||
cursor)
|
||||
|
||||
poke swa (XSetWindowAttributes
|
||||
poke swa (SetWindowAttributes
|
||||
background_pixmap
|
||||
background_pixel
|
||||
border_pixmap
|
||||
|
|
@ -231,8 +231,8 @@ instance Storable XSetWindowAttributes where
|
|||
((\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)
|
||||
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"
|
||||
|
|
@ -241,65 +241,65 @@ foreign import ccall unsafe "GL/glx.h XCreateColormap"
|
|||
foreign import ccall unsafe "GL/glx.h XCreateWindow"
|
||||
createWindow :: Display -> Window -> Position -> Position ->
|
||||
Dimension -> Dimension -> CInt -> CInt -> WindowClass ->
|
||||
Visual -> AttributeMask -> Ptr XSetWindowAttributes -> IO Window
|
||||
Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window
|
||||
|
||||
|
||||
|
||||
foreign import ccall unsafe "GL/glx.h glXChooseFBConfig"
|
||||
glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr GLXFBConfig)
|
||||
glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr FBConfig)
|
||||
|
||||
chooseFBConfig :: Display -> CInt -> [(CInt, CInt)] -> IO [GLXFBConfig]
|
||||
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
|
||||
peekArray (fromIntegral nelements) configs
|
||||
|
||||
glxRenderType :: CInt
|
||||
glxRenderType = (32785)
|
||||
renderType :: CInt
|
||||
renderType = (32785)
|
||||
{-# LINE 205 "GLX.chs" #-}
|
||||
|
||||
glxRgbaBit :: CInt
|
||||
glxRgbaBit = (1)
|
||||
rgbaBit :: CInt
|
||||
rgbaBit = (1)
|
||||
{-# LINE 208 "GLX.chs" #-}
|
||||
|
||||
glxDrawableType :: CInt
|
||||
glxDrawableType = (32784)
|
||||
drawableType :: CInt
|
||||
drawableType = (32784)
|
||||
{-# LINE 211 "GLX.chs" #-}
|
||||
|
||||
glxWindowBit :: CInt
|
||||
glxWindowBit = (1)
|
||||
windowBit :: CInt
|
||||
windowBit = (1)
|
||||
{-# LINE 214 "GLX.chs" #-}
|
||||
|
||||
glxXRenderable :: CInt
|
||||
glxXRenderable = (32786)
|
||||
xRenderable :: CInt
|
||||
xRenderable = (32786)
|
||||
{-# LINE 217 "GLX.chs" #-}
|
||||
|
||||
glxDoublebuffer :: CInt
|
||||
glxDoublebuffer = (5)
|
||||
doublebuffer :: CInt
|
||||
doublebuffer = (5)
|
||||
{-# LINE 220 "GLX.chs" #-}
|
||||
|
||||
glxDepthSize :: CInt
|
||||
glxDepthSize = (12)
|
||||
depthSize :: CInt
|
||||
depthSize = (12)
|
||||
{-# LINE 223 "GLX.chs" #-}
|
||||
|
||||
glxStencilSize :: CInt
|
||||
glxStencilSize = (13)
|
||||
stencilSize :: CInt
|
||||
stencilSize = (13)
|
||||
{-# LINE 226 "GLX.chs" #-}
|
||||
|
||||
glxTrue :: CInt
|
||||
glxTrue = (1)
|
||||
true :: CInt
|
||||
true = (1)
|
||||
{-# LINE 229 "GLX.chs" #-}
|
||||
|
||||
foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
|
||||
glXGetVisualFromFBConfig :: Display -> GLXFBConfig -> IO (Ptr XVisualInfo)
|
||||
glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo)
|
||||
|
||||
getVisualFromFBConfig :: Display -> GLXFBConfig -> IO (XVisualInfo)
|
||||
getVisualFromFBConfig :: Display -> FBConfig -> IO (VisualInfo)
|
||||
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
|
||||
createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context
|
||||
|
||||
foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
|
||||
glXMakeCurrent :: Display -> XID -> GLXContext -> IO Bool
|
||||
makeCurrent :: Display -> XID -> Context -> IO Bool
|
||||
|
|
|
|||
12
GLDriver.hs
12
GLDriver.hs
|
|
@ -1,14 +1,15 @@
|
|||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
|
||||
|
||||
module GLDriver ( GLDriver(..)
|
||||
module GLDriver ( Driver(..)
|
||||
, Event
|
||||
, SomeEvent(..)
|
||||
, QuitEvent
|
||||
) where
|
||||
|
||||
import Data.Typeable
|
||||
|
||||
|
||||
class GLDriver a where
|
||||
class Driver a where
|
||||
initialized :: a -> Bool
|
||||
|
||||
initGL :: a -> IO a
|
||||
|
|
@ -23,3 +24,8 @@ data SomeEvent = forall a. Event a => SomeEvent a
|
|||
|
||||
fromEvent :: Event a => SomeEvent -> Maybe a
|
||||
fromEvent (SomeEvent a) = cast a
|
||||
|
||||
|
||||
data QuitEvent = QuitEvent deriving Typeable
|
||||
|
||||
instance Event QuitEvent
|
||||
24
GLX.hs
24
GLX.hs
|
|
@ -26,7 +26,7 @@ glxDriver :: GLX
|
|||
glxDriver = GLX False
|
||||
|
||||
|
||||
instance GLDriver GLX where
|
||||
instance Driver GLX where
|
||||
initialized (GLX inited) = inited
|
||||
|
||||
initGL (GLX inited) = do
|
||||
|
|
@ -34,25 +34,25 @@ instance GLDriver GLX where
|
|||
|
||||
disp <- openDisplay ""
|
||||
fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp)
|
||||
[(glxRenderType, glxRgbaBit)
|
||||
, (glxDrawableType, glxWindowBit)
|
||||
, (glxXRenderable, glxTrue)
|
||||
, (glxDepthSize, 1)
|
||||
, (glxStencilSize, 1)
|
||||
[(renderType, rgbaBit)
|
||||
, (drawableType, windowBit)
|
||||
, (xRenderable, true)
|
||||
, (depthSize, 1)
|
||||
, (stencilSize, 1)
|
||||
]
|
||||
visualinfo <- getVisualFromFBConfig disp (head fbconfigs)
|
||||
rootwindow <- rootWindow disp (fromIntegral $ vi_screen visualinfo)
|
||||
cmap <- createColormap disp rootwindow (vi_visual visualinfo) allocNone
|
||||
rootwindow <- rootWindow disp (fromIntegral $ viScreen visualinfo)
|
||||
cmap <- createColormap disp rootwindow (viVisual visualinfo) allocNone
|
||||
|
||||
let swa = nullSetWindowAttributes {swa_colormap = cmap, swa_event_mask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask}
|
||||
let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = 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
|
||||
wnd <- with swa $ \swaptr -> createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual 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
|
||||
ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
|
||||
makeCurrent disp wnd ctx
|
||||
|
||||
return (GLX True)
|
||||
|
||||
|
|
|
|||
34
HTanks.hs
34
HTanks.hs
|
|
@ -1,24 +1,38 @@
|
|||
import Game
|
||||
import Level
|
||||
import Tank
|
||||
import Control.Monad.State
|
||||
|
||||
import GLDriver
|
||||
import GLX
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Monad.State
|
||||
import Data.Maybe
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
glxContext <- initGL glxDriver
|
||||
gl <- initGL glxDriver
|
||||
|
||||
let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]}
|
||||
|
||||
(_, gameState) <- runGame gameState mainLoop
|
||||
(_, gameState) <- runGame gameState $ mainLoop gl
|
||||
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
|
||||
mainLoop :: Driver a => a -> Game ()
|
||||
mainLoop gl = do
|
||||
run <- liftIO $ handleEvents gl
|
||||
liftIO $ threadDelay 10000
|
||||
when run $ mainLoop gl
|
||||
|
||||
handleEvents :: Driver a => a -> IO Bool
|
||||
handleEvents gl = do
|
||||
event <- nextEvent gl
|
||||
if (isJust event)
|
||||
then
|
||||
handleEvent $ fromJust event
|
||||
else
|
||||
return True
|
||||
|
||||
handleEvent :: SomeEvent -> IO Bool
|
||||
handleEvent ev = return True
|
||||
Reference in a new issue