diff options
| -rw-r--r-- | .gitignore | 6 | ||||
| -rw-r--r-- | Bindings/GLX.chs | 242 | ||||
| -rw-r--r-- | Bindings/GLX.hs | 305 | ||||
| -rw-r--r-- | GLDriver.hs | 25 | ||||
| -rw-r--r-- | GLX.hs | 74 | ||||
| -rw-r--r-- | Game.hs | 25 | ||||
| -rw-r--r-- | HTanks.hs | 24 | ||||
| -rw-r--r-- | Level.hs | 18 | ||||
| -rw-r--r-- | Tank.hs | 8 |
9 files changed, 727 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ad959f0 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*.hi +*.o +*~ +*.chs.h + +HTanks diff --git a/Bindings/GLX.chs b/Bindings/GLX.chs new file mode 100644 index 0000000..5f544ca --- /dev/null +++ b/Bindings/GLX.chs @@ -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 diff --git a/Bindings/GLX.hs b/Bindings/GLX.hs new file mode 100644 index 0000000..725b1a4 --- /dev/null +++ b/Bindings/GLX.hs @@ -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 diff --git a/GLDriver.hs b/GLDriver.hs new file mode 100644 index 0000000..e527d09 --- /dev/null +++ b/GLDriver.hs @@ -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 @@ -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 + +
\ No newline at end of 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 diff --git a/HTanks.hs b/HTanks.hs new file mode 100644 index 0000000..cf3aae0 --- /dev/null +++ b/HTanks.hs @@ -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 diff --git a/Level.hs b/Level.hs new file mode 100644 index 0000000..c18104e --- /dev/null +++ b/Level.hs @@ -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 + }
\ No newline at end of file @@ -0,0 +1,8 @@ +module Tank ( Tank(..) + ) where + +data Tank = Tank + { posx :: !Float + , posy :: !Float + , dir :: !Float + } deriving Show |