summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMatthias Schiffer <matthias@gamezock.de>2010-02-22 16:50:42 +0100
committerMatthias Schiffer <matthias@gamezock.de>2010-02-22 16:50:42 +0100
commit62fe58cb55a279c285980a313d4355d91e93601c (patch)
tree7e318f4b62c7f90b0fad5e267ec9c3194fae53c7
downloadhtanks-62fe58cb55a279c285980a313d4355d91e93601c.tar
htanks-62fe58cb55a279c285980a313d4355d91e93601c.zip
Initial commit
-rw-r--r--.gitignore6
-rw-r--r--Bindings/GLX.chs242
-rw-r--r--Bindings/GLX.hs305
-rw-r--r--GLDriver.hs25
-rw-r--r--GLX.hs74
-rw-r--r--Game.hs25
-rw-r--r--HTanks.hs24
-rw-r--r--Level.hs18
-rw-r--r--Tank.hs8
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
diff --git a/GLX.hs b/GLX.hs
new file mode 100644
index 0000000..3f806ac
--- /dev/null
+++ b/GLX.hs
@@ -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
diff --git a/Game.hs b/Game.hs
new file mode 100644
index 0000000..ef760d7
--- /dev/null
+++ b/Game.hs
@@ -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
diff --git a/Tank.hs b/Tank.hs
new file mode 100644
index 0000000..c5bf465
--- /dev/null
+++ b/Tank.hs
@@ -0,0 +1,8 @@
+module Tank ( Tank(..)
+ ) where
+
+data Tank = Tank
+ { posx :: !Float
+ , posy :: !Float
+ , dir :: !Float
+ } deriving Show