From 7327695ca3d9aee5da1d0bc98572d877dd8c8546 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Tue, 9 Mar 2010 03:49:15 +0100 Subject: Moved source files to src directory --- Bindings/GLPng.hsc | 158 ----------------------------- Bindings/GLX.hsc | 265 ------------------------------------------------- CPUPlayer.hs | 19 ---- DefaultPlayer.hs | 36 ------- GLDriver.hs | 67 ------------- GLX.hs | 214 --------------------------------------- Game.hs | 52 ---------- HTanks.hs | 199 ------------------------------------- Level.hs | 18 ---- Paths_htanks.hs | 4 - Player.hs | 27 ----- Render.hs | 167 ------------------------------- Texture.hs | 8 -- htanks.cabal | 5 +- src/Bindings/GLPng.hsc | 158 +++++++++++++++++++++++++++++ src/Bindings/GLX.hsc | 265 +++++++++++++++++++++++++++++++++++++++++++++++++ src/CPUPlayer.hs | 19 ++++ src/DefaultPlayer.hs | 36 +++++++ src/GLDriver.hs | 67 +++++++++++++ src/GLX.hs | 214 +++++++++++++++++++++++++++++++++++++++ src/Game.hs | 52 ++++++++++ src/HTanks.hs | 199 +++++++++++++++++++++++++++++++++++++ src/Level.hs | 18 ++++ src/Player.hs | 27 +++++ src/Render.hs | 167 +++++++++++++++++++++++++++++++ src/Texture.hs | 8 ++ 26 files changed, 1233 insertions(+), 1236 deletions(-) delete mode 100644 Bindings/GLPng.hsc delete mode 100644 Bindings/GLX.hsc delete mode 100644 CPUPlayer.hs delete mode 100644 DefaultPlayer.hs delete mode 100644 GLDriver.hs delete mode 100644 GLX.hs delete mode 100644 Game.hs delete mode 100644 HTanks.hs delete mode 100644 Level.hs delete mode 100644 Paths_htanks.hs delete mode 100644 Player.hs delete mode 100644 Render.hs delete mode 100644 Texture.hs create mode 100644 src/Bindings/GLPng.hsc create mode 100644 src/Bindings/GLX.hsc create mode 100644 src/CPUPlayer.hs create mode 100644 src/DefaultPlayer.hs create mode 100644 src/GLDriver.hs create mode 100644 src/GLX.hs create mode 100644 src/Game.hs create mode 100644 src/HTanks.hs create mode 100644 src/Level.hs create mode 100644 src/Player.hs create mode 100644 src/Render.hs create mode 100644 src/Texture.hs diff --git a/Bindings/GLPng.hsc b/Bindings/GLPng.hsc deleted file mode 100644 index 453bddc..0000000 --- a/Bindings/GLPng.hsc +++ /dev/null @@ -1,158 +0,0 @@ -{-# 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 -#include - - -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/Bindings/GLX.hsc b/Bindings/GLX.hsc deleted file mode 100644 index d5fed4d..0000000 --- a/Bindings/GLX.hsc +++ /dev/null @@ -1,265 +0,0 @@ -{-# 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 - - -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/CPUPlayer.hs b/CPUPlayer.hs deleted file mode 100644 index 0276de3..0000000 --- a/CPUPlayer.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# 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/DefaultPlayer.hs b/DefaultPlayer.hs deleted file mode 100644 index af9aaf5..0000000 --- a/DefaultPlayer.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# 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/GLDriver.hs b/GLDriver.hs deleted file mode 100644 index 7340075..0000000 --- a/GLDriver.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# 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/GLX.hs b/GLX.hs deleted file mode 100644 index 6f5b0fc..0000000 --- a/GLX.hs +++ /dev/null @@ -1,214 +0,0 @@ -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/Game.hs b/Game.hs deleted file mode 100644 index b31009e..0000000 --- a/Game.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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/HTanks.hs b/HTanks.hs deleted file mode 100644 index 6d07cb6..0000000 --- a/HTanks.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# 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/Level.hs b/Level.hs deleted file mode 100644 index c99a4b5..0000000 --- a/Level.hs +++ /dev/null @@ -1,18 +0,0 @@ -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/Paths_htanks.hs b/Paths_htanks.hs deleted file mode 100644 index 7dd7e2a..0000000 --- a/Paths_htanks.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Paths_htanks where - -getDataFileName :: FilePath -> IO FilePath -getDataFileName = return diff --git a/Player.hs b/Player.hs deleted file mode 100644 index baf1cbe..0000000 --- a/Player.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# 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/Render.hs b/Render.hs deleted file mode 100644 index d1276a3..0000000 --- a/Render.hs +++ /dev/null @@ -1,167 +0,0 @@ -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/Texture.hs b/Texture.hs deleted file mode 100644 index bf89cf9..0000000 --- a/Texture.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Texture ( Texture(..) - , TextureObject - ) where - -import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) - -data Texture = TextureWood | TextureTank | TextureCannon | TextureBullet - deriving (Eq, Ord, Show) diff --git a/htanks.cabal b/htanks.cabal index 847d937..0a705e9 100644 --- a/htanks.cabal +++ b/htanks.cabal @@ -9,10 +9,11 @@ author: Matthias Schiffer maintainer: matthias@gamezock.de build-depends: base >= 4, syb, containers, mtl, time, X11, OpenGL build-type: Simple -data-files: tex/Bullet.png, tex/Cannon.png, tex/Tank.png, tex/Wood.png +data-files: tex/*.png executable: HTanks +hs-source-dirs: src main-is: HTanks.hs -other-modules: Bindings.GLX, Bindings.GLPng +other-modules: CPUPlayer, DefaultPlayer, Game, GLDriver, GLX, Level, Paths_htanks, Player, Render, Texture, Bindings.GLX, Bindings.GLPng ghc-options: -threaded extra-libraries: glpng 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 +#include + + +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 + + +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) -- cgit v1.2.3