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

Added texture loading

Browse source
This commit is contained in:
Matthias Schiffer 2010-02-25 02:15:26 +01:00
parent 7f12f41e5f
commit b4c3367c63
9 changed files with 454 additions and 94 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

158
Bindings/GLPng.chs Normal file
View file

@ -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)

189
Bindings/GLPng.hs Normal file
View file

@ -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)

1
Bindings/GLX.chs
View file

@ -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)

125
Bindings/GLX.hs
View file

@ -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)

16
HTanks.hs
View file

@ -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 $ runMain mainState $ mainLoop
runGame gameState $ do
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}

8
Level.hs
View file

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

42
Render.hs
View file

@ -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
loadIdentity
ortho (-aspect) (aspect) (-1) 1 (-1) 1
lvl <- gets level
let s = max (0.5*(fromIntegral $ levelWidth lvl)/aspect) (0.5*(fromIntegral $ levelHeight lvl)) :: GLdouble
matrixMode $= Modelview 0
viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h)))
liftIO $ do
matrixMode $= Projection
loadIdentity
ortho (-s*aspect) (s*aspect) (-s) s (-1) 1
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
y = toFloat . posy $ tank
let x = fromReal . posx $ 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
toFloat = fromRational . toRational
fromReal :: (Real a, Fractional b) => a -> b
fromReal = fromRational . toRational

9
Tank.hs
View file

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

BIN
tex/Wood.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 18 KiB