summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Bindings/GLPng.hsc158
-rw-r--r--src/Bindings/GLX.hsc265
-rw-r--r--src/CPUPlayer.hs19
-rw-r--r--src/DefaultPlayer.hs36
-rw-r--r--src/GLDriver.hs67
-rw-r--r--src/GLX.hs214
-rw-r--r--src/Game.hs52
-rw-r--r--src/HTanks.hs199
-rw-r--r--src/Level.hs18
-rw-r--r--src/Player.hs27
-rw-r--r--src/Render.hs167
-rw-r--r--src/Texture.hs8
12 files changed, 1230 insertions, 0 deletions
diff --git a/src/Bindings/GLPng.hsc b/src/Bindings/GLPng.hsc
new file mode 100644
index 0000000..453bddc
--- /dev/null
+++ b/src/Bindings/GLPng.hsc
@@ -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)
+ \ No newline at end of file
diff --git a/src/Bindings/GLX.hsc b/src/Bindings/GLX.hsc
new file mode 100644
index 0000000..d5fed4d
--- /dev/null
+++ b/src/Bindings/GLX.hsc
@@ -0,0 +1,265 @@
+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+
+module Bindings.GLX ( createColormap
+ , createWindow
+ , setClassHint
+ , chooseFBConfig
+ , getVisualFromFBConfig
+ , VisualInfo(..)
+ , SetWindowAttributes(..)
+ , nullSetWindowAttributes
+ , renderType
+ , rgbaBit
+ , drawableType
+ , windowBit
+ , xRenderable
+ , doublebuffer
+ , depthSize
+ , stencilSize
+ , createContext
+ , makeCurrent
+ , destroyContext
+ , swapBuffers
+ , Context(..)
+ , Drawable
+ ) where
+
+import Data.Generics
+import Data.Int
+import Data.Word
+
+import Foreign.C.String (withCString)
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Marshal.Alloc (alloca, allocaBytes)
+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, xFree, ClassHint, resName, resClass, TextProperty)
+import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position)
+
+
+#include <GL/glx.h>
+
+
+type Drawable = XID
+
+newtype FBConfig = FBConfig (Ptr FBConfig)
+ deriving (Eq, Ord, Show, Typeable, Data, Storable)
+
+newtype Context = Context (Ptr Context)
+ deriving (Eq, Ord, Show, Typeable, Data, Storable)
+
+newtype Visual = Visual (Ptr Visual)
+ deriving (Eq, Ord, Show, Typeable, Data, Storable)
+
+data VisualInfo = VisualInfo
+ { viVisual :: !Visual
+ , viVisualid :: !VisualID
+ , viScreen :: !CInt
+ , viDepth :: !CInt
+ , viClass :: !CInt
+ , viRedMask :: !CULong
+ , viGreenMask :: !CULong
+ , viBlueMask :: !CULong
+ , viColormapSize :: !CInt
+ , viBitsPerRgb :: !CInt
+ } deriving (Eq, Ord, Show, Typeable)
+
+instance Storable VisualInfo 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 (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
+ (#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 SetWindowAttributes = SetWindowAttributes
+ { swaBackgroundPixmap :: !Pixmap
+ , swaBackgroundPixel :: !Pixel
+ , swaBorderPixmap :: !Pixmap
+ , swaBitGravity :: !CInt
+ , swaWinGravity :: !CInt
+ , swaBackingStore :: !CInt
+ , swaBackingPlanes :: !CULong
+ , swaBackingPixel :: !CULong
+ , swaSaveUnder :: !Bool
+ , swaEventMask :: !EventMask
+ , swaDoNotPropagateMask :: !CULong
+ , swaOverrideRedirect :: !Bool
+ , swaColormap :: !Colormap
+ , swaCursor :: !Cursor
+ } deriving (Eq, Ord, Show, Typeable)
+
+instance Storable SetWindowAttributes 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 (SetWindowAttributes
+ 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 (SetWindowAttributes
+ 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 :: SetWindowAttributes
+nullSetWindowAttributes = (SetWindowAttributes 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 SetWindowAttributes -> IO Window
+
+foreign import ccall unsafe "GL/glx.h XSetClassHint"
+ xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO ()
+
+setClassHint :: Display -> Window -> ClassHint -> IO ()
+setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p ->
+ withCString (resName hint) $ \res_name ->
+ withCString (resClass hint) $ \res_class -> do
+ (#poke XClassHint, res_name) p res_name
+ (#poke XClassHint, res_class) p res_class
+ xSetClassHint disp wnd p
+
+
+foreign import ccall unsafe "GL/glx.h glXChooseFBConfig"
+ glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr FBConfig)
+
+chooseFBConfig :: Display -> CInt -> [(CInt, CInt)] -> IO [FBConfig]
+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
+ configlist <- peekArray (fromIntegral nelements) configs
+ xFree configs
+ return configlist
+
+
+renderType :: CInt
+renderType = (#const GLX_RENDER_TYPE)
+
+rgbaBit :: CInt
+rgbaBit = (#const GLX_RGBA_BIT)
+
+drawableType :: CInt
+drawableType = (#const GLX_DRAWABLE_TYPE)
+
+windowBit :: CInt
+windowBit = (#const GLX_WINDOW_BIT)
+
+xRenderable :: CInt
+xRenderable = (#const GLX_X_RENDERABLE)
+
+doublebuffer :: CInt
+doublebuffer = (#const GLX_DOUBLEBUFFER)
+
+depthSize :: CInt
+depthSize = (#const GLX_DEPTH_SIZE)
+
+stencilSize :: CInt
+stencilSize = (#const GLX_STENCIL_SIZE)
+
+foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig"
+ glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo)
+
+getVisualFromFBConfig :: Display -> FBConfig -> IO (VisualInfo)
+getVisualFromFBConfig disp config = do
+ viptr <- glXGetVisualFromFBConfig disp config
+ vi <- peek viptr
+ xFree viptr
+ return vi
+
+foreign import ccall unsafe "GL/glx.h glXCreateContext"
+ createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context
+
+foreign import ccall unsafe "GL/glx.h glXMakeCurrent"
+ makeCurrent :: Display -> Drawable -> Context -> IO Bool
+
+foreign import ccall unsafe "GL/glx.h glXDestroyContext"
+ destroyContext :: Display -> Context -> IO ()
+
+foreign import ccall unsafe "GL/glx.h glXSwapBuffers"
+ swapBuffers :: Display -> Drawable -> IO ()
diff --git a/src/CPUPlayer.hs b/src/CPUPlayer.hs
new file mode 100644
index 0000000..0276de3
--- /dev/null
+++ b/src/CPUPlayer.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module CPUPlayer ( CPUPlayer(..)
+ ) where
+
+
+import Data.Fixed
+import Data.Ratio ((%))
+import Data.Typeable
+
+import GLDriver
+import Player
+
+
+data CPUPlayer = CPUPlayer Micro
+ deriving (Typeable, Show)
+
+instance Player CPUPlayer where
+ playerUpdate (CPUPlayer angle) _ = (CPUPlayer (if (angle+0.1) > 180 then angle-359.9 else angle+0.1), Just angle, True, Just (-angle), False)
diff --git a/src/DefaultPlayer.hs b/src/DefaultPlayer.hs
new file mode 100644
index 0000000..af9aaf5
--- /dev/null
+++ b/src/DefaultPlayer.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
+
+module DefaultPlayer ( DefaultPlayer(..)
+ ) where
+
+
+import qualified Data.Set as S
+import Data.Fixed
+import Data.Ratio ((%))
+import Data.Typeable
+
+import Game (Tank(..))
+import GLDriver
+import Player
+
+
+data DefaultPlayer = DefaultPlayer (S.Set Key) Float Float Bool
+ deriving (Typeable, Show)
+
+instance Player DefaultPlayer where
+ playerUpdate (DefaultPlayer keys aimx aimy shoot) tank =
+ let x = (if (S.member KeyLeft keys) then (-1) else 0) + (if (S.member KeyRight keys) then 1 else 0)
+ y = (if (S.member KeyDown keys) then (-1) else 0) + (if (S.member KeyUp keys) then 1 else 0)
+ ax = aimx - (fromRational . toRational . tankX $ tank)
+ ay = aimy - (fromRational . toRational . tankY $ tank)
+ move = (x /= 0 || y /= 0)
+ angle = if move then Just $ fromRational $ round ((atan2 y x)*1000000*180/pi)%1000000 else Nothing
+ aangle = if (ax /= 0 || ay /= 0) then Just $ fromRational $ round ((atan2 ay ax)*1000000*180/pi)%1000000 else Nothing
+ in (DefaultPlayer keys aimx aimy False, angle, move, aangle, shoot)
+
+ handleEvent (DefaultPlayer keys aimx aimy shoot) ev
+ | Just (KeyPressEvent key) <- fromEvent ev = DefaultPlayer (S.insert key keys) aimx aimy shoot
+ | Just (KeyReleaseEvent key) <- fromEvent ev = DefaultPlayer (S.delete key keys) aimx aimy shoot
+ | Just (MouseMotionEvent x y) <- fromEvent ev = DefaultPlayer keys x y shoot
+ | Just (MousePressEvent x y) <- fromEvent ev = DefaultPlayer keys x y True
+ | otherwise = DefaultPlayer keys aimx aimy shoot
diff --git a/src/GLDriver.hs b/src/GLDriver.hs
new file mode 100644
index 0000000..7340075
--- /dev/null
+++ b/src/GLDriver.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
+
+module GLDriver ( Driver(..)
+ , SomeDriver(..)
+ , Event
+ , SomeEvent(..)
+ , fromEvent
+ , QuitEvent(..)
+ , Key(..)
+ , KeyPressEvent(..)
+ , KeyReleaseEvent(..)
+ , MouseMotionEvent(..)
+ , MousePressEvent(..)
+ ) where
+
+import Data.Typeable
+
+
+class Driver a where
+ initialized :: a -> Bool
+
+ initGL :: a -> IO a
+ deinitGL :: a -> IO ()
+
+ swapBuffers :: a -> IO ()
+
+ nextEvent :: a -> IO (a, Maybe SomeEvent)
+
+data SomeDriver = forall d. Driver d => SomeDriver d
+
+instance Driver SomeDriver where
+ initialized (SomeDriver d) = initialized d
+ initGL (SomeDriver d) = initGL d >>= return . SomeDriver
+ deinitGL (SomeDriver d) = deinitGL d
+ swapBuffers (SomeDriver d) = swapBuffers d
+ nextEvent (SomeDriver d) = nextEvent d >>= \(gl, ev) -> return (SomeDriver gl, ev)
+
+
+class (Typeable a, Show a) => Event a
+
+data SomeEvent = forall a. Event a => SomeEvent a
+instance Show SomeEvent where
+ show (SomeEvent a) = show a
+
+fromEvent :: Event a => SomeEvent -> Maybe a
+fromEvent (SomeEvent a) = cast a
+
+
+data QuitEvent = QuitEvent deriving (Typeable, Show)
+instance Event QuitEvent
+
+
+data Key = KeyLeft | KeyRight | KeyUp | KeyDown
+ deriving (Eq, Ord, Show)
+
+data KeyPressEvent = KeyPressEvent Key deriving (Typeable, Show)
+instance Event KeyPressEvent
+
+data KeyReleaseEvent = KeyReleaseEvent Key deriving (Typeable, Show)
+instance Event KeyReleaseEvent
+
+
+data MouseMotionEvent = MouseMotionEvent Float Float deriving (Typeable, Show)
+instance Event MouseMotionEvent
+
+data MousePressEvent = MousePressEvent Float Float deriving (Typeable, Show)
+instance Event MousePressEvent
diff --git a/src/GLX.hs b/src/GLX.hs
new file mode 100644
index 0000000..6f5b0fc
--- /dev/null
+++ b/src/GLX.hs
@@ -0,0 +1,214 @@
+module GLX ( glxDriver
+ ) where
+
+import GLDriver
+import Bindings.GLX
+
+import Control.Monad (when, unless)
+
+import Data.Bits ((.|.))
+import Data.Maybe (isJust)
+import Data.Ratio
+
+import Graphics.Rendering.OpenGL.GL (($=), GLdouble, GLfloat, Vector3(..), Capability(..))
+import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, ortho, translate)
+
+import Graphics.X11.Types
+import Graphics.X11.Xlib.Atom (internAtom)
+import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow)
+import Graphics.X11.Xlib.Event (XEventPtr, allocaXEvent, nextEvent, get_Window, get_EventType, pending)
+import Graphics.X11.Xlib.Extras (ClassHint(..), getEvent, ev_event_type, ev_width, ev_height, ev_keycode, ev_data, ev_x, ev_y, getWindowAttributes, wa_width, wa_height)
+import Graphics.X11.Xlib.Misc (keycodeToKeysym, setWMProtocols)
+import Graphics.X11.Xlib.Types
+import Graphics.X11.Xlib.Window (destroyWindow, mapWindow, storeName)
+
+import Foreign.Marshal.Utils (with)
+import Foreign.Ptr
+import Foreign.Storable
+
+
+
+data GLX = GLX
+ { glxDisplay :: !Display
+ , glxWindow :: !Window
+ , glxContext :: !Context
+ , glxDeleteWindow :: !Atom
+ , glxScale :: !Rational
+ , glxLevelWidth :: !Int
+ , glxLevelHeight :: !Int
+ }
+
+glxDriver :: Int -> Int -> GLX
+glxDriver w h = GLX
+ { glxDisplay = Display nullPtr
+ , glxWindow = 0
+ , glxContext = Context nullPtr
+ , glxDeleteWindow = 0
+ , glxScale = 1
+ , glxLevelWidth = w
+ , glxLevelHeight = h
+ }
+
+
+instance Driver GLX where
+ initialized glx = ((glxContext glx) /= (Context nullPtr))
+
+ initGL glx = do
+ when (initialized glx) $ fail "GLX already initialized"
+
+ disp <- openDisplay ""
+ delwnd <- internAtom disp "WM_DELETE_WINDOW" False
+ fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp)
+ [ (renderType, rgbaBit)
+ , (drawableType, windowBit)
+ , (doublebuffer, 1)
+ , (xRenderable, 1)
+ , (depthSize, 1)
+ , (stencilSize, 1)
+ ]
+ visualinfo <- getVisualFromFBConfig disp (head fbconfigs)
+ rootwindow <- rootWindow disp (fromIntegral $ viScreen visualinfo)
+ cmap <- createColormap disp rootwindow (viVisual visualinfo) allocNone
+
+ let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask .|. pointerMotionMask .|. buttonPressMask}
+
+ wnd <- with swa $ \swaptr ->
+ createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr
+
+ setClassHint disp wnd (ClassHint "HTanks" "htanks")
+ setWMProtocols disp wnd [delwnd]
+
+ storeName disp wnd "HTanks"
+
+ mapWindow disp wnd
+
+ waitForMapNotify disp wnd
+
+ ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
+ makeCurrent disp wnd ctx
+
+ wa <- getWindowAttributes disp wnd
+ s <- resize (glxLevelWidth glx) (glxLevelHeight glx) (fromIntegral . wa_width $ wa) (fromIntegral . wa_height $ wa)
+
+ return glx
+ { glxDisplay = disp
+ , glxWindow = wnd
+ , glxContext = ctx
+ , glxDeleteWindow = delwnd
+ , glxScale = s
+ }
+
+ deinitGL glx = do
+ destroyWindow (glxDisplay glx) (glxWindow glx)
+ destroyContext (glxDisplay glx) (glxContext glx)
+
+ swapBuffers glx = Bindings.GLX.swapBuffers (glxDisplay glx) (glxWindow glx)
+
+ nextEvent glx = allocaXEvent $ nextEvent' glx
+
+
+nextEvent' :: GLX -> XEventPtr -> IO (GLX, Maybe SomeEvent)
+nextEvent' glx xevent = do
+ p <- pending $ glxDisplay glx
+ if (p > 0) then do
+ Graphics.X11.Xlib.Event.nextEvent (glxDisplay glx) xevent
+ (newglx, ev) <- handleEvent glx xevent
+
+ if isJust ev then
+ return (newglx, ev)
+ else
+ nextEvent' newglx xevent
+ else
+ return (glx, Nothing)
+
+
+handleEvent :: GLX -> XEventPtr -> IO (GLX, Maybe SomeEvent)
+handleEvent glx xevent = do
+ event <- getEvent xevent
+ let evtype = ev_event_type event
+ case () of
+ _ | evtype == configureNotify -> do
+ s <- resize (glxLevelWidth glx) (glxLevelHeight glx) (fromIntegral . ev_width $ event) (fromIntegral . ev_height $ event)
+ return (glx {glxScale = s}, Nothing)
+ | evtype == keyPress -> do
+ keysym <- keycodeToKeysym (glxDisplay glx) (ev_keycode event) 0
+ case () of
+ _ | keysym == xK_Escape -> return (glx, Just $ SomeEvent QuitEvent)
+ | keysym == xK_Up -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyUp)
+ | keysym == xK_Down -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyDown)
+ | keysym == xK_Left -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyLeft)
+ | keysym == xK_Right -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyRight)
+ | keysym == xK_w -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyUp)
+ | keysym == xK_s -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyDown)
+ | keysym == xK_a -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyLeft)
+ | keysym == xK_d -> return (glx, Just $ SomeEvent $ KeyPressEvent KeyRight)
+ | otherwise -> return (glx, Nothing)
+ | evtype == keyRelease -> do
+ keysym <- keycodeToKeysym (glxDisplay glx) (ev_keycode event) 0
+ case () of
+ _ | keysym == xK_Up -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyUp)
+ | keysym == xK_Down -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyDown)
+ | keysym == xK_Left -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyLeft)
+ | keysym == xK_Right -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyRight)
+ | keysym == xK_w -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyUp)
+ | keysym == xK_s -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyDown)
+ | keysym == xK_a -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyLeft)
+ | keysym == xK_d -> return (glx, Just $ SomeEvent $ KeyReleaseEvent KeyRight)
+ | otherwise -> return (glx, Nothing)
+ | evtype == clientMessage -> do
+ if ((glxDeleteWindow glx) == (fromIntegral . head . ev_data $ event))
+ then
+ return (glx, Just $ SomeEvent QuitEvent)
+ else
+ return (glx, Nothing)
+ | evtype == motionNotify -> do
+ (x, y) <- windowToGameCoords glx (ev_x event) (ev_y event)
+ wa <- getWindowAttributes (glxDisplay glx) (glxWindow glx)
+ return (glx, Just $ SomeEvent $ MouseMotionEvent x y)
+ | evtype == buttonPress -> do
+ (x, y) <- windowToGameCoords glx (ev_x event) (ev_y event)
+ wa <- getWindowAttributes (glxDisplay glx) (glxWindow glx)
+ return (glx, Just $ SomeEvent $ MousePressEvent x y)
+
+ | otherwise -> return (glx, Nothing)
+
+
+windowToGameCoords :: Integral a => GLX -> a -> a -> IO (Float, Float)
+windowToGameCoords glx x y = getWindowAttributes (glxDisplay glx) (glxWindow glx) >>= \wa ->
+ let w = fromIntegral . wa_width $ wa
+ h = fromIntegral . wa_height $ wa
+ in return (((-w/2 + wx)/s + lw/2), ((h/2 - wy)/s + lh/2))
+ where s = fromRational . glxScale $ glx
+ lw = fromIntegral . glxLevelWidth $ glx
+ lh = fromIntegral . glxLevelHeight $ glx
+ wx = fromIntegral x
+ wy = fromIntegral y
+
+
+resize :: Int -> Int -> Int -> Int -> IO Rational
+resize lw lh w h = do
+ let aspect = (fromIntegral w)%(fromIntegral h)
+ s = (max ((fromIntegral lw)/aspect) (fromIntegral lh))/2
+ sf = fromRational s
+ aspectf = fromRational aspect
+
+ matrixMode $= Projection
+ loadIdentity
+ ortho (-sf*aspectf) (sf*aspectf) (-sf) sf (-1) 1
+ translate $ Vector3 (-(fromIntegral lw)/2) (-(fromIntegral lh)/2) (0 :: GLfloat)
+
+ matrixMode $= Modelview 0
+
+ viewport $= ((Position 0 0), (Size (fromIntegral w) (fromIntegral h)))
+
+ return $ (fromIntegral h)/(2*s)
+
+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
diff --git a/src/Game.hs b/src/Game.hs
new file mode 100644
index 0000000..b31009e
--- /dev/null
+++ b/src/Game.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Game ( Tank(..)
+ , Shoot(..)
+ , GameState(..)
+ , Game
+ , runGame
+ ) where
+
+import Level
+import Texture
+
+import Control.Monad
+import Control.Monad.State
+import Data.Fixed
+import qualified Data.Map as M
+
+
+data Tank = Tank
+ { tankX :: !Micro
+ , tankY :: !Micro
+ , tankDir :: !Micro
+ , tankAim :: !Micro
+ , tankSpeed :: !Micro
+ , tankTurnspeed :: !Micro
+ , tankMoving :: !Bool
+ , tankShootSpeed :: !Micro
+ , tankShootBounces :: !Int
+ , tankShootsLeft :: !Int
+ } deriving Show
+
+data Shoot = Shoot
+ { shootX :: !Micro
+ , shootY :: !Micro
+ , shootDir :: !Micro
+ , shootSpeed :: !Micro
+ , shootBouncesLeft :: !Int
+ , shootTank :: !Int
+ } deriving Show
+
+data GameState = GameState
+ { level :: !Level
+ , tanks :: ![Tank]
+ , shoots :: ![Shoot]
+ , textures :: !(M.Map Texture TextureObject)
+ } 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/src/HTanks.hs b/src/HTanks.hs
new file mode 100644
index 0000000..6d07cb6
--- /dev/null
+++ b/src/HTanks.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE PatternGuards, GeneralizedNewtypeDeriving #-}
+
+import Game
+import Level
+import Render
+import Player
+import CPUPlayer
+import DefaultPlayer
+
+import GLDriver
+import GLX
+
+import Control.Concurrent (threadDelay)
+import Control.Monad.State
+import Data.Fixed
+import Data.Maybe
+import qualified Data.Map as M
+import Data.Ratio
+import qualified Data.Set as S
+import Data.Time.Clock
+
+
+data MainState = MainState
+ { run :: !Bool
+ , driver :: !SomeDriver
+ , time :: !UTCTime
+ , players :: ![SomePlayer]
+ }
+
+newtype MainT m a = MainT (StateT MainState m a)
+ deriving (Monad, MonadState MainState, MonadIO, MonadTrans)
+
+type Main = MainT Game
+
+runMain :: MainState -> Main a -> Game (a, MainState)
+runMain st (MainT a) = runStateT a st
+
+
+main :: IO ()
+main = do
+ let theLevel = testLevel
+ gl <- initGL $ glxDriver (levelWidth theLevel) (levelHeight theLevel)
+
+ when (initialized gl) $ do
+ currentTime <- getCurrentTime
+ let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, players =
+ [ SomePlayer $ DefaultPlayer S.empty 0 0 False
+ , SomePlayer $ CPUPlayer 0
+ ]}
+ gameState = GameState {level = theLevel, tanks = [ Tank 5.0 5.0 0 0 2 270 False 3 2 5
+ , Tank 5.0 3.5 0 0 2 270 False 3 2 5
+ ], shoots = [], textures = M.empty}
+
+ runGame gameState $ do
+ setup
+ runMain mainState mainLoop
+
+ deinitGL gl
+
+minFrameTime :: NominalDiffTime
+minFrameTime = 0.01
+
+mainLoop :: Main ()
+mainLoop = do
+ gl <- gets driver
+ t <- gets time
+ handleEvents
+
+ lift render
+
+ liftIO $ swapBuffers gl
+
+ rtime <- liftIO getCurrentTime
+ let drender = diffUTCTime rtime t
+ when (drender < minFrameTime) $
+ liftIO $ threadDelay $ truncate $ 1e6*(minFrameTime - drender)
+
+ currenttime <- liftIO getCurrentTime
+ let d = round $ 1e3*(diffUTCTime currenttime t)
+
+ replicateM_ d simulationStep
+
+ let newtime = addUTCTime ((1e-3)*(fromIntegral d)) t
+
+ modify $ \state -> state {time = newtime}
+
+ runnext <- gets run
+ when runnext mainLoop
+
+
+updateAngle :: Micro -> State Tank ()
+updateAngle angle = do
+ oldangle <- gets tankDir
+ tspeed <- gets tankTurnspeed >>= return . (/1000)
+
+ let diff = angle - oldangle
+ let diff360 = if (diff > 180)
+ then (diff-360)
+ else if (diff <= -180)
+ then (diff+360)
+ else diff
+
+ let (diff180, angle180) = if (diff360 > 90)
+ then (diff360-180, oldangle+180)
+ else if (diff360 <= -90)
+ then (diff360+180, oldangle-180)
+ else (diff360, oldangle)
+
+ let turn = if (diff180 > tspeed)
+ then tspeed
+ else if (diff180 < -tspeed)
+ then (-tspeed)
+ else diff180
+
+ let newangle = angle180 + turn
+
+ let newangle180 = if (newangle > 180)
+ then (newangle-360)
+ else if (newangle <= -180)
+ then (newangle+360)
+ else newangle
+
+ modify $ \tank -> tank {tankDir = newangle180}
+
+
+updateTank :: Maybe Micro -> Bool -> Maybe Micro -> State Tank ()
+updateTank angle move aangle = do
+ when (isJust angle) $
+ updateAngle $ fromJust angle
+
+ when (isJust aangle) $
+ modify $ \tank -> tank {tankAim = fromJust aangle}
+
+ when move $ do
+ tdir <- gets tankDir
+ tspeed <- gets tankSpeed
+ moved <- gets tankMoving
+
+ when (isNothing angle || (isJust angle && (tdir == fromJust angle)) || moved) $ do
+ let anglej = (fromRational . toRational $ tdir)*pi/180
+ x = tspeed * fromRational (round ((cos anglej)*1000)%1000000)
+ y = tspeed * fromRational (round ((sin anglej)*1000)%1000000)
+
+ modify $ \tank -> tank {tankX = x + tankX tank, tankY = y + tankY tank, tankMoving = True}
+
+ when (not move) $ do
+ modify $ \tank -> tank {tankMoving = False}
+
+
+updateShoot :: State Shoot ()
+updateShoot = do
+ angle <- gets shootDir >>= return . (/180) . (*pi) . fromRational . toRational
+ speed <- gets shootSpeed
+ let dx = speed * fromRational (round ((cos angle)*1000)%1000000)
+ dy = speed * fromRational (round ((sin angle)*1000)%1000000)
+
+ modify $ \shoot -> shoot {shootX = dx + shootX shoot, shootY = dy + shootY shoot}
+
+
+simulationStep :: Main ()
+simulationStep = do
+ oldplayers <- gets players
+ oldtanks <- lift $ gets tanks
+
+ let (p, t, s) = unzip3 $ map updateTank' $ zip oldplayers oldtanks
+ ts = zip3 t s [0..]
+ shootingtanks = map (\(tank, _, n) -> (tank, n)) $ filter (\(tank, shoot, _) -> shoot && (tankShootsLeft tank) > 0) $ ts
+ newtanks = map (\(tank, shoot, _) -> if shoot then tank {tankShootsLeft = (tankShootsLeft tank) - 1} else tank) $ ts
+ newshoots = map (\(tank, n) -> Shoot
+ { shootX = tankX tank
+ , shootY = tankY tank
+ , shootDir = tankAim tank
+ , shootSpeed = tankShootSpeed tank
+ , shootBouncesLeft = tankShootBounces tank
+ , shootTank = n
+ }) shootingtanks
+
+
+ modify $ \state -> state {players = p}
+ lift $ modify $ \state -> state {tanks = newtanks, shoots = map (execState updateShoot) (shoots state ++ newshoots)}
+ where
+ updateTank' (player, tank) = let (p, angle, move, aangle, shoot) = playerUpdate player tank
+ t = execState (updateTank angle move aangle) tank
+ in (p, t, shoot)
+
+
+handleEvents :: Main ()
+handleEvents = do
+ (newgl, event) <- gets driver >>= liftIO . nextEvent
+ modify $ \state -> state {driver = newgl}
+ when (isJust event) $ do
+ Main.handleEvent $ fromJust event
+ modify $ \state -> state {players = map (\p -> Player.handleEvent p $ fromJust event) $ players state}
+ handleEvents
+
+handleEvent :: SomeEvent -> Main ()
+handleEvent ev
+ | Just QuitEvent <- fromEvent ev = modify $ \state -> state {run = False}
+ | otherwise = return ()
diff --git a/src/Level.hs b/src/Level.hs
new file mode 100644
index 0000000..c99a4b5
--- /dev/null
+++ b/src/Level.hs
@@ -0,0 +1,18 @@
+module Level ( Level(..)
+ , testLevel
+ ) where
+
+import Data.List
+
+data Level = Level
+ { levelWidth :: !Int
+ , levelHeight :: !Int
+ } deriving (Show)
+
+
+
+testLevel :: Level
+testLevel = Level
+ { levelWidth = 10
+ , levelHeight = 10
+ } \ No newline at end of file
diff --git a/src/Player.hs b/src/Player.hs
new file mode 100644
index 0000000..baf1cbe
--- /dev/null
+++ b/src/Player.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
+
+module Player ( Player(..)
+ , SomePlayer(..)
+ ) where
+
+import Data.Fixed
+import Data.Typeable
+
+import Game (Tank(..))
+import GLDriver (SomeEvent)
+
+
+class Player a where
+ playerUpdate :: a -> Tank -> (a, Maybe Micro, Bool, Maybe Micro, Bool)
+ handleEvent :: a -> SomeEvent -> a
+
+ handleEvent player _ = player
+
+
+data SomePlayer = forall a. Player a => SomePlayer a
+
+instance Player SomePlayer where
+ playerUpdate (SomePlayer player) tank =
+ let (p, angle, move, aangle, shoot) = playerUpdate player tank
+ in (SomePlayer p, angle, move, aangle, shoot)
+ handleEvent (SomePlayer player) event = SomePlayer $ handleEvent player event
diff --git a/src/Render.hs b/src/Render.hs
new file mode 100644
index 0000000..d1276a3
--- /dev/null
+++ b/src/Render.hs
@@ -0,0 +1,167 @@
+module Render ( setup
+ , render
+ ) where
+
+
+import Paths_htanks
+import Game
+import Level
+import Texture
+
+import Control.Monad.State
+
+import Data.Fixed
+import Data.Maybe
+import Data.Ratio
+import qualified Data.Map as M
+
+import Bindings.GLPng
+
+import Graphics.Rendering.OpenGL.GL (($=), GLfloat, GLdouble, Capability(..), Vector3(..))
+import Graphics.Rendering.OpenGL.GL.BeginEnd (renderPrimitive, PrimitiveMode(..))
+import Graphics.Rendering.OpenGL.GL.CoordTrans (matrixMode, MatrixMode(..), viewport, Position(..), Size(..), loadIdentity, preservingMatrix, ortho, translate, rotate)
+import Graphics.Rendering.OpenGL.GL.Framebuffer (clear, ClearBuffer(..))
+import Graphics.Rendering.OpenGL.GL.PerFragment (blend, blendFunc, BlendingFactor(..))
+import Graphics.Rendering.OpenGL.GL.Texturing.Application (texture)
+import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding, TextureObject(..))
+import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (Repetition(..), Clamping(..), TextureFilter(..), MinificationFilter, MagnificationFilter)
+import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureTarget(..))
+import Graphics.Rendering.OpenGL.GL.VertexSpec
+
+
+texturePath :: Texture -> IO FilePath
+texturePath t = getDataFileName $ path t
+ where
+ path TextureWood = "tex/Wood.png"
+ path TextureTank = "tex/Tank.png"
+ path TextureCannon = "tex/Cannon.png"
+ path TextureBullet = "tex/Bullet.png"
+
+getTexture :: Texture -> Game TextureObject
+getTexture t = do
+ ts <- gets textures
+ let tobj = M.lookup t ts
+
+ if (isJust tobj)
+ then
+ return $ fromJust tobj
+ else do
+ path <- liftIO $ texturePath t
+ tex <- liftIO $ pngBind path BuildMipmap Alpha (Repeated, Repeat) (Linear', Just Linear') Linear' >>= return . TextureObject . fromIntegral . fst
+ modify $ \state -> state {textures = M.insert t tex ts}
+ return tex
+
+
+setup :: Game ()
+setup = do
+ liftIO $ do
+ blend $= Enabled
+ blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
+
+ -- cache textures
+ getTexture TextureWood
+ getTexture TextureTank
+ getTexture TextureCannon
+ getTexture TextureBullet
+
+ return ()
+
+
+render :: Game ()
+render = do
+ tanklist <- gets tanks
+ shootlist <- gets shoots
+
+ textureWood <- getTexture TextureWood
+ textureTank <- getTexture TextureTank
+ textureCannon <- getTexture TextureCannon
+ textureBullet <- getTexture TextureBullet
+
+ (lw, lh) <- gets level >>= \l -> return (fromIntegral . levelWidth $ l :: GLfloat, fromIntegral . levelHeight $ l :: GLfloat)
+
+ liftIO $ do
+ clear [ColorBuffer]
+
+ texture Texture2D $= Enabled
+ textureBinding Texture2D $= Just textureWood
+
+ renderPrimitive Quads $ do
+ texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
+ vertex $ Vertex2 0 lh
+
+ texCoord $ TexCoord2 lw 0
+ vertex $ Vertex2 lw lh
+
+ texCoord $ TexCoord2 lw lh
+ vertex $ Vertex2 lw 0
+
+ texCoord $ TexCoord2 0 lh
+ vertex $ Vertex2 (0 :: GLfloat) (0 :: GLfloat)
+
+ forM_ tanklist $ \tank -> preservingMatrix $ do
+ let x = fromReal . tankX $ tank
+ y = fromReal . tankY $ tank
+ rotDir = fromReal . tankDir $ tank
+ rotAim = fromReal . tankAim $ tank
+
+ translate $ Vector3 x y (0 :: GLfloat)
+ rotate rotDir $ Vector3 0 0 (1 :: GLfloat)
+
+ textureBinding Texture2D $= Just textureTank
+
+ renderPrimitive Quads $ do
+ texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
+ vertex $ Vertex2 (-0.5 :: GLfloat) (-0.5 :: GLfloat)
+
+ texCoord $ TexCoord2 (0 :: GLfloat) (1 :: GLfloat)
+ vertex $ Vertex2 (-0.5 :: GLfloat) (0.5 :: GLfloat)
+
+ texCoord $ TexCoord2 (1 :: GLfloat) (1 :: GLfloat)
+ vertex $ Vertex2 (0.5 :: GLfloat) (0.5 :: GLfloat)
+
+ texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
+ vertex $ Vertex2 (0.5 :: GLfloat) (-0.5 :: GLfloat)
+
+ rotate (rotAim-rotDir) $ Vector3 0 0 (1 :: GLfloat)
+
+ textureBinding Texture2D $= Just textureCannon
+
+ renderPrimitive Quads $ do
+ texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
+ vertex $ Vertex2 (-0.5 :: GLfloat) (-0.5 :: GLfloat)
+
+ texCoord $ TexCoord2 (0 :: GLfloat) (1 :: GLfloat)
+ vertex $ Vertex2 (-0.5 :: GLfloat) (0.5 :: GLfloat)
+
+ texCoord $ TexCoord2 (1 :: GLfloat) (1 :: GLfloat)
+ vertex $ Vertex2 (0.5 :: GLfloat) (0.5 :: GLfloat)
+
+ texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
+ vertex $ Vertex2 (0.5 :: GLfloat) (-0.5 :: GLfloat)
+
+ forM_ shootlist $ \shoot -> preservingMatrix $ do
+ let x = fromReal . shootX $ shoot
+ y = fromReal . shootY $ shoot
+ rotDir = fromReal . shootDir $ shoot
+
+ translate $ Vector3 x y (0 :: GLfloat)
+ rotate rotDir $ Vector3 0 0 (1 :: GLfloat)
+
+ textureBinding Texture2D $= Just textureBullet
+
+ renderPrimitive Quads $ do
+ texCoord $ TexCoord2 (0 :: GLfloat) (0 :: GLfloat)
+ vertex $ Vertex2 (-0.2 :: GLfloat) (-0.2 :: GLfloat)
+
+ texCoord $ TexCoord2 (0 :: GLfloat) (1 :: GLfloat)
+ vertex $ Vertex2 (-0.2 :: GLfloat) (0.2 :: GLfloat)
+
+ texCoord $ TexCoord2 (1 :: GLfloat) (1 :: GLfloat)
+ vertex $ Vertex2 (0.2 :: GLfloat) (0.2 :: GLfloat)
+
+ texCoord $ TexCoord2 (1 :: GLfloat) (0 :: GLfloat)
+ vertex $ Vertex2 (0.2 :: GLfloat) (-0.2 :: GLfloat)
+
+
+fromReal :: (Real a, Fractional b) => a -> b
+fromReal = fromRational . toRational \ No newline at end of file
diff --git a/src/Texture.hs b/src/Texture.hs
new file mode 100644
index 0000000..bf89cf9
--- /dev/null
+++ b/src/Texture.hs
@@ -0,0 +1,8 @@
+module Texture ( Texture(..)
+ , TextureObject
+ ) where
+
+import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
+
+data Texture = TextureWood | TextureTank | TextureCannon | TextureBullet
+ deriving (Eq, Ord, Show)