neocturne/htanks
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added simple main loop

Browse source
This commit is contained in:
Matthias Schiffer 2010-02-22 18:27:18 +01:00
parent 62fe58cb55
commit 465bf68345
5 changed files with 197 additions and 177 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

152
Bindings/GLX.chs
View file

@ -4,22 +4,22 @@ module Bindings.GLX ( createColormap
, createWindow , createWindow
, chooseFBConfig , chooseFBConfig
, getVisualFromFBConfig , getVisualFromFBConfig
, XVisualInfo(..) , VisualInfo(..)
, XSetWindowAttributes(..) , SetWindowAttributes(..)
, nullSetWindowAttributes , nullSetWindowAttributes
, glXGetVisualFromFBConfig , getVisualFromFBConfig
, glxRenderType , renderType
, glxRgbaBit , rgbaBit
, glxDrawableType , drawableType
, glxWindowBit , windowBit
, glxXRenderable , xRenderable
, glxDoublebuffer , doublebuffer
, glxDepthSize , depthSize
, glxStencilSize , stencilSize
, glxTrue , true
, glXCreateContext , createContext
, glXMakeCurrent , makeCurrent
, GLXContext(..) , Context(..)
) where ) where
import Data.Generics import Data.Generics
@ -40,29 +40,29 @@ import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
#include <GL/glx.h> #include <GL/glx.h>
newtype GLXFBConfig = GLXFBConfig (Ptr GLXFBConfig) newtype FBConfig = FBConfig (Ptr FBConfig)
deriving (Eq, Ord, Show, Typeable, Data, Storable) deriving (Eq, Ord, Show, Typeable, Data, Storable)
newtype GLXContext = GLXContext (Ptr GLXContext) newtype Context = Context (Ptr Context)
deriving (Eq, Ord, Show, Typeable, Data, Storable) deriving (Eq, Ord, Show, Typeable, Data, Storable)
newtype Visual = Visual (Ptr Visual) newtype Visual = Visual (Ptr Visual)
deriving (Eq, Ord, Show, Typeable, Data, Storable) deriving (Eq, Ord, Show, Typeable, Data, Storable)
data XVisualInfo = XVisualInfo data VisualInfo = VisualInfo
{ vi_visual :: !Visual { viVisual :: !Visual
, vi_visualid :: !VisualID , viVisualid :: !VisualID
, vi_screen :: !CInt , viScreen :: !CInt
, vi_depth :: !CInt , viDepth :: !CInt
, vi_class :: !CInt , viClass :: !CInt
, vi_red_mask :: !CULong , viRedMask :: !CULong
, vi_green_mask :: !CULong , viGreenMask :: !CULong
, vi_blue_mask :: !CULong , viBlueMask :: !CULong
, vi_colormap_size :: !CInt , viColormapSize :: !CInt
, vi_bits_per_rgb :: !CInt , viBitsPerRgb :: !CInt
} deriving (Eq, Ord, Show, Typeable) } deriving (Eq, Ord, Show, Typeable)
instance Storable XVisualInfo where instance Storable VisualInfo where
sizeOf _ = (#size XVisualInfo) sizeOf _ = (#size XVisualInfo)
alignment _ = alignment (undefined :: CULong) alignment _ = alignment (undefined :: CULong)
@ -78,10 +78,10 @@ instance Storable XVisualInfo where
colormap_size <- (#peek XVisualInfo, colormap_size) vi colormap_size <- (#peek XVisualInfo, colormap_size) vi
bits_per_rgb <- (#peek XVisualInfo, bits_per_rgb) 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, visual) vi visual
(#poke XVisualInfo, visualid) vi visualid (#poke XVisualInfo, visualid) vi visualid
(#poke XVisualInfo, screen) vi screen (#poke XVisualInfo, screen) vi screen
@ -94,24 +94,24 @@ instance Storable XVisualInfo where
(#poke XVisualInfo, bits_per_rgb) vi bits_per_rgb (#poke XVisualInfo, bits_per_rgb) vi bits_per_rgb
data XSetWindowAttributes = XSetWindowAttributes data SetWindowAttributes = SetWindowAttributes
{ swa_background_pixmap :: !Pixmap { swaBackgroundPixmap :: !Pixmap
, swa_packground_pixel :: !Pixel , swaBackgroundPixel :: !Pixel
, swa_border_pixmap :: !Pixmap , swaBorderPixmap :: !Pixmap
, swa_bit_gravity :: !CInt , swaBitGravity :: !CInt
, swa_win_gravity :: !CInt , swaWinGravity :: !CInt
, swa_backing_store :: !CInt , swaBackingStore :: !CInt
, swa_backing_planes :: !CULong , swaBackingPlanes :: !CULong
, swa_backing_pixel :: !CULong , swaBackingPixel :: !CULong
, swa_save_under :: !Bool , swaSaveUnder :: !Bool
, swa_event_mask :: !EventMask , swaEventMask :: !EventMask
, swa_do_not_propagate_mask :: !CULong , swaDoNotPropagateMask :: !CULong
, swa_override_redirect :: !Bool , swaOverrideRedirect :: !Bool
, swa_colormap :: !Colormap , swaColormap :: !Colormap
, swa_cursor :: !Cursor , swaCursor :: !Cursor
} deriving (Eq, Ord, Show, Typeable) } deriving (Eq, Ord, Show, Typeable)
instance Storable XSetWindowAttributes where instance Storable SetWindowAttributes where
sizeOf _ = (#size XSetWindowAttributes) sizeOf _ = (#size XSetWindowAttributes)
alignment _ = alignment (undefined :: CULong) alignment _ = alignment (undefined :: CULong)
@ -131,7 +131,7 @@ instance Storable XSetWindowAttributes where
colormap <- (#peek XSetWindowAttributes, colormap) swa colormap <- (#peek XSetWindowAttributes, colormap) swa
cursor <- (#peek XSetWindowAttributes, cursor) swa cursor <- (#peek XSetWindowAttributes, cursor) swa
return (XSetWindowAttributes return (SetWindowAttributes
background_pixmap background_pixmap
background_pixel background_pixel
border_pixmap border_pixmap
@ -147,7 +147,7 @@ instance Storable XSetWindowAttributes where
colormap colormap
cursor) cursor)
poke swa (XSetWindowAttributes poke swa (SetWindowAttributes
background_pixmap background_pixmap
background_pixel background_pixel
border_pixmap border_pixmap
@ -177,8 +177,8 @@ instance Storable XSetWindowAttributes where
(#poke XSetWindowAttributes, colormap) swa colormap (#poke XSetWindowAttributes, colormap) swa colormap
(#poke XSetWindowAttributes, cursor) swa cursor (#poke XSetWindowAttributes, cursor) swa cursor
nullSetWindowAttributes :: XSetWindowAttributes nullSetWindowAttributes :: SetWindowAttributes
nullSetWindowAttributes = (XSetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0) nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0)
foreign import ccall unsafe "GL/glx.h XCreateColormap" 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" foreign import ccall unsafe "GL/glx.h XCreateWindow"
createWindow :: Display -> Window -> Position -> Position -> createWindow :: Display -> Window -> Position -> Position ->
Dimension -> Dimension -> CInt -> CInt -> WindowClass -> 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" 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 chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (concatMap (\(a,b) -> [a,b]) attr) $ \attrp -> do
configs <- glXChooseFBConfig disp sc attrp n configs <- glXChooseFBConfig disp sc attrp n
nelements <- peek n nelements <- peek n
peekArray (fromIntegral nelements) configs peekArray (fromIntegral nelements) configs
glxRenderType :: CInt renderType :: CInt
glxRenderType = (#const GLX_RENDER_TYPE) renderType = (#const GLX_RENDER_TYPE)
glxRgbaBit :: CInt rgbaBit :: CInt
glxRgbaBit = (#const GLX_RGBA_BIT) rgbaBit = (#const GLX_RGBA_BIT)
glxDrawableType :: CInt drawableType :: CInt
glxDrawableType = (#const GLX_DRAWABLE_TYPE) drawableType = (#const GLX_DRAWABLE_TYPE)
glxWindowBit :: CInt windowBit :: CInt
glxWindowBit = (#const GLX_WINDOW_BIT) windowBit = (#const GLX_WINDOW_BIT)
glxXRenderable :: CInt xRenderable :: CInt
glxXRenderable = (#const GLX_X_RENDERABLE) xRenderable = (#const GLX_X_RENDERABLE)
glxDoublebuffer :: CInt doublebuffer :: CInt
glxDoublebuffer = (#const GLX_DOUBLEBUFFER) doublebuffer = (#const GLX_DOUBLEBUFFER)
glxDepthSize :: CInt depthSize :: CInt
glxDepthSize = (#const GLX_DEPTH_SIZE) depthSize = (#const GLX_DEPTH_SIZE)
glxStencilSize :: CInt stencilSize :: CInt
glxStencilSize = (#const GLX_STENCIL_SIZE) stencilSize = (#const GLX_STENCIL_SIZE)
glxTrue :: CInt true :: CInt
glxTrue = (#const True) true = (#const True)
foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig" 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 getVisualFromFBConfig disp config = do
vi <- glXGetVisualFromFBConfig disp config vi <- glXGetVisualFromFBConfig disp config
peek vi peek vi
foreign import ccall unsafe "GL/glx.h glXCreateContext" 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" foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
glXMakeCurrent :: Display -> XID -> GLXContext -> IO Bool makeCurrent :: Display -> XID -> Context -> IO Bool

152
Bindings/GLX.hs
View file

@ -7,22 +7,22 @@ module Bindings.GLX ( createColormap
, createWindow , createWindow
, chooseFBConfig , chooseFBConfig
, getVisualFromFBConfig , getVisualFromFBConfig
, XVisualInfo(..) , VisualInfo(..)
, XSetWindowAttributes(..) , SetWindowAttributes(..)
, nullSetWindowAttributes , nullSetWindowAttributes
, glXGetVisualFromFBConfig , getVisualFromFBConfig
, glxRenderType , renderType
, glxRgbaBit , rgbaBit
, glxDrawableType , drawableType
, glxWindowBit , windowBit
, glxXRenderable , xRenderable
, glxDoublebuffer , doublebuffer
, glxDepthSize , depthSize
, glxStencilSize , stencilSize
, glxTrue , true
, glXCreateContext , createContext
, glXMakeCurrent , makeCurrent
, GLXContext(..) , Context(..)
) where ) where
import Data.Generics import Data.Generics
@ -44,29 +44,29 @@ import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
{-# LINE 41 "GLX.chs" #-} {-# LINE 41 "GLX.chs" #-}
newtype GLXFBConfig = GLXFBConfig (Ptr GLXFBConfig) newtype FBConfig = FBConfig (Ptr FBConfig)
deriving (Eq, Ord, Show, Typeable, Data, Storable) deriving (Eq, Ord, Show, Typeable, Data, Storable)
newtype GLXContext = GLXContext (Ptr GLXContext) newtype Context = Context (Ptr Context)
deriving (Eq, Ord, Show, Typeable, Data, Storable) deriving (Eq, Ord, Show, Typeable, Data, Storable)
newtype Visual = Visual (Ptr Visual) newtype Visual = Visual (Ptr Visual)
deriving (Eq, Ord, Show, Typeable, Data, Storable) deriving (Eq, Ord, Show, Typeable, Data, Storable)
data XVisualInfo = XVisualInfo data VisualInfo = VisualInfo
{ vi_visual :: !Visual { viVisual :: !Visual
, vi_visualid :: !VisualID , viVisualid :: !VisualID
, vi_screen :: !CInt , viScreen :: !CInt
, vi_depth :: !CInt , viDepth :: !CInt
, vi_class :: !CInt , viClass :: !CInt
, vi_red_mask :: !CULong , viRedMask :: !CULong
, vi_green_mask :: !CULong , viGreenMask :: !CULong
, vi_blue_mask :: !CULong , viBlueMask :: !CULong
, vi_colormap_size :: !CInt , viColormapSize :: !CInt
, vi_bits_per_rgb :: !CInt , viBitsPerRgb :: !CInt
} deriving (Eq, Ord, Show, Typeable) } deriving (Eq, Ord, Show, Typeable)
instance Storable XVisualInfo where instance Storable VisualInfo where
sizeOf _ = ((40)) sizeOf _ = ((40))
{-# LINE 67 "GLX.chs" #-} {-# LINE 67 "GLX.chs" #-}
alignment _ = alignment (undefined :: CULong) alignment _ = alignment (undefined :: CULong)
@ -93,10 +93,10 @@ instance Storable XVisualInfo where
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi
{-# LINE 80 "GLX.chs" #-} {-# 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 ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) vi visual
{-# LINE 86 "GLX.chs" #-} {-# LINE 86 "GLX.chs" #-}
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
@ -119,24 +119,24 @@ instance Storable XVisualInfo where
{-# LINE 95 "GLX.chs" #-} {-# LINE 95 "GLX.chs" #-}
data XSetWindowAttributes = XSetWindowAttributes data SetWindowAttributes = SetWindowAttributes
{ swa_background_pixmap :: !Pixmap { swaBackgroundPixmap :: !Pixmap
, swa_packground_pixel :: !Pixel , swaBackgroundPixel :: !Pixel
, swa_border_pixmap :: !Pixmap , swaBorderPixmap :: !Pixmap
, swa_bit_gravity :: !CInt , swaBitGravity :: !CInt
, swa_win_gravity :: !CInt , swaWinGravity :: !CInt
, swa_backing_store :: !CInt , swaBackingStore :: !CInt
, swa_backing_planes :: !CULong , swaBackingPlanes :: !CULong
, swa_backing_pixel :: !CULong , swaBackingPixel :: !CULong
, swa_save_under :: !Bool , swaSaveUnder :: !Bool
, swa_event_mask :: !EventMask , swaEventMask :: !EventMask
, swa_do_not_propagate_mask :: !CULong , swaDoNotPropagateMask :: !CULong
, swa_override_redirect :: !Bool , swaOverrideRedirect :: !Bool
, swa_colormap :: !Colormap , swaColormap :: !Colormap
, swa_cursor :: !Cursor , swaCursor :: !Cursor
} deriving (Eq, Ord, Show, Typeable) } deriving (Eq, Ord, Show, Typeable)
instance Storable XSetWindowAttributes where instance Storable SetWindowAttributes where
sizeOf _ = ((60)) sizeOf _ = ((60))
{-# LINE 116 "GLX.chs" #-} {-# LINE 116 "GLX.chs" #-}
alignment _ = alignment (undefined :: CULong) alignment _ = alignment (undefined :: CULong)
@ -171,7 +171,7 @@ instance Storable XSetWindowAttributes where
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
{-# LINE 133 "GLX.chs" #-} {-# LINE 133 "GLX.chs" #-}
return (XSetWindowAttributes return (SetWindowAttributes
background_pixmap background_pixmap
background_pixel background_pixel
border_pixmap border_pixmap
@ -187,7 +187,7 @@ instance Storable XSetWindowAttributes where
colormap colormap
cursor) cursor)
poke swa (XSetWindowAttributes poke swa (SetWindowAttributes
background_pixmap background_pixmap
background_pixel background_pixel
border_pixmap border_pixmap
@ -231,8 +231,8 @@ instance Storable XSetWindowAttributes where
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor ((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor
{-# LINE 179 "GLX.chs" #-} {-# LINE 179 "GLX.chs" #-}
nullSetWindowAttributes :: XSetWindowAttributes nullSetWindowAttributes :: SetWindowAttributes
nullSetWindowAttributes = (XSetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0) nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0)
foreign import ccall unsafe "GL/glx.h XCreateColormap" 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" foreign import ccall unsafe "GL/glx.h XCreateWindow"
createWindow :: Display -> Window -> Position -> Position -> createWindow :: Display -> Window -> Position -> Position ->
Dimension -> Dimension -> CInt -> CInt -> WindowClass -> 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" 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 chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (concatMap (\(a,b) -> [a,b]) attr) $ \attrp -> do
configs <- glXChooseFBConfig disp sc attrp n configs <- glXChooseFBConfig disp sc attrp n
nelements <- peek n nelements <- peek n
peekArray (fromIntegral nelements) configs peekArray (fromIntegral nelements) configs
glxRenderType :: CInt renderType :: CInt
glxRenderType = (32785) renderType = (32785)
{-# LINE 205 "GLX.chs" #-} {-# LINE 205 "GLX.chs" #-}
glxRgbaBit :: CInt rgbaBit :: CInt
glxRgbaBit = (1) rgbaBit = (1)
{-# LINE 208 "GLX.chs" #-} {-# LINE 208 "GLX.chs" #-}
glxDrawableType :: CInt drawableType :: CInt
glxDrawableType = (32784) drawableType = (32784)
{-# LINE 211 "GLX.chs" #-} {-# LINE 211 "GLX.chs" #-}
glxWindowBit :: CInt windowBit :: CInt
glxWindowBit = (1) windowBit = (1)
{-# LINE 214 "GLX.chs" #-} {-# LINE 214 "GLX.chs" #-}
glxXRenderable :: CInt xRenderable :: CInt
glxXRenderable = (32786) xRenderable = (32786)
{-# LINE 217 "GLX.chs" #-} {-# LINE 217 "GLX.chs" #-}
glxDoublebuffer :: CInt doublebuffer :: CInt
glxDoublebuffer = (5) doublebuffer = (5)
{-# LINE 220 "GLX.chs" #-} {-# LINE 220 "GLX.chs" #-}
glxDepthSize :: CInt depthSize :: CInt
glxDepthSize = (12) depthSize = (12)
{-# LINE 223 "GLX.chs" #-} {-# LINE 223 "GLX.chs" #-}
glxStencilSize :: CInt stencilSize :: CInt
glxStencilSize = (13) stencilSize = (13)
{-# LINE 226 "GLX.chs" #-} {-# LINE 226 "GLX.chs" #-}
glxTrue :: CInt true :: CInt
glxTrue = (1) true = (1)
{-# LINE 229 "GLX.chs" #-} {-# LINE 229 "GLX.chs" #-}
foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig" 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 getVisualFromFBConfig disp config = do
vi <- glXGetVisualFromFBConfig disp config vi <- glXGetVisualFromFBConfig disp config
peek vi peek vi
foreign import ccall unsafe "GL/glx.h glXCreateContext" 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" foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
glXMakeCurrent :: Display -> XID -> GLXContext -> IO Bool makeCurrent :: Display -> XID -> Context -> IO Bool

12
GLDriver.hs
View file

@ -1,14 +1,15 @@
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
module GLDriver ( GLDriver(..) module GLDriver ( Driver(..)
, Event , Event
, SomeEvent(..) , SomeEvent(..)
, QuitEvent
) where ) where
import Data.Typeable import Data.Typeable
class GLDriver a where class Driver a where
initialized :: a -> Bool initialized :: a -> Bool
initGL :: a -> IO a initGL :: a -> IO a
@ -23,3 +24,8 @@ data SomeEvent = forall a. Event a => SomeEvent a
fromEvent :: Event a => SomeEvent -> Maybe a fromEvent :: Event a => SomeEvent -> Maybe a
fromEvent (SomeEvent a) = cast a fromEvent (SomeEvent a) = cast a
data QuitEvent = QuitEvent deriving Typeable
instance Event QuitEvent

24
GLX.hs
View file

@ -26,7 +26,7 @@ glxDriver :: GLX
glxDriver = GLX False glxDriver = GLX False
instance GLDriver GLX where instance Driver GLX where
initialized (GLX inited) = inited initialized (GLX inited) = inited
initGL (GLX inited) = do initGL (GLX inited) = do
@ -34,25 +34,25 @@ instance GLDriver GLX where
disp <- openDisplay "" disp <- openDisplay ""
fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp) fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp)
[(glxRenderType, glxRgbaBit) [(renderType, rgbaBit)
, (glxDrawableType, glxWindowBit) , (drawableType, windowBit)
, (glxXRenderable, glxTrue) , (xRenderable, true)
, (glxDepthSize, 1) , (depthSize, 1)
, (glxStencilSize, 1) , (stencilSize, 1)
] ]
visualinfo <- getVisualFromFBConfig disp (head fbconfigs) visualinfo <- getVisualFromFBConfig disp (head fbconfigs)
rootwindow <- rootWindow disp (fromIntegral $ vi_screen visualinfo) rootwindow <- rootWindow disp (fromIntegral $ viScreen visualinfo)
cmap <- createColormap disp rootwindow (vi_visual visualinfo) allocNone 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 mapWindow disp wnd
waitForMapNotify disp wnd waitForMapNotify disp wnd
ctx <- with visualinfo $ \vi -> glXCreateContext disp vi (GLXContext nullPtr) True ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
glXMakeCurrent disp wnd ctx makeCurrent disp wnd ctx
return (GLX True) return (GLX True)

34
HTanks.hs
View file

@ -1,24 +1,38 @@
import Game import Game
import Level import Level
import Tank import Tank
import Control.Monad.State
import GLDriver import GLDriver
import GLX import GLX
import Control.Concurrent (threadDelay)
import Control.Monad.State
import Data.Maybe
main :: IO () main :: IO ()
main = do main = do
glxContext <- initGL glxDriver gl <- initGL glxDriver
let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]} let gameState = GameState {level = testLevel, tanks = [Tank 0.5 0.5 0]}
(_, gameState) <- runGame gameState mainLoop (_, gameState) <- runGame gameState $ mainLoop gl
print $ tanks gameState print $ tanks gameState
mainLoop :: Game () mainLoop :: Driver a => a -> Game ()
mainLoop = do mainLoop gl = do
(tank:_) <- gets tanks run <- liftIO $ handleEvents gl
let newtank = tank {posx = 1 + posx tank} liftIO $ threadDelay 10000
modify $ \game -> game {tanks = newtank:(tail $ tanks game)} when run $ mainLoop gl
gets tanks >>= \t -> liftIO $ print t
when (posx newtank < 10) mainLoop 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