Added texture loading

Bindings/GLPng.chs

@@ -0,0 +1,158 @@
+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable  #-}
+
+module Bindings.GLPng ( PngInfo(..)
+                      , Mipmap(..)
+                      , Trans (..)
+                      , pngBind
+                      ) where
+
+import Data.Generics
+
+import Foreign.C.String (CString, withCString)
+import Foreign.C.Types
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr
+import Foreign.Storable
+
+import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clamping(..), TextureFilter(..), MinificationFilter, MagnificationFilter)
+
+
+#include <GL/gl.h>
+#include <GL/glpng.h>
+
+
+data PngInfo = PngInfo
+    { pngWidth  :: !CUInt
+    , pngHeight :: !CUInt
+    , pngDepth  :: !CUInt
+    , pngAlpha  :: !CUInt
+    } deriving (Eq, Ord, Show, Typeable)
+
+instance Storable PngInfo where
+    sizeOf _ = (#size pngInfo)
+    alignment _ = alignment (undefined :: CUInt)
+    
+    peek pi = do
+      w <- (#peek pngInfo, Width) pi
+      h <- (#peek pngInfo, Height) pi
+      d <- (#peek pngInfo, Depth) pi
+      a <- (#peek pngInfo, Alpha) pi
+      
+      return (PngInfo w h d a)
+    
+    poke pi (PngInfo w h d a) = do
+                            (#poke pngInfo, Width) pi w
+                            (#poke pngInfo, Height) pi h
+                            (#poke pngInfo, Depth) pi d
+                            (#poke pngInfo, Alpha) pi a
+    
+    
+
+
+png_NoMipmap :: CInt
+png_NoMipmap = (#const PNG_NOMIPMAP)
+
+png_BuildMipmap :: CInt
+png_BuildMipmap = (#const PNG_BUILDMIPMAP)
+
+png_SimpleMipmap :: CInt
+png_SimpleMipmap = (#const PNG_SIMPLEMIPMAP)
+
+
+data Mipmap = NoMipmap | BuildMipmap | SimpleMipmap
+            deriving (Eq, Show)
+
+marshalMipmap :: Mipmap -> CInt
+marshalMipmap m
+    | m == NoMipmap     = png_NoMipmap
+    | m == BuildMipmap  = png_BuildMipmap
+    | m == SimpleMipmap = png_SimpleMipmap
+
+
+png_Alpha :: CInt
+png_Alpha = (#const PNG_ALPHA)
+
+png_Solid :: CInt
+png_Solid = (#const PNG_SOLID)
+
+data Trans = Alpha | Solid
+           deriving (Eq, Show)
+
+marshalTrans :: Trans -> CInt
+marshalTrans t
+    | t == Alpha = png_Alpha
+    | t == Solid = png_Solid
+
+
+magToMin :: MagnificationFilter -> MinificationFilter
+magToMin magFilter = (magFilter, Nothing)
+
+
+gl_NEAREST :: CInt
+gl_NEAREST = (#const GL_NEAREST)
+
+gl_LINEAR :: CInt
+gl_LINEAR = (#const GL_LINEAR)
+
+gl_NEAREST_MIPMAP_NEAREST :: CInt
+gl_NEAREST_MIPMAP_NEAREST = (#const GL_NEAREST_MIPMAP_NEAREST)
+
+gl_LINEAR_MIPMAP_NEAREST :: CInt
+gl_LINEAR_MIPMAP_NEAREST = (#const GL_LINEAR_MIPMAP_NEAREST)
+
+gl_NEAREST_MIPMAP_LINEAR :: CInt
+gl_NEAREST_MIPMAP_LINEAR = (#const GL_NEAREST_MIPMAP_LINEAR)
+
+gl_LINEAR_MIPMAP_LINEAR :: CInt
+gl_LINEAR_MIPMAP_LINEAR = (#const GL_LINEAR_MIPMAP_LINEAR)
+
+
+marshalMinificationFilter :: MinificationFilter -> CInt
+marshalMinificationFilter x = fromIntegral $ case x of
+   (Nearest, Nothing     ) -> gl_NEAREST
+   (Linear', Nothing     ) -> gl_LINEAR
+   (Nearest, Just Nearest) -> gl_NEAREST_MIPMAP_NEAREST
+   (Linear', Just Nearest) -> gl_LINEAR_MIPMAP_NEAREST
+   (Nearest, Just Linear') -> gl_NEAREST_MIPMAP_LINEAR
+   (Linear', Just Linear') -> gl_LINEAR_MIPMAP_LINEAR
+
+marshalMagnificationFilter :: MagnificationFilter -> CInt
+marshalMagnificationFilter = marshalMinificationFilter . magToMin
+
+
+gl_CLAMP :: CInt
+gl_CLAMP = (#const GL_CLAMP)
+
+gl_REPEAT :: CInt
+gl_REPEAT = (#const GL_REPEAT)
+
+gl_CLAMP_TO_EDGE :: CInt
+gl_CLAMP_TO_EDGE = (#const GL_CLAMP_TO_EDGE)
+
+gl_CLAMP_TO_BORDER :: CInt
+gl_CLAMP_TO_BORDER = (#const GL_CLAMP_TO_BORDER)
+
+gl_MIRRORED_REPEAT :: CInt
+gl_MIRRORED_REPEAT = (#const GL_MIRRORED_REPEAT)
+
+
+marshalTextureWrapMode :: (Repetition, Clamping) -> CInt
+marshalTextureWrapMode x = fromIntegral $ case x of
+   (Repeated, Clamp) -> gl_CLAMP
+   (Repeated, Repeat) -> gl_REPEAT
+   (Repeated, ClampToEdge) -> gl_CLAMP_TO_EDGE
+   (Repeated, ClampToBorder) -> gl_CLAMP_TO_BORDER
+   (Mirrored, Repeat) -> gl_MIRRORED_REPEAT
+   _ -> error ("marshalTextureWrapMode: illegal value " ++ show x)
+
+foreign import ccall unsafe "GL/glpng.h pngBind"
+        rawPngBind :: CString -> CInt -> CInt -> Ptr PngInfo -> CInt -> CInt -> CInt -> IO CUInt
+
+
+pngBind :: String -> Mipmap -> Trans -> (Repetition, Clamping) -> MinificationFilter -> MagnificationFilter -> IO (CUInt, PngInfo)
+pngBind name mipmap trans wrapst minfilter magfilter = alloca $ \infop -> withCString name $ \cname -> do
+                                                         ret <- rawPngBind cname (marshalMipmap mipmap) (marshalTrans trans) infop (marshalTextureWrapMode wrapst)
+                                                                          (marshalMinificationFilter minfilter) (marshalMagnificationFilter magfilter)
+                                                         info <- peek infop
+                                                         return (ret, info)
+                                                         

Bindings/GLPng.hs

@@ -0,0 +1,189 @@
+{-# INCLUDE <GL/gl.h> #-}
+{-# INCLUDE <GL/glpng.h> #-}
+{-# LINE 1 "GLPng.chs" #-}
+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable  #-}
+{-# LINE 2 "GLPng.chs" #-}
+
+module Bindings.GLPng ( PngInfo(..)
+                      , Mipmap(..)
+                      , Trans (..)
+                      , pngBind
+                      ) where
+
+import Data.Generics
+
+import Foreign.C.String (CString, withCString)
+import Foreign.C.Types
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr
+import Foreign.Storable
+
+import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clamping(..), TextureFilter(..), MinificationFilter, MagnificationFilter)
+
+
+
+{-# LINE 21 "GLPng.chs" #-}
+
+{-# LINE 22 "GLPng.chs" #-}
+
+
+data PngInfo = PngInfo
+    { pngWidth  :: !CUInt
+    , pngHeight :: !CUInt
+    , pngDepth  :: !CUInt
+    , pngAlpha  :: !CUInt
+    } deriving (Eq, Ord, Show, Typeable)
+
+instance Storable PngInfo where
+    sizeOf _ = ((16))
+{-# LINE 33 "GLPng.chs" #-}
+    alignment _ = alignment (undefined :: CUInt)
+    
+    peek pi = do
+      w <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) pi
+{-# LINE 37 "GLPng.chs" #-}
+      h <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) pi
+{-# LINE 38 "GLPng.chs" #-}
+      d <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) pi
+{-# LINE 39 "GLPng.chs" #-}
+      a <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) pi
+{-# LINE 40 "GLPng.chs" #-}
+      
+      return (PngInfo w h d a)
+    
+    poke pi (PngInfo w h d a) = do
+                            ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) pi w
+{-# LINE 45 "GLPng.chs" #-}
+                            ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) pi h
+{-# LINE 46 "GLPng.chs" #-}
+                            ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) pi d
+{-# LINE 47 "GLPng.chs" #-}
+                            ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) pi a
+{-# LINE 48 "GLPng.chs" #-}
+    
+    
+
+
+png_NoMipmap :: CInt
+png_NoMipmap = (0)
+{-# LINE 54 "GLPng.chs" #-}
+
+png_BuildMipmap :: CInt
+png_BuildMipmap = (-1)
+{-# LINE 57 "GLPng.chs" #-}
+
+png_SimpleMipmap :: CInt
+png_SimpleMipmap = (-2)
+{-# LINE 60 "GLPng.chs" #-}
+
+
+data Mipmap = NoMipmap | BuildMipmap | SimpleMipmap
+            deriving (Eq, Show)
+
+marshalMipmap :: Mipmap -> CInt
+marshalMipmap m
+    | m == NoMipmap     = png_NoMipmap
+    | m == BuildMipmap  = png_BuildMipmap
+    | m == SimpleMipmap = png_SimpleMipmap
+
+
+png_Alpha :: CInt
+png_Alpha = (-2)
+{-# LINE 74 "GLPng.chs" #-}
+
+png_Solid :: CInt
+png_Solid = (-1)
+{-# LINE 77 "GLPng.chs" #-}
+
+data Trans = Alpha | Solid
+           deriving (Eq, Show)
+
+marshalTrans :: Trans -> CInt
+marshalTrans t
+    | t == Alpha = png_Alpha
+    | t == Solid = png_Solid
+
+
+magToMin :: MagnificationFilter -> MinificationFilter
+magToMin magFilter = (magFilter, Nothing)
+
+
+gl_NEAREST :: CInt
+gl_NEAREST = (9728)
+{-# LINE 93 "GLPng.chs" #-}
+
+gl_LINEAR :: CInt
+gl_LINEAR = (9729)
+{-# LINE 96 "GLPng.chs" #-}
+
+gl_NEAREST_MIPMAP_NEAREST :: CInt
+gl_NEAREST_MIPMAP_NEAREST = (9984)
+{-# LINE 99 "GLPng.chs" #-}
+
+gl_LINEAR_MIPMAP_NEAREST :: CInt
+gl_LINEAR_MIPMAP_NEAREST = (9985)
+{-# LINE 102 "GLPng.chs" #-}
+
+gl_NEAREST_MIPMAP_LINEAR :: CInt
+gl_NEAREST_MIPMAP_LINEAR = (9986)
+{-# LINE 105 "GLPng.chs" #-}
+
+gl_LINEAR_MIPMAP_LINEAR :: CInt
+gl_LINEAR_MIPMAP_LINEAR = (9987)
+{-# LINE 108 "GLPng.chs" #-}
+
+
+marshalMinificationFilter :: MinificationFilter -> CInt
+marshalMinificationFilter x = fromIntegral $ case x of
+   (Nearest, Nothing     ) -> gl_NEAREST
+   (Linear', Nothing     ) -> gl_LINEAR
+   (Nearest, Just Nearest) -> gl_NEAREST_MIPMAP_NEAREST
+   (Linear', Just Nearest) -> gl_LINEAR_MIPMAP_NEAREST
+   (Nearest, Just Linear') -> gl_NEAREST_MIPMAP_LINEAR
+   (Linear', Just Linear') -> gl_LINEAR_MIPMAP_LINEAR
+
+marshalMagnificationFilter :: MagnificationFilter -> CInt
+marshalMagnificationFilter = marshalMinificationFilter . magToMin
+
+
+gl_CLAMP :: CInt
+gl_CLAMP = (10496)
+{-# LINE 125 "GLPng.chs" #-}
+
+gl_REPEAT :: CInt
+gl_REPEAT = (10497)
+{-# LINE 128 "GLPng.chs" #-}
+
+gl_CLAMP_TO_EDGE :: CInt
+gl_CLAMP_TO_EDGE = (33071)
+{-# LINE 131 "GLPng.chs" #-}
+
+gl_CLAMP_TO_BORDER :: CInt
+gl_CLAMP_TO_BORDER = (33069)
+{-# LINE 134 "GLPng.chs" #-}
+
+gl_MIRRORED_REPEAT :: CInt
+gl_MIRRORED_REPEAT = (33648)
+{-# LINE 137 "GLPng.chs" #-}
+
+
+marshalTextureWrapMode :: (Repetition, Clamping) -> CInt
+marshalTextureWrapMode x = fromIntegral $ case x of
+   (Repeated, Clamp) -> gl_CLAMP
+   (Repeated, Repeat) -> gl_REPEAT
+   (Repeated, ClampToEdge) -> gl_CLAMP_TO_EDGE
+   (Repeated, ClampToBorder) -> gl_CLAMP_TO_BORDER
+   (Mirrored, Repeat) -> gl_MIRRORED_REPEAT
+   _ -> error ("marshalTextureWrapMode: illegal value " ++ show x)
+
+foreign import ccall unsafe "GL/glpng.h pngBind"
+        rawPngBind :: CString -> CInt -> CInt -> Ptr PngInfo -> CInt -> CInt -> CInt -> IO CUInt
+
+
+pngBind :: String -> Mipmap -> Trans -> (Repetition, Clamping) -> MinificationFilter -> MagnificationFilter -> IO (CUInt, PngInfo)
+pngBind name mipmap trans wrapst minfilter magfilter = alloca $ \infop -> withCString name $ \cname -> do
+                                                         ret <- rawPngBind cname (marshalMipmap mipmap) (marshalTrans trans) infop (marshalTextureWrapMode wrapst)
+                                                                          (marshalMinificationFilter minfilter) (marshalMagnificationFilter magfilter)
+                                                         info <- peek infop
+                                                         return (ret, info)
+                                                         

Bindings/GLX.chs

@@ -30,7 +30,6 @@ import Data.Word
 
 import Foreign.C.String (withCString)
 import Foreign.C.Types
-import Foreign.ForeignPtr
 import Foreign.Ptr
 import Foreign.Marshal.Alloc (alloca, allocaBytes)
 import Foreign.Marshal.Array (peekArray, withArray0)

Bindings/GLX.hs

@@ -33,7 +33,6 @@ import Data.Word
 
 import Foreign.C.String (withCString)
 import Foreign.C.Types
-import Foreign.ForeignPtr
 import Foreign.Ptr
 import Foreign.Marshal.Alloc (alloca, allocaBytes)
 import Foreign.Marshal.Array (peekArray, withArray0)
@@ -45,7 +44,7 @@ import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
 
 
 
-{-# LINE 45 "GLX.chs" #-}
+{-# LINE 44 "GLX.chs" #-}
 
 
 type Drawable = XID
@@ -74,55 +73,55 @@ data VisualInfo = VisualInfo
 
 instance Storable VisualInfo where
     sizeOf _ = ((40))
-{-# LINE 73 "GLX.chs" #-}
+{-# LINE 72 "GLX.chs" #-}
     alignment _ = alignment (undefined :: CULong)
     
     peek vi = do
       visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi
-{-# LINE 77 "GLX.chs" #-}
+{-# LINE 76 "GLX.chs" #-}
       visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
-{-# LINE 78 "GLX.chs" #-}
+{-# LINE 77 "GLX.chs" #-}
       screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi
-{-# LINE 79 "GLX.chs" #-}
+{-# LINE 78 "GLX.chs" #-}
       depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi
-{-# LINE 80 "GLX.chs" #-}
+{-# LINE 79 "GLX.chs" #-}
       viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi
-{-# LINE 81 "GLX.chs" #-}
+{-# LINE 80 "GLX.chs" #-}
       red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi
-{-# LINE 82 "GLX.chs" #-}
+{-# LINE 81 "GLX.chs" #-}
       green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi
-{-# LINE 83 "GLX.chs" #-}
+{-# LINE 82 "GLX.chs" #-}
       blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi
-{-# LINE 84 "GLX.chs" #-}
+{-# LINE 83 "GLX.chs" #-}
       colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi
-{-# LINE 85 "GLX.chs" #-}
+{-# LINE 84 "GLX.chs" #-}
       bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi
-{-# LINE 86 "GLX.chs" #-}
+{-# LINE 85 "GLX.chs" #-}
       
       return (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb)
       
     
     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 92 "GLX.chs" #-}
+{-# LINE 91 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
-{-# LINE 93 "GLX.chs" #-}
+{-# LINE 92 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen
-{-# LINE 94 "GLX.chs" #-}
+{-# LINE 93 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth
-{-# LINE 95 "GLX.chs" #-}
+{-# LINE 94 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass
-{-# LINE 96 "GLX.chs" #-}
+{-# LINE 95 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask
-{-# LINE 97 "GLX.chs" #-}
+{-# LINE 96 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask
-{-# LINE 98 "GLX.chs" #-}
+{-# LINE 97 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask
-{-# LINE 99 "GLX.chs" #-}
+{-# LINE 98 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size
-{-# LINE 100 "GLX.chs" #-}
+{-# LINE 99 "GLX.chs" #-}
                                 ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb
-{-# LINE 101 "GLX.chs" #-}
+{-# LINE 100 "GLX.chs" #-}
 
 
 data SetWindowAttributes = SetWindowAttributes
@@ -144,38 +143,38 @@ data SetWindowAttributes = SetWindowAttributes
 
 instance Storable SetWindowAttributes where
     sizeOf _ = ((60))
-{-# LINE 122 "GLX.chs" #-}
+{-# LINE 121 "GLX.chs" #-}
     alignment _ = alignment (undefined :: CULong)
     
     peek swa = do
       background_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) swa
-{-# LINE 126 "GLX.chs" #-}
+{-# LINE 125 "GLX.chs" #-}
       background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
-{-# LINE 127 "GLX.chs" #-}
+{-# LINE 126 "GLX.chs" #-}
       border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa
-{-# LINE 128 "GLX.chs" #-}
+{-# LINE 127 "GLX.chs" #-}
       bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa
-{-# LINE 129 "GLX.chs" #-}
+{-# LINE 128 "GLX.chs" #-}
       win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa
-{-# LINE 130 "GLX.chs" #-}
+{-# LINE 129 "GLX.chs" #-}
       backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa
-{-# LINE 131 "GLX.chs" #-}
+{-# LINE 130 "GLX.chs" #-}
       backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa
-{-# LINE 132 "GLX.chs" #-}
+{-# LINE 131 "GLX.chs" #-}
       backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa
-{-# LINE 133 "GLX.chs" #-}
+{-# LINE 132 "GLX.chs" #-}
       save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa
-{-# LINE 134 "GLX.chs" #-}
+{-# LINE 133 "GLX.chs" #-}
       event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa
-{-# LINE 135 "GLX.chs" #-}
+{-# LINE 134 "GLX.chs" #-}
       do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa
-{-# LINE 136 "GLX.chs" #-}
+{-# LINE 135 "GLX.chs" #-}
       override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa
-{-# LINE 137 "GLX.chs" #-}
+{-# LINE 136 "GLX.chs" #-}
       colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa
-{-# LINE 138 "GLX.chs" #-}
+{-# LINE 137 "GLX.chs" #-}
       cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
-{-# LINE 139 "GLX.chs" #-}
+{-# LINE 138 "GLX.chs" #-}
       
       return (SetWindowAttributes
               background_pixmap
@@ -209,33 +208,33 @@ instance Storable SetWindowAttributes where
               colormap
               cursor) = do
       ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) swa background_pixmap
-{-# LINE 172 "GLX.chs" #-}
+{-# LINE 171 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
-{-# LINE 173 "GLX.chs" #-}
+{-# LINE 172 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap
-{-# LINE 174 "GLX.chs" #-}
+{-# LINE 173 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity
-{-# LINE 175 "GLX.chs" #-}
+{-# LINE 174 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity
-{-# LINE 176 "GLX.chs" #-}
+{-# LINE 175 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store
-{-# LINE 177 "GLX.chs" #-}
+{-# LINE 176 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes
-{-# LINE 178 "GLX.chs" #-}
+{-# LINE 177 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel
-{-# LINE 179 "GLX.chs" #-}
+{-# LINE 178 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under
-{-# LINE 180 "GLX.chs" #-}
+{-# LINE 179 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask
-{-# LINE 181 "GLX.chs" #-}
+{-# LINE 180 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask
-{-# LINE 182 "GLX.chs" #-}
+{-# LINE 181 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect
-{-# LINE 183 "GLX.chs" #-}
+{-# LINE 182 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap
-{-# LINE 184 "GLX.chs" #-}
+{-# LINE 183 "GLX.chs" #-}
       ((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor
-{-# LINE 185 "GLX.chs" #-}
+{-# LINE 184 "GLX.chs" #-}
 
 nullSetWindowAttributes :: SetWindowAttributes
 nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0)
@@ -254,13 +253,13 @@ foreign import ccall unsafe "GL/glx.h XSetClassHint"
 
 setClassHint :: Display -> Window -> ClassHint -> IO ()
 setClassHint disp wnd hint = allocaBytes ((8)) $ \p ->
-{-# LINE 203 "GLX.chs" #-}
+{-# LINE 202 "GLX.chs" #-}
                              withCString (resName hint) $ \res_name ->
                              withCString (resClass hint) $ \res_class -> do
                                ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p res_name
-{-# LINE 206 "GLX.chs" #-}
+{-# LINE 205 "GLX.chs" #-}
                                ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p res_class
-{-# LINE 207 "GLX.chs" #-}
+{-# LINE 206 "GLX.chs" #-}
                                xSetClassHint disp wnd p
 
 
@@ -278,35 +277,35 @@ chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (con
 
 renderType :: CInt
 renderType = (32785)
-{-# LINE 224 "GLX.chs" #-}
+{-# LINE 223 "GLX.chs" #-}
 
 rgbaBit :: CInt
 rgbaBit = (1)
-{-# LINE 227 "GLX.chs" #-}
+{-# LINE 226 "GLX.chs" #-}
 
 drawableType :: CInt
 drawableType = (32784)
-{-# LINE 230 "GLX.chs" #-}
+{-# LINE 229 "GLX.chs" #-}
 
 windowBit :: CInt
 windowBit = (1)
-{-# LINE 233 "GLX.chs" #-}
+{-# LINE 232 "GLX.chs" #-}
 
 xRenderable :: CInt
 xRenderable = (32786)
-{-# LINE 236 "GLX.chs" #-}
+{-# LINE 235 "GLX.chs" #-}
 
 doublebuffer :: CInt
 doublebuffer = (5)
-{-# LINE 239 "GLX.chs" #-}
+{-# LINE 238 "GLX.chs" #-}
 
 depthSize :: CInt
 depthSize = (12)
-{-# LINE 242 "GLX.chs" #-}
+{-# LINE 241 "GLX.chs" #-}
 
 stencilSize :: CInt
 stencilSize = (13)
-{-# LINE 245 "GLX.chs" #-}
+{-# LINE 244 "GLX.chs" #-}
 
 foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
         glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo)

HTanks.hs

@@ -39,10 +39,11 @@ main = do
   when (initialized gl) $ do
          currentTime <- getCurrentTime
          let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, keyset = S.empty}
-             gameState = GameState {level = testLevel, tanks = [Tank 0.0 0.0 0 0]}
+             gameState = GameState {level = testLevel, tanks = [Tank 0.0 0.0 0 0 2]}
          
-         setup 800 600
+         runGame gameState $ do
-         runGame gameState $ runMain mainState $ mainLoop
+                            setup 800 600
+                            runMain mainState mainLoop
          
          deinitGL gl
 
@@ -90,10 +91,11 @@ simulationStep = do
   when (lengthsq /= 0) $ do
                    let length = sqrt lengthsq
                    
-                   let dx = fromRational (round (x*1000/length)%1000000)
-                       dy = fromRational (round (y*1000/length)%1000000)
-                   
                    oldtank <- lift $ gets (head . tanks)
+                   
+                   let dx = (speed oldtank) * fromRational (round (x*1000/length)%1000000)
+                       dy = (speed oldtank) * fromRational (round (y*1000/length)%1000000)
+                   
                    let tank = oldtank {posx = dx + posx oldtank, posy = dy + posy oldtank}
                    
                    lift $ modify $ \state -> state {tanks = tank:(tail . tanks $ state)}
@@ -107,7 +109,7 @@ handleEvents = do
 
 handleEvent :: SomeEvent -> Main ()
 handleEvent ev
-    | Just (ResizeEvent w h)     <- fromEvent ev = liftIO $ resize w h
+    | Just (ResizeEvent w h)     <- fromEvent ev = lift $ resize w h
     | Just (KeyPressEvent key)   <- fromEvent ev = modify $ \state -> state {keyset = S.insert key (keyset state)}
     | Just (KeyReleaseEvent key) <- fromEvent ev = modify $ \state -> state {keyset = S.delete key (keyset state)}
     | Just QuitEvent             <- fromEvent ev = modify $ \state -> state {run = False}

Level.hs

@@ -5,14 +5,14 @@ module Level ( Level(..)
 import Data.List
 
 data Level = Level
-    { floorTiles :: ![[Int]]
+    { levelWidth  :: !Int
-    , objectTiles :: ![[Int]]
+    , levelHeight :: !Int
     } deriving (Show)
 
 
 
 testLevel :: Level
 testLevel = Level
-            { floorTiles = replicate 10 $ replicate 10 0
+            { levelWidth = 10
-            , objectTiles = replicate 10 $ replicate 10 0
+            , levelHeight = 10
             }

Render.hs

@@ -5,52 +5,64 @@ module Render ( setup
 
 
 import Game
+import Level
 import Tank
 
+import Bindings.GLPng
+
 import Control.Monad.State
 
 import Data.Fixed
 import Data.Ratio
 
-import Graphics.Rendering.OpenGL.GL (($=), GLfloat)
+import Graphics.Rendering.OpenGL.GL (($=), GLfloat, GLdouble)
 import Graphics.Rendering.OpenGL.GL.BeginEnd (renderPrimitive, PrimitiveMode(..))
 import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, ortho)
 import Graphics.Rendering.OpenGL.GL.Framebuffer (clear, ClearBuffer(..))
+import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clamping(..), TextureFilter(..), MinificationFilter, MagnificationFilter)
 import Graphics.Rendering.OpenGL.GL.VertexSpec
 
 
-setup :: Int -> Int -> IO ()
+setup :: Int -> Int -> Game ()
 setup w h = do
   resize w h
+  (tex, info) <- liftIO $ pngBind "tex/Wood.png" NoMipmap Solid (Repeated, Repeat) (Linear', Nothing) Linear'
+  liftIO $ print info
   
-resize :: Int -> Int -> IO ()
+
+resize :: Int -> Int -> Game ()
 resize w h = do
   let wn = fromIntegral w
       hn = fromIntegral h
-      aspect = wn/hn
+      aspect = fromReal (wn/hn)
   
-  matrixMode $= Projection
+  lvl <- gets level
-  loadIdentity
+  let s = max (0.5*(fromIntegral $ levelWidth lvl)/aspect) (0.5*(fromIntegral $ levelHeight lvl)) :: GLdouble
-  ortho (-aspect) (aspect) (-1) 1 (-1) 1
   
-  matrixMode $= Modelview 0
+  liftIO $ do
+    matrixMode $= Projection
+    loadIdentity
+    ortho (-s*aspect) (s*aspect) (-s) s (-1) 1
     
-  viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h)))
+    matrixMode $= Modelview 0
+    
+    viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h)))
 
 
 render :: Game ()
 render = do
   tank <- liftM head $ gets tanks
-  let x = toFloat . posx $ tank
+  let x = fromReal . posx $ tank
-      y = toFloat . posy $ tank
+      y = fromReal . posy $ tank
   
   liftIO $ do
            clear [ColorBuffer]
            
-           renderPrimitive Triangles $ do
+           renderPrimitive Quads $ do
                     vertex $ Vertex2 (x-0.5 :: GLfloat) (y-0.5 :: GLfloat)
+                    vertex $ Vertex2 (x-0.5 :: GLfloat) (y+0.5 :: GLfloat)
                     vertex $ Vertex2 (x+0.5 :: GLfloat) (y+0.5 :: GLfloat)
                     vertex $ Vertex2 (x+0.5 :: GLfloat) (y-0.5 :: GLfloat)
 
-toFloat :: Real a => a -> GLfloat
+fromReal :: (Real a, Fractional b) => a -> b
-toFloat = fromRational . toRational
+fromReal = fromRational . toRational

Tank.hs

@@ -4,8 +4,9 @@ module Tank ( Tank(..)
 import Data.Fixed
 
 data Tank = Tank
-          { posx :: !Micro
+          { posx  :: !Micro
-          , posy :: !Micro
+          , posy  :: !Micro
-          , dir  :: !Micro
+          , dir   :: !Micro
-          , aim  :: !Micro
+          , aim   :: !Micro
+          , speed :: !Micro
           } deriving Show