Moved source files to src directory

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

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

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)

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

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

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

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

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

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
+            }

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

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

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)