From 5ec9db8534e74262d4fae74a080da80947b7dd24 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Mon, 7 Apr 2014 17:32:13 +0200 Subject: [PATCH 01/10] changed x-lens to _x-lens and cabal-info --- Pioneers.cabal | 11 +++++----- src/Main.hs | 58 +++++++++++++++++++++++--------------------------- src/Types.hs | 4 ++-- 3 files changed, 35 insertions(+), 38 deletions(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index faa8198..c9224a7 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -1,6 +1,6 @@ name: Pioneers version: 0.1 -cabal-version: >=1.2 +cabal-version: >= 1.18 build-type: Simple author: sdressel @@ -32,14 +32,15 @@ executable Pioneers text >=0.11, array >=0.4, random >=1.0.1, - transformers >=0.3.0 && <0.4, + transformers >=0.3.0, mtl >=2.1.2, stm >=2.4.2, vector >=0.10.9 && <0.11, - distributive >=0.3.2 && <0.4, - linear >=1.3.1 && <1.4, - lens >=3.10.1 && <3.11, + distributive >=0.3.2, + linear >=1.3.1, + lens >=4.0, SDL2 >= 0.1.0, time >=1.4.0 && <1.5, GLUtil >= 0.7 + Default-Language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs index b37fc93..e42e8a7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,17 +5,14 @@ import Data.Int (Int8) import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureSize2D) import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..)) import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D) -import Control.Monad (liftM) -import Foreign.Marshal.Array (pokeArray) -import Foreign.Marshal.Alloc (allocaBytes) import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (textureFilter) import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureTarget2D(Texture2D)) import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding) import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..)) -- Monad-foo and higher functional stuff -import Control.Monad (unless, void, when, join) -import Control.Arrow ((***)) +import Control.Monad (unless, void, when, join, liftM) +import Control.Arrow ((***)) -- data consistency/conversion import Control.Concurrent (threadDelay) @@ -31,11 +28,13 @@ import Data.Distributive (distribute, collect) import Foreign (Ptr, castPtr, with, sizeOf) import Foreign.C (CFloat) import Foreign.C.Types (CInt) +import Foreign.Marshal.Array (pokeArray) +import Foreign.Marshal.Alloc (allocaBytes) import Data.Word (Word8) -- Math import Control.Lens ((^.), (.~), (%~)) -import Linear as L +import qualified Linear as L -- GUI import Graphics.UI.SDL as SDL @@ -100,7 +99,7 @@ main = do --generate map vertices (mapBuffer, vert) <- getMapBufferObject (mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader - putStrLn $ show window + print window eventQueue <- newTQueueIO :: IO (TQueue Event) putStrLn "foo" now <- getCurrentTime @@ -160,8 +159,8 @@ main = do , _zDist = 10 , _frustum = frust , _camPosition = Types.Position - { Types._x = 25 - , Types._y = 25 + { Types.__x = 25 + , Types.__y = 25 } } , _io = IOState @@ -175,8 +174,8 @@ main = do , _dragStartXAngle = 0 , _dragStartYAngle = 0 , _mousePosition = Types.Position - { Types._x = 5 - , Types._y = 5 + { Types.__x = 5 + , Types.__y = 5 } } , _keyboard = KeyboardState @@ -222,16 +221,13 @@ draw = do numVert = state ^. gl.glMap.mapVert map' = state ^. gl.glMap.stateMap frust = state ^. camera.frustum - camX = state ^. camera.camPosition.x - camY = state ^. camera.camPosition.y + camX = state ^. camera.camPosition._x + camY = state ^. camera.camPosition._y zDist' = state ^. camera.zDist tessFac = state ^. gl.glMap.stateTessellationFactor window = env ^. windowObject rb = state ^. gl.glRenderbuffer - if state ^. ui.uiHasChanged then - prepareGUI - else - return () + when (state ^. ui . uiHasChanged) prepareGUI liftIO $ do --bind renderbuffer and set sample 0 as target --GL.bindRenderbuffer GL.Renderbuffer GL.$= rb @@ -278,23 +274,23 @@ draw = do checkError "setting up buffer" --set up projection (= copy from state) with (distribute frust) $ \ptr -> - glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) + glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat))) checkError "copy projection" --set up camera let ! cam = getCam (camX,camY) zDist' xa ya with (distribute cam) $ \ptr -> - glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) + glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat))) checkError "copy cam" --set up normal--Mat transpose((model*camera)^-1) - let normal = (case inv33 (fmap (^. _xyz) cam ^. _xyz) of + let normal = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of (Just a) -> a - Nothing -> eye3) :: M33 CFloat - nmap = collect id normal :: M33 CFloat --transpose... + Nothing -> L.eye3) :: L.M33 CFloat + nmap = collect id normal :: L.M33 CFloat --transpose... with (distribute nmap) $ \ptr -> - glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat))) + glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat))) checkError "nmat" @@ -379,8 +375,8 @@ run = do sody = state ^. mouse.dragStartY sodxa = state ^. mouse.dragStartXAngle sodya = state ^. mouse.dragStartYAngle - x' = state ^. mouse.mousePosition.x - y' = state ^. mouse.mousePosition.y + x' = state ^. mouse.mousePosition._x + y' = state ^. mouse.mousePosition._y myrot = (x' - sodx) / 2 mxrot = (y' - sody) / 2 newXAngle = curb (pi/12) (0.45*pi) newXAngle' @@ -404,8 +400,8 @@ run = do - 0.2 * kyrot * mults mody y' = y' + 0.2 * kxrot * mults - 0.2 * kyrot * multc - modify $ (camera.camPosition.x %~ modx) - . (camera.camPosition.y %~ mody) + modify $ (camera.camPosition._x %~ modx) + . (camera.camPosition._y %~ mody) {- --modify the state with all that happened in mt time. @@ -510,8 +506,8 @@ processEvent e = do Closing -> modify $ window.shouldClose .~ True Resized {windowResizedTo=size} -> do - modify $ (window.width .~ (sizeWidth size)) - . (window.height .~ (sizeHeight size)) + modify $ (window . width .~ sizeWidth size) + . (window . height .~ sizeHeight size) adjustWindow SizeChanged -> adjustWindow @@ -557,8 +553,8 @@ processEvent e = do . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) - modify $ (mouse.mousePosition. Types.x .~ (fromIntegral x)) - . (mouse.mousePosition. Types.y .~ (fromIntegral y)) + modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x)) + . (mouse.mousePosition. Types._y .~ (fromIntegral y)) MouseButton _ mouseId button state (SDL.Position x y) -> case button of LeftButton -> do diff --git a/src/Types.hs b/src/Types.hs index 29d9638..d5d262b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -26,8 +26,8 @@ data Env = Env --Mutable State data Position = Position - { _x :: !Double - , _y :: !Double + { __x :: !Double + , __y :: !Double } data WindowState = WindowState From 5077bfd793f87a4c8bfefa831e934409f55a13a0 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Wed, 9 Apr 2014 17:42:07 +0200 Subject: [PATCH 02/10] changed cabal-info --- Pioneers.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index c9224a7..27a407f 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -40,7 +40,7 @@ executable Pioneers linear >=1.3.1, lens >=4.0, SDL2 >= 0.1.0, - time >=1.4.0 && <1.5, + time >=1.4.0, GLUtil >= 0.7 Default-Language: Haskell2010 From a642c78c32e389321584966a98bfe11873eb23e9 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Wed, 9 Apr 2014 17:45:13 +0200 Subject: [PATCH 03/10] fixed indentation --- src/Main.hs | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index e42e8a7..c9963cb 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -68,24 +68,15 @@ import qualified Debug.Trace as D (trace) -------------------------------------------------------------------------------- main :: IO () main = do - SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute! -{- (window, renderer) <- SDL.createWindowAndRenderer (Size 1024 600) [WindowOpengl -- we want openGL - ,WindowShown -- window should be visible - ,WindowResizable -- and resizable - ,WindowInputFocus -- focused (=> active) - ,WindowMouseFocus -- Mouse into it - --,WindowInputGrabbed-- never let go of input (KB/Mouse) - ] -} - SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL + SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute! + SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL ,WindowShown -- window should be visible ,WindowResizable -- and resizable ,WindowInputFocus -- focused (=> active) ,WindowMouseFocus -- Mouse into it --,WindowInputGrabbed-- never let go of input (KB/Mouse) ] $ \window -> do - --mainGlContext <- SDL.glCreateContext window - withOpenGL window $ do - --TTF.withInit $ do + withOpenGL window $ do --Create Renderbuffer & Framebuffer -- We will render to this buffer to copy the result into textures From 40e3b6ed4dec9458ebbe841d2aee6c57b31cd38f Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Wed, 9 Apr 2014 20:04:06 +0200 Subject: [PATCH 04/10] started iqm-parser - can parse header - can parse initial texts - can parse mesh-structure - cannot parse everything else. --- Pioneers.cabal | 6 +- sample.iqm | Bin 0 -> 3104 bytes src/Importer/IQM/Parser.hs | 132 +++++++++++++++++++++++++++++++++++++ src/Importer/IQM/Types.hs | 60 +++++++++++++++++ src/Main.hs | 9 +++ 5 files changed, 206 insertions(+), 1 deletion(-) create mode 100644 sample.iqm create mode 100644 src/Importer/IQM/Parser.hs create mode 100644 src/Importer/IQM/Types.hs diff --git a/Pioneers.cabal b/Pioneers.cabal index 27a407f..48b2fc3 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -16,6 +16,9 @@ executable Pioneers Map.Graphics, Map.Creation, Map.StaticMaps, + IQM.Types, + IQM.TestMain, + IQM.Parser, Render.Misc, Render.Render, Render.RenderObject, @@ -41,6 +44,7 @@ executable Pioneers lens >=4.0, SDL2 >= 0.1.0, time >=1.4.0, - GLUtil >= 0.7 + GLUtil >= 0.7, + attoparsec >= 0.11.2 Default-Language: Haskell2010 diff --git a/sample.iqm b/sample.iqm new file mode 100644 index 0000000000000000000000000000000000000000..44a9d4607b18d9834d46352efe43593c03b4a54d GIT binary patch literal 3104 zcmeH}%}bO~6vl5;+LxwT*@rgs`jLfLOw_KXJ7%+xGAom4BO$nwDUI3%&bpP*CMv?9 zphY`f2$HYRB5GxSL17#JfHu+M?fK2T7cT?R8$zo&aOOVe+~=Ho&T&T0;MJRj8`nqs zFBgV}FBPtslrbh~(1&Ed^pSLnbXHm~Jt2K74aFGil1{XRb{PQ#bA+|<|; zyQn<%$^-UeeLSlCCzT(LAM3yCmukPO z0l&lWU2L`A^@!hLzn5yis|~-y@LjC$2fG@;ehogq@)xgtZhiu#a3jZ`aVEF292AP- zdSuTe!JXoYcR@edg(SFL+>S!gMp4s360Dpyt(sEi&e^1xy6F}E-*8)85BwxJqkg*; z13wAwjpqqJ35HjZl6A#y7Txl23qr#_dJyL~g%f-(ja?|6w=6 z)*58A_86^oWz1TK%}UrP-4o-c*lyOjSK1;4?~84Awgb{uDfnP)AJTbPdPE9ti|uxu zN2O^gI1}4}&JJm(6x=1n?v@^t_Qd#jY||Tk&?mjn7lKWF_z-$#CUEJAd&HjyJ#$Y^ zX22aMHnGfz{N!X#%!hm4VIJJ$V^+js<0mgZ=0+XZ%#Awmk&FD;_}yH|#T^{t$wl5s z^6~3CJGRtgi{lT%so~Gd6X{lqP77E5Pw`tVS>l~U(TsgOI6ePz^3}P?pEF@!UH|zH J&ps{r{NI61n*#s< literal 0 HcmV?d00001 diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs new file mode 100644 index 0000000..09efd9a --- /dev/null +++ b/src/Importer/IQM/Parser.hs @@ -0,0 +1,132 @@ +module Importer.IQM.Parser where + +import Importer.IQM.Types +import Data.Attoparsec.ByteString.Char8 +import Data.Attoparsec.ByteString +import Data.Attoparsec +import Data.ByteString.Char8 (pack) +import Data.ByteString (split, null) +import Data.Word +import Data.Int +import Data.List (foldl1) +import Foreign.C.Types +import Unsafe.Coerce + +import Prelude as P hiding (take, null) + +w8Toint :: Integral a => a -> a -> a +w8Toint i add = 256*i + add + + +int16 :: Parser Int16 +int16 = do + a <- anyWord8 :: Parser Word8 + b <- anyWord8 :: Parser Word8 + return $ foldl1 w8Toint $ map fromIntegral [b,a] + +int32 :: Parser Int32 +int32 = do + a <- anyWord8 :: Parser Word8 + b <- anyWord8 :: Parser Word8 + c <- anyWord8 :: Parser Word8 + d <- anyWord8 :: Parser Word8 + return $ foldl1 w8Toint $ map fromIntegral [d,c,b,a] + +readHeader = do + string (pack "INTERQUAKEMODEL\0") + v <- int32 + -- when v /= 2 then --TODO: error something + size <- int32 + flags <- int32 + num_text <- int32 + ofs_text <- int32 + num_meshes <- int32 + ofs_meshes <- int32 + num_vertexarrays <- int32 + num_vertexes <- int32 + ofs_vertexarrays <- int32 + num_triangles <- int32 + ofs_triangles <- int32 + ofs_adjacency <- int32 + num_joints <- int32 + ofs_joints <- int32 + num_poses <- int32 + ofs_poses <- int32 + num_anims <- int32 + ofs_anims <- int32 + num_frames <- int32 + num_framechannels <- int32 + ofs_frames <- int32 + ofs_bounds <- int32 + num_comment <- int32 + ofs_comment <- int32 + num_extensions <- int32 + ofs_extensions <- int32 + return (IQMHeader { version = v + , filesize = size + , flags = flags + , num_text = num_text + , ofs_text = ofs_text + , num_meshes = num_meshes + , ofs_meshes = ofs_meshes + , num_vertexarrays = num_vertexarrays + , num_vertexes = num_vertexes + , ofs_vertexarrays = ofs_vertexarrays + , num_triangles = num_triangles + , ofs_triangles = ofs_triangles + , ofs_adjacency = ofs_adjacency + , num_joints = num_joints + , ofs_joints = ofs_joints + , num_poses = num_poses + , ofs_poses = ofs_poses + , num_anims = num_anims + , ofs_anims = ofs_anims + , num_frames = num_frames + , num_framechannels = num_framechannels + , ofs_frames = ofs_frames + , ofs_bounds = ofs_bounds + , num_comment = num_comment + , ofs_comment = ofs_comment + , num_extensions = num_extensions + , ofs_extensions = ofs_extensions + } + , 16+27*4) + +readMesh :: Parser IQMMesh +readMesh = do + name <- int32 + mat <- int32 + fv <- int32 + nv <- int32 + ft <- int32 + nt <- int32 + return IQMMesh + { meshName = if name == 0 then Nothing else Just (Mesh name) + , meshMaterial = mat + , meshFirstVertex = fv + , meshNumVertexes = nv + , meshFirstTriangle = ft + , meshNumTriangles = nt + } + +readMeshes :: Int -> Parser [IQMMesh] +readMeshes 1 = do + m <- readMesh + return [m] +readMeshes n = do + m <- readMesh + ms <- readMeshes (n-1) + return $ m:ms + +parseIQM :: Parser IQM +parseIQM = do + (h,soFar) <- readHeader + take $ (fromIntegral (ofs_text h)) - soFar + text <- take $ fromIntegral $ num_text h + meshes <- readMeshes (fromIntegral (num_meshes h)) + return IQM + { header = h + , texts = filter (not.null) (split (unsafeCoerce '\0') text) + , meshes = meshes + } + \ No newline at end of file diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs new file mode 100644 index 0000000..8222e85 --- /dev/null +++ b/src/Importer/IQM/Types.hs @@ -0,0 +1,60 @@ +module Importer.IQM.Types where + +import Data.Int +import Data.ByteString + +newtype Mesh = Mesh Int32 deriving (Show, Eq) +newtype CParser a = Parser (a, Int64) + +-- Int32 or Int64 - depending on implementation. Format just specifies "uint". +-- 4-Byte indicates Int32 + +-- | ofs_* fields are relative tot he beginning of the iqmheader struct +-- ofs_* fields are set to 0 when data is empty +-- ofs_* fields are aligned at 4-byte-boundaries +data IQMHeader = IQMHeader + { version :: Int32 -- ^ Must be 2 + , filesize :: Int32 + , flags :: Int32 + , num_text :: Int32 + , ofs_text :: Int32 + , num_meshes :: Int32 + , ofs_meshes :: Int32 + , num_vertexarrays :: Int32 + , num_vertexes :: Int32 + , ofs_vertexarrays :: Int32 + , num_triangles :: Int32 + , ofs_triangles :: Int32 + , ofs_adjacency :: Int32 + , num_joints :: Int32 + , ofs_joints :: Int32 + , num_poses :: Int32 + , ofs_poses :: Int32 + , num_anims :: Int32 + , ofs_anims :: Int32 + , num_frames :: Int32 + , num_framechannels :: Int32 + , ofs_frames :: Int32 + , ofs_bounds :: Int32 + , num_comment :: Int32 + , ofs_comment :: Int32 + , num_extensions :: Int32 -- ^ stored as linked list, not as array. + , ofs_extensions :: Int32 + } deriving (Show, Eq) + + +data IQMMesh = IQMMesh + { meshName :: Maybe Mesh + , meshMaterial :: Int32 + , meshFirstVertex :: Int32 + , meshNumVertexes :: Int32 + , meshFirstTriangle :: Int32 + , meshNumTriangles :: Int32 + } deriving (Show, Eq) + +data IQM = IQM + { header :: IQMHeader + , texts :: [ByteString] + , meshes :: [IQMMesh] + } deriving (Show, Eq) + \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index c9963cb..a8283e4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -60,12 +60,21 @@ import Render.Render (initRendering, import UI.Callbacks import UI.GUIOverlay import Types +import Importer.IQM.Parser +import Data.Attoparsec.Char8 (parseTest) +import qualified Data.ByteString as B --import ThirdParty.Flippers import qualified Debug.Trace as D (trace) -------------------------------------------------------------------------------- + +testParser = do + B.readFile "sample.iqm" >>= parseTest parseIQM + +-------------------------------------------------------------------------------- + main :: IO () main = do SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute! From 6104e7349b6fa22fae5b67206f412696eefe51da Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Mon, 14 Apr 2014 19:48:40 +0200 Subject: [PATCH 05/10] changed cabal-version back to 1.16 --- Pioneers.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index 48b2fc3..0c2be9b 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -1,6 +1,6 @@ name: Pioneers version: 0.1 -cabal-version: >= 1.18 +cabal-version: >= 1.16 build-type: Simple author: sdressel From b0e78033e5122c110f4428c8012cea648be66207 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 15 Apr 2014 06:43:49 +0200 Subject: [PATCH 06/10] rewrote Parser now uses Parser a in Combination with StateT Int64 a yielding type CParser a = StateT Int64 Parser a So now the parser Counts how many Bytes get read. This can be used by the get-function to get the currently read bytes. --- src/Importer/IQM/Parser.hs | 183 +++++++++++++++++++++---------------- src/Importer/IQM/Types.hs | 6 +- src/Main.hs | 6 +- 3 files changed, 111 insertions(+), 84 deletions(-) diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index 09efd9a..932d0a2 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -1,98 +1,108 @@ +{-# LANGUAGE RankNTypes #-} + module Importer.IQM.Parser where import Importer.IQM.Types import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.ByteString -import Data.Attoparsec import Data.ByteString.Char8 (pack) import Data.ByteString (split, null) import Data.Word import Data.Int -import Data.List (foldl1) -import Foreign.C.Types import Unsafe.Coerce +import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import Control.Monad import Prelude as P hiding (take, null) -w8Toint :: Integral a => a -> a -> a -w8Toint i add = 256*i + add +w8ToInt :: Integral a => a -> a -> a +w8ToInt i add = 256*i + add +parseNum :: (Integral a, Integral b) => [a] -> b +parseNum = (foldl1 w8ToInt) . map fromIntegral -int16 :: Parser Int16 +int16 :: CParser Int16 int16 = do - a <- anyWord8 :: Parser Word8 - b <- anyWord8 :: Parser Word8 - return $ foldl1 w8Toint $ map fromIntegral [b,a] - -int32 :: Parser Int32 + ret <- lift $ do + a <- anyWord8 :: Parser Word8 + b <- anyWord8 :: Parser Word8 + return $ parseNum [b,a] + modify (+2) + return ret + +int32 :: CParser Int32 int32 = do - a <- anyWord8 :: Parser Word8 - b <- anyWord8 :: Parser Word8 - c <- anyWord8 :: Parser Word8 - d <- anyWord8 :: Parser Word8 - return $ foldl1 w8Toint $ map fromIntegral [d,c,b,a] + ret <- lift $ do + a <- anyWord8 :: Parser Word8 + b <- anyWord8 :: Parser Word8 + c <- anyWord8 :: Parser Word8 + d <- anyWord8 :: Parser Word8 + return $ parseNum [d,c,b,a] + modify (+4) + return $ ret +readHeader :: CParser IQMHeader readHeader = do - string (pack "INTERQUAKEMODEL\0") + _ <- lift $ string (pack "INTERQUAKEMODEL\0") v <- int32 -- when v /= 2 then --TODO: error something - size <- int32 - flags <- int32 - num_text <- int32 - ofs_text <- int32 - num_meshes <- int32 - ofs_meshes <- int32 - num_vertexarrays <- int32 - num_vertexes <- int32 - ofs_vertexarrays <- int32 - num_triangles <- int32 - ofs_triangles <- int32 - ofs_adjacency <- int32 - num_joints <- int32 - ofs_joints <- int32 - num_poses <- int32 - ofs_poses <- int32 - num_anims <- int32 - ofs_anims <- int32 - num_frames <- int32 - num_framechannels <- int32 - ofs_frames <- int32 - ofs_bounds <- int32 - num_comment <- int32 - ofs_comment <- int32 - num_extensions <- int32 - ofs_extensions <- int32 - return (IQMHeader { version = v - , filesize = size - , flags = flags - , num_text = num_text - , ofs_text = ofs_text - , num_meshes = num_meshes - , ofs_meshes = ofs_meshes - , num_vertexarrays = num_vertexarrays - , num_vertexes = num_vertexes - , ofs_vertexarrays = ofs_vertexarrays - , num_triangles = num_triangles - , ofs_triangles = ofs_triangles - , ofs_adjacency = ofs_adjacency - , num_joints = num_joints - , ofs_joints = ofs_joints - , num_poses = num_poses - , ofs_poses = ofs_poses - , num_anims = num_anims - , ofs_anims = ofs_anims - , num_frames = num_frames - , num_framechannels = num_framechannels - , ofs_frames = ofs_frames - , ofs_bounds = ofs_bounds - , num_comment = num_comment - , ofs_comment = ofs_comment - , num_extensions = num_extensions - , ofs_extensions = ofs_extensions + size' <- int32 + flags' <- int32 + num_text' <- int32 + ofs_text' <- int32 + num_meshes' <- int32 + ofs_meshes' <- int32 + num_vertexarrays' <- int32 + num_vertexes' <- int32 + ofs_vertexarrays' <- int32 + num_triangles' <- int32 + ofs_triangles' <- int32 + ofs_adjacency' <- int32 + num_joints' <- int32 + ofs_joints' <- int32 + num_poses' <- int32 + ofs_poses' <- int32 + num_anims' <- int32 + ofs_anims' <- int32 + num_frames' <- int32 + num_framechannels' <- int32 + ofs_frames' <- int32 + ofs_bounds' <- int32 + num_comment' <- int32 + ofs_comment' <- int32 + num_extensions' <- int32 + ofs_extensions' <- int32 + return IQMHeader { version = v + , filesize = size' + , flags = flags' + , num_text = num_text' + , ofs_text = ofs_text' + , num_meshes = num_meshes' + , ofs_meshes = ofs_meshes' + , num_vertexarrays = num_vertexarrays' + , num_vertexes = num_vertexes' + , ofs_vertexarrays = ofs_vertexarrays' + , num_triangles = num_triangles' + , ofs_triangles = ofs_triangles' + , ofs_adjacency = ofs_adjacency' + , num_joints = num_joints' + , ofs_joints = ofs_joints' + , num_poses = num_poses' + , ofs_poses = ofs_poses' + , num_anims = num_anims' + , ofs_anims = ofs_anims' + , num_frames = num_frames' + , num_framechannels = num_framechannels' + , ofs_frames = ofs_frames' + , ofs_bounds = ofs_bounds' + , num_comment = num_comment' + , ofs_comment = ofs_comment' + , num_extensions = num_extensions' + , ofs_extensions = ofs_extensions' } - , 16+27*4) -readMesh :: Parser IQMMesh +readMesh :: CParser IQMMesh readMesh = do name <- int32 mat <- int32 @@ -109,7 +119,7 @@ readMesh = do , meshNumTriangles = nt } -readMeshes :: Int -> Parser [IQMMesh] +readMeshes :: Int -> CParser [IQMMesh] readMeshes 1 = do m <- readMesh return [m] @@ -117,16 +127,27 @@ readMeshes n = do m <- readMesh ms <- readMeshes (n-1) return $ m:ms - -parseIQM :: Parser IQM + +(.-) :: forall a a1 a2. + (Num a, Integral a2, Integral a1) => + a1 -> a2 -> a +(.-) a b = (fromIntegral a) - (fromIntegral b) + +infix 5 .- + +parseIQM :: CParser IQM parseIQM = do - (h,soFar) <- readHeader - take $ (fromIntegral (ofs_text h)) - soFar - text <- take $ fromIntegral $ num_text h - meshes <- readMeshes (fromIntegral (num_meshes h)) + put 0 + h <- readHeader + soFar <- get + _ <- lift $ take $ ofs_text h .- soFar + text <- lift $ take $ fromIntegral $ num_text h + soFar <- get + _ <- lift $ take $ ofs_meshes h .- soFar + meshes' <- readMeshes (fromIntegral (num_meshes h)) return IQM { header = h , texts = filter (not.null) (split (unsafeCoerce '\0') text) - , meshes = meshes + , meshes = meshes' } - \ No newline at end of file + diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index 8222e85..7dabaf6 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -2,9 +2,11 @@ module Importer.IQM.Types where import Data.Int import Data.ByteString +import Data.Attoparsec.ByteString.Char8 +import Control.Monad.Trans.State.Lazy (StateT) newtype Mesh = Mesh Int32 deriving (Show, Eq) -newtype CParser a = Parser (a, Int64) +type CParser a = StateT Int64 Parser a -- Int32 or Int64 - depending on implementation. Format just specifies "uint". -- 4-Byte indicates Int32 @@ -57,4 +59,4 @@ data IQM = IQM , texts :: [ByteString] , meshes :: [IQMMesh] } deriving (Show, Eq) - \ No newline at end of file + diff --git a/src/Main.hs b/src/Main.hs index a8283e4..4a32161 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -22,6 +22,8 @@ import Control.Concurrent.STM (TQueue, import Control.Monad.RWS.Strict (RWST, ask, asks, evalRWST, get, liftIO, modify, put) +import Control.Monad.Trans.Class +import Control.Monad.Trans.State (evalStateT) import Data.Distributive (distribute, collect) -- FFI @@ -70,8 +72,10 @@ import qualified Debug.Trace as D (trace) -------------------------------------------------------------------------------- +testParser :: IO () testParser = do - B.readFile "sample.iqm" >>= parseTest parseIQM + f <- B.readFile "sample.iqm" + parseTest (evalStateT parseIQM 0) f -------------------------------------------------------------------------------- From 7b54ec9006d5a9dfe61e50eeee7555ca845549eb Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 15 Apr 2014 07:17:45 +0200 Subject: [PATCH 07/10] improved Parser and added documentation --- src/Importer/IQM/Parser.hs | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index 932d0a2..29fc148 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -135,16 +135,23 @@ readMeshes n = do infix 5 .- +skipToCounter :: Integral a => a -> CParser () +skipToCounter a = do + let d = fromIntegral a + c <- get + when (d < c) $ fail "wanting to skip to counter already passed" + _ <- lift $ take $ d .- c + put d + parseIQM :: CParser IQM parseIQM = do - put 0 - h <- readHeader - soFar <- get - _ <- lift $ take $ ofs_text h .- soFar - text <- lift $ take $ fromIntegral $ num_text h - soFar <- get - _ <- lift $ take $ ofs_meshes h .- soFar - meshes' <- readMeshes (fromIntegral (num_meshes h)) + put 0 --start at offset 0 + h <- readHeader --read header + skipToCounter $ ofs_text h --skip 0-n bytes to get to text + text <- lift . take . fromIntegral $ num_text h --read texts + modify . (+) . fromIntegral $ num_text h --put offset forward + skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes + meshes' <- readMeshes (fromIntegral (num_meshes h)) --read meshes return IQM { header = h , texts = filter (not.null) (split (unsafeCoerce '\0') text) From 413c74c0a728b499671547f6438b4786cbdac31c Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 15 Apr 2014 08:59:53 +0200 Subject: [PATCH 08/10] minor stuff --- src/Main.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index 4a32161..259ff7f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -24,7 +24,9 @@ import Control.Monad.RWS.Strict (RWST, ask, asks, modify, put) import Control.Monad.Trans.Class import Control.Monad.Trans.State (evalStateT) +import Data.Functor ((<$>)) import Data.Distributive (distribute, collect) +import Data.Monoid (mappend) -- FFI import Foreign (Ptr, castPtr, with, sizeOf) @@ -200,7 +202,8 @@ main = do } putStrLn "init done." - void $ evalRWST (adjustWindow >> run) env state + uncurry mappend <$> evalRWST (adjustWindow >> run) env state + putStrLn "shutdown complete." --SDL.glDeleteContext mainGlContext --SDL.destroyRenderer renderer From d0ce4dcf6aec0f28a00892ab4da46b6ce3aad259 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 15 Apr 2014 17:03:54 +0200 Subject: [PATCH 09/10] fixed compiler warnings. most of them .. not all are my modules. --- src/Main.deprecated.hs | 529 ---------------------------- src/Main.glfw.deprecated.hs | 665 ------------------------------------ src/Main.hs | 143 ++++---- src/PioneerTypes.hs | 8 +- src/Render/Misc.hs | 7 +- src/Render/Render.hs | 9 +- src/Types.hs | 2 +- 7 files changed, 71 insertions(+), 1292 deletions(-) delete mode 100644 src/Main.deprecated.hs delete mode 100644 src/Main.glfw.deprecated.hs diff --git a/src/Main.deprecated.hs b/src/Main.deprecated.hs deleted file mode 100644 index 7cd2f5f..0000000 --- a/src/Main.deprecated.hs +++ /dev/null @@ -1,529 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main where - -import Graphics.UI.Gtk (AttrOp ((:=))) -import qualified Graphics.UI.Gtk as Gtk -import qualified Graphics.UI.Gtk.OpenGL as GtkGL - -import qualified Data.Array.IArray as A -import Graphics.Rendering.OpenGL as GL -import qualified Graphics.UI.Gtk.Gdk.EventM as Event - -import Map.Coordinates -import Map.Map - -import Data.IntSet as IS -import Data.IORef -import Data.Maybe (fromMaybe) -import Debug.Trace - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Foreign.Ptr (nullPtr) -import GHC.Conc.Sync (unsafeIOToSTM) -import Prelude as P -import System.IO.Unsafe (unsafePerformIO) -import Foreign.Marshal.Array (allocaArray) -import Render.Misc (dumpInfo) - -data ProgramState = PS { keysPressed :: IntSet - , px :: GLfloat - , py :: GLfloat - , pz :: GLfloat - , heading :: GLfloat - , pitch :: GLfloat - , dx :: GLfloat - , dy :: GLfloat - , dz :: GLfloat - , dheading :: GLfloat - , dpitch :: GLfloat - , showShadowMap :: Bool } - deriving (Show) - -type RenderObject = (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat]) - -(Vertex4 a b c d) .+ (Vertex4 w x y z) = Vertex4 (a+w) (b+x) (c+y) (d+z) -(Vertex4 a b c d) .* e = Vertex4 (a*e) (b*e) (c*e) (d*e) - -animationWaitTime = 3 :: Int -canvasWidth = 1024 :: Int -canvasHeight = 768 :: Int -deltaV = 0.10 -deltaH = 0.5 -deltaP = 0.15 -black = Color3 0 0 0 :: Color3 GLfloat -shadowMapSize :: TextureSize2D -shadowMapSize = TextureSize2D 512 512 - -up :: Vector3 GLdouble -up = Vector3 0 1 0 - -origin :: Vertex3 GLdouble -origin = Vertex3 0 0 0 - -sun = Light 0 - --- TODO: Put render-stuff in render-modul - ---gets Sun position in given format -getSunPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a -getSunPos f = do - Vertex4 x y z _ <- get (position sun) - return $ f (realToFrac x) (realToFrac y) (realToFrac z) - -glTexCoord2f (x,y) = texCoord (TexCoord2 x y :: TexCoord2 GLfloat) -glVertex3f (x,y,z) = vertex (Vertex3 x y z :: Vertex3 GLfloat) -glNormal3f (x,y,z) = normal (Normal3 x y z :: Normal3 GLfloat) - -prepareRenderTile :: PlayMap -> ((Int,Int),MapEntry) -> (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat]) -prepareRenderTile m (c@(cx,cz),(_,t)) = - ( - Vector3 (1.5 * fromIntegral cx) 0.0 - (if even cx then 2 * fromIntegral cz else - 2 * fromIntegral cz - 1) - , - case t of - Water -> Color3 0.5 0.5 1 :: Color3 GLfloat - Grass -> Color3 0.3 0.9 0.1 :: Color3 GLfloat - Sand -> Color3 0.9 0.85 0.7 :: Color3 GLfloat - Mountain -> Color3 0.5 0.5 0.5 :: Color3 GLfloat - ,getTileVertices m c) - -renderTile :: RenderObject -> IO () -renderTile (coord,c,ts) = - preservingMatrix $ do - translate coord - {-color black - lineWidth $= 4.0 - lineSmooth $= Enabled - _ <- renderPrimitive LineLoop $ do - glNormal3f(0.0,0.0,1.0) - mapM vertex ts-} - color c - _ <- renderPrimitive Polygon $ do - glNormal3f(0.0,1.0,0.0) - mapM vertex ts - return () - -drawSphere :: IO () -drawSphere = renderQuadric - (QuadricStyle (Just Smooth) GenerateTextureCoordinates Outside - FillStyle) - (Sphere 2.0 48 48) - -drawObjects :: [RenderObject] -> [RenderObject] -> Bool -> IO () -drawObjects map ent shadowRender = do - textureOn <- get (texture Texture2D) --are textures enabled? - - when shadowRender $ - texture Texture2D $= Disabled --disable textures if we render shadows. - - --draw something throwing shadows - preservingMatrix $ do - pos <- getSunPos Vector3 - translate $ fmap (+ (-15.0)) pos - drawSphere - preservingMatrix $ do - pos <- getSunPos Vector3 - translate $ fmap (+ (-10.0)) pos - drawSphere - --draw sun-indicator - {- preservingMatrix $ do - pos <- getSunPos Vector3 - translate pos - color (Color4 1.0 1.0 0.0 1.0 :: Color4 GLfloat) - drawSphere - --putStrLn $ unwords ["sun at", show pos] - -- -} - --draw map - mapM_ renderTile map - - - when (shadowRender && textureOn == Enabled) $ --reset texture-rendering - texture Texture2D $= Enabled - --- OpenGL polygon-function for drawing stuff. -display :: MVar ProgramState -> PlayMap -> IO () -display state t = - let - -- Todo: have tiles static somewhere .. dont calculate every frame - tiles = P.map (prepareRenderTile t) (A.assocs t) - in - do - ps@PS { - px = px - , py = py - , pz = pz - , pitch = pitch - , heading = heading - , showShadowMap = showShadowMap } - <- readMVar state - loadIdentity - GL.rotate pitch (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat) - GL.rotate heading (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat) - translate (Vector3 (-px) (-py) (-pz)::Vector3 GLfloat) - - generateShadowMap tiles [] - generateTextureMatrix - unless showShadowMap $ do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - drawObjects tiles [] False - - return () - -updateCamera :: MVar ProgramState -> IO () -updateCamera state = do - ps@PS { dx = dx - , dy = dy - , dz = dz - , px = px - , py = py - , pz = pz - , pitch = pitch - , heading = heading - , dpitch = dpitch - , dheading = dheading - } - <- takeMVar state - - d@((dx,dy,dz),(heading',pitch')) <- - if any (/= 0.0) [dx,dy,dz,dpitch,dheading] then - preservingMatrix $ do - -- putStrLn $ unwords $ P.map show [dx,dy,dz,dpitch,dheading] - loadIdentity - - -- in direction of current heading and pitch - rotate (-heading) (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat) - rotate (-pitch) (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat) - - -- perform motion - translate (Vector3 (-dx) (-dy) (-dz)) - - - -- get changes in location components - mat <- get (matrix Nothing) :: IO (GLmatrix GLfloat) - comps <- getMatrixComponents ColumnMajor mat - -- putStrLn $ show $ comps - let [dx', dy', dz', _] = drop 12 comps - (heading', pitch') = (heading + dheading, pitch + dpitch) - return ((dx',dy',dz'),(heading',pitch')) - else - return ((0,0,0),(heading, pitch)) - putMVar state ps { px = px + dx - , py = py + dy - , pz = pz + dz - , pitch = pitch' - , heading = heading' - } - --- Note: preservingViewport is not exception safe, but it doesn't matter here -preservingViewport :: IO a -> IO a -preservingViewport act = do - v <- get viewport - x <- act - viewport $= v - return x - -generateTextureMatrix :: IO () -generateTextureMatrix = do - -- Set up projective texture matrix. We use the Modelview matrix stack and - -- OpenGL matrix commands to make the matrix. - m <- preservingMatrix $ do - loadIdentity - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - translatef (Vector3 0.5 0.5 0.0) - scalef 0.5 0.5 1.0 - ortho (-20) 20 (-20) 20 1 100 - lightPos' <- getSunPos Vertex3 - lookAt lightPos' origin up - get (matrix (Just (Modelview 0))) - - [ sx, sy, sz, sw, - tx, ty, tz, tw, - rx, ry, rz, rw, - qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble) - - textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw)) - textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw)) - textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw)) - textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw)) - -generateShadowMap :: [RenderObject] -> [RenderObject] -> IO () -generateShadowMap tiles obj = do - lightPos' <- getSunPos Vertex3 - let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize - shadowMapSize' = Size shadowMapWidth shadowMapHeight - - preservingViewport $ do - viewport $= (Position 0 0, shadowMapSize') - - clear [ ColorBuffer, DepthBuffer ] - - cullFace $= Just Front -- only backsides cast shadows -> less polys - - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - ortho (-20) 20 (-20) 20 10 100 - matrixMode $= Modelview 0 - preservingMatrix $ do - loadIdentity - lookAt lightPos' origin up - drawObjects tiles obj True - matrixMode $= Projection - matrixMode $= Modelview 0 - - copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0 - - cullFace $= Just Back - - when True $ do - let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight) - allocaArray numShadowMapPixels $ \depthImage -> do - let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat - readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent) - (_, Size viewPortWidth _) <- get viewport - windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0) - drawPixels shadowMapSize' (pixelData Luminance) - ---Adjust size to given dimensions -reconfigure :: Int -> Int -> IO (Int, Int) -reconfigure w h = do - -- maintain aspect ratio - let aspectRatio = fromIntegral canvasWidth / fromIntegral canvasHeight - (w1, h1) = (fromIntegral w, fromIntegral w / aspectRatio) - (w2, h2) = (fromIntegral h * aspectRatio, fromIntegral h) - (w', h') = if h1 <= fromIntegral h - then (floor w1, floor h1) - else (floor w2, floor h2) - reshape $ Just (w', h') - return (w', h') - --- Called by reconfigure to fix the OpenGL viewport according to the --- dimensions of the widget, appropriately. -reshape :: Maybe (Int, Int) -> IO () -reshape dims = do - let (width, height) = fromMaybe (canvasWidth, canvasHeight) dims - viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height)) - matrixMode $= Projection - loadIdentity - let (w, h) = if width <= height - then (fromIntegral height, fromIntegral width ) - else (fromIntegral width, fromIntegral height) - -- open, aspect-ratio, near-plane, far-plane - perspective 60.0 (fromIntegral canvasWidth / fromIntegral canvasHeight) 1.0 100.0 - matrixMode $= Modelview 0 - loadIdentity - -keyEvent state press = do - code <- Event.eventHardwareKeycode - val <- Event.eventKeyVal - mods <- Event.eventModifier - name <- Event.eventKeyName - liftIO $ do - ps@PS { keysPressed = kp - , dx = dx - , dy = dy - , dz = dz - , px = px - , py = py - , pz = pz - , pitch = pitch - , heading = heading - , dpitch = dpitch - , dheading = dheading - , showShadowMap = showShadowMap } - <- takeMVar state - -- Only process the key event if it is not a repeat - (ps',ret) <- if (fromIntegral code `member` kp && not press) || - (fromIntegral code `notMember` kp && press) - then let - accept a = return (a, True) - deny a = return (a, False) - in do - -- keep list of pressed keys up2date - ps <- return (if not press then - (ps{keysPressed = fromIntegral code `delete` kp}) - else - (ps{keysPressed = fromIntegral code `insert` kp})) - putStrLn $ unwords [name , show val, show code, show ps] -- trace (unwords [name , show val]) -- debugging - -- process keys - case press of - -- on PRESS only - True - | code == 9 -> Gtk.mainQuit >> deny ps - | code == 26 -> accept $ ps { dz = dz + deltaV } - | code == 40 -> accept $ ps { dz = dz - deltaV } - | code == 39 -> accept $ ps { dx = dx + deltaV } - | code == 41 -> accept $ ps { dx = dx - deltaV } - | code == 65 -> accept $ ps { dy = dy - deltaV } - | code == 66 -> accept $ ps { dy = dy + deltaV } - | code == 25 -> accept $ ps { dheading = dheading - deltaH } - | code == 27 -> accept $ ps { dheading = dheading + deltaH } - | code == 42 -> accept $ ps { showShadowMap = not showShadowMap } - | code == 31 -> dumpInfo >> accept ps - | otherwise -> deny ps - -- on RELEASE only - False - | code == 26 -> accept $ ps { dz = dz - deltaV } - | code == 40 -> accept $ ps { dz = dz + deltaV } - | code == 39 -> accept $ ps { dx = dx - deltaV } - | code == 41 -> accept $ ps { dx = dx + deltaV } - | code == 65 -> accept $ ps { dy = dy + deltaV } - | code == 66 -> accept $ ps { dy = dy - deltaV } - | code == 25 -> accept $ ps { dheading = dheading + deltaH } - | code == 27 -> accept $ ps { dheading = dheading - deltaH } - | otherwise -> deny ps - else return (ps, False) - putMVar state ps' - return ret - -main :: IO () -main = do - ! terrain <- testmap - -- create TVar using unsafePerformIO -> currently no other thread -> OK - state <- newMVar PS { keysPressed = IS.empty - , px = 7.5 - , py = 20 - , pz = 15 - , heading = 0 - , pitch = 60 - , dx = 0 - , dy = 0 - , dz = 0 - , dheading = 0 - , dpitch = 0 - , showShadowMap = False } - trace (show terrain) Gtk.initGUI - -- Initialise the Gtk+ OpenGL extension - -- (including reading various command line parameters) - GtkGL.initGL - - -- We need a OpenGL frame buffer configuration to be able to create other - -- OpenGL objects. - glconfig <- GtkGL.glConfigNew [GtkGL.GLModeRGBA, - GtkGL.GLModeDepth, - GtkGL.GLModeDouble] - - -- Create an OpenGL drawing area widget - canvas <- GtkGL.glDrawingAreaNew glconfig - - Gtk.widgetSetSizeRequest canvas canvasWidth canvasHeight - - -- Initialise some GL setting just before the canvas first gets shown - -- (We can't initialise these things earlier since the GL resources that - -- we are using wouldn't heve been setup yet) - Gtk.onRealize canvas $ GtkGL.withGLDrawingArea canvas $ \_ -> do - reconfigure canvasWidth canvasHeight - --set up shadow-map - texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0 - (PixelData DepthComponent UnsignedByte nullPtr) - - materialAmbient Front $= Color4 0.4 0.4 0.4 1.0 - materialDiffuse Front $= Color4 0.4 0.4 0.4 1.0 - materialSpecular Front $= Color4 0.8 0.8 0.8 1.0 - materialShininess Front $= 25.0 - - ambient sun $= Color4 0.3 0.3 0.3 1.0 - diffuse sun $= Color4 1.0 1.0 1.0 1.0 - specular sun $= Color4 0.8 0.8 0.8 1.0 - lightModelAmbient $= Color4 0.2 0.2 0.2 1.0 - position sun $= (Vertex4 2.0 1.0 1.3 1.0 :: Vertex4 GLfloat) .* (1/2.5865) .* 45 - spotDirection sun $= (Normal3 (2.0) (1.0) (1.3) :: Normal3 GLfloat) - --spotExponent sun $= 1.0 - --attenuation sun $= (1.0, 0.0, 0.0) - - lighting $= Enabled - light sun $= Enabled - depthFunc $= Just Less - shadeModel $= Smooth - --lightModelLocalViewer $= Enabled - --vertexProgramTwoSide $= Enabled - - clearColor $= Color4 0.0 0.0 0.0 0.0 - drawBuffer $= BackBuffers - colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) - - frontFace $= CCW - cullFace $= Just Back - - texture Texture2D $= Enabled - - textureWrapMode Texture2D S $= (Repeated, ClampToEdge) - textureWrapMode Texture2D T $= (Repeated, ClampToEdge) - textureFilter Texture2D $= ((Linear', Nothing), Linear') - textureCompareMode Texture2D $= Just Lequal - depthTextureMode Texture2D $= Luminance' - - shadeModel $= Smooth - - fog $= Enabled - fogMode $= Linear 45.0 50.0 - fogColor $= Color4 0.5 0.5 0.5 1.0 - fogDistanceMode $= EyeRadial - - - return () - {-clearColor $= (Color4 0.0 0.0 0.0 0.0) - matrixMode $= Projection - loadIdentity - ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0 - depthFunc $= Just Less - drawBuffer $= BackBuffers-} - - -- Set the repaint handler - Gtk.onExpose canvas $ \_ -> do - GtkGL.withGLDrawingArea canvas $ \glwindow -> do - GL.clear [GL.DepthBuffer, GL.ColorBuffer] - display state terrain - GtkGL.glDrawableSwapBuffers glwindow - return True - - -- Setup the animation - Gtk.timeoutAddFull (do - updateCamera state - Gtk.widgetQueueDraw canvas - return True) - Gtk.priorityDefaultIdle animationWaitTime - - -------------------------------- - -- Setup the rest of the GUI: - -- - -- Objects - window <- Gtk.windowNew - button <- Gtk.buttonNew - exitButton <- Gtk.buttonNew - label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!") - vbox <- Gtk.vBoxNew False 4 - - --Wrench them together - - Gtk.set window [ Gtk.containerBorderWidth := 10, - Gtk.containerChild := canvas, - Gtk.windowTitle := "Pioneer" ] - - ------ - -- Events - -- - Gtk.afterClicked button (putStrLn "Hello World") - Gtk.afterClicked exitButton Gtk.mainQuit - Gtk.onDestroy window Gtk.mainQuit - - Gtk.on window Gtk.keyPressEvent $ keyEvent state True - - Gtk.on window Gtk.keyReleaseEvent $ keyEvent state False - - -- "reshape" event handler - Gtk.on canvas Gtk.configureEvent $ Event.tryEvent $ do - (w, h) <- Event.eventSize - (w', h') <- liftIO $ reconfigure w h - liftIO $ Gtk.labelSetText label $ unwords ["Width:",show w',"Height:",show h'] - - Gtk.widgetShowAll window - Gtk.mainGUI - diff --git a/src/Main.glfw.deprecated.hs b/src/Main.glfw.deprecated.hs deleted file mode 100644 index 55e0915..0000000 --- a/src/Main.glfw.deprecated.hs +++ /dev/null @@ -1,665 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main (main) where - --------------------------------------------------------------------------------- - -import Control.Concurrent.STM (TQueue, atomically, - newTQueueIO, - tryReadTQueue, - writeTQueue) -import Control.Monad (unless, void, when) -import Control.Monad.RWS.Strict (RWST, ask, asks, - evalRWST, get, liftIO, - modify, put) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Distributive (distribute, collect) -import Data.List (intercalate) -import Data.Maybe (catMaybes) -import Foreign (Ptr, castPtr, with) -import Foreign.C (CFloat) -import Linear as L -import Text.PrettyPrint - -import qualified Graphics.Rendering.OpenGL.GL as GL -import Graphics.Rendering.OpenGL.Raw.Core31 -import qualified Graphics.UI.GLFW as GLFW - -import Map.Map -import Render.Misc (checkError, - createFrustum, getCam, - lookAt, up) -import Render.Render (initRendering, - initShader) -import Control.Lens ((^.),transposeOf) -import Data.Traversable (traverse) - --------------------------------------------------------------------------------- - ---Static Read-Only-State -data Env = Env - { envEventsChan :: TQueue Event - , envWindow :: !GLFW.Window - , envZDistClosest :: !Double - , envZDistFarthest :: !Double - } - ---Mutable State -data State = State - { stateWindowWidth :: !Int - , stateWindowHeight :: !Int - --- IO - , stateXAngle :: !Double - , stateYAngle :: !Double - , stateZDist :: !Double - , stateMouseDown :: !Bool - , stateDragging :: !Bool - , stateDragStartX :: !Double - , stateDragStartY :: !Double - , stateDragStartXAngle :: !Double - , stateDragStartYAngle :: !Double - , statePositionX :: !Double - , statePositionY :: !Double - , stateFrustum :: !(M44 CFloat) - --- pointer to bindings for locations inside the compiled shader - --- mutable because shaders may be changed in the future. - , shdrVertexIndex :: !GL.AttribLocation - , shdrColorIndex :: !GL.AttribLocation - , shdrNormalIndex :: !GL.AttribLocation - , shdrProjMatIndex :: !GL.UniformLocation - , shdrViewMatIndex :: !GL.UniformLocation - , shdrModelMatIndex :: !GL.UniformLocation - , shdrNormalMatIndex :: !GL.UniformLocation - --- the map - , stateMap :: !GL.BufferObject - , mapVert :: !GL.NumArrayIndices - } - -type Pioneer = RWST Env () State IO - --------------------------------------------------------------------------------- - -data Event = - EventError !GLFW.Error !String - | EventWindowPos !GLFW.Window !Int !Int - | EventWindowSize !GLFW.Window !Int !Int - | EventWindowClose !GLFW.Window - | EventWindowRefresh !GLFW.Window - | EventWindowFocus !GLFW.Window !GLFW.FocusState - | EventWindowIconify !GLFW.Window !GLFW.IconifyState - | EventFramebufferSize !GLFW.Window !Int !Int - | EventMouseButton !GLFW.Window !GLFW.MouseButton !GLFW.MouseButtonState !GLFW.ModifierKeys - | EventCursorPos !GLFW.Window !Double !Double - | EventCursorEnter !GLFW.Window !GLFW.CursorState - | EventScroll !GLFW.Window !Double !Double - | EventKey !GLFW.Window !GLFW.Key !Int !GLFW.KeyState !GLFW.ModifierKeys - | EventChar !GLFW.Window !Char - deriving Show - --------------------------------------------------------------------------------- - -main :: IO () -main = do - let width = 640 - height = 480 - - eventsChan <- newTQueueIO :: IO (TQueue Event) - - withWindow width height "Pioneers" $ \win -> do - GLFW.setErrorCallback $ Just $ errorCallback eventsChan - GLFW.setWindowPosCallback win $ Just $ windowPosCallback eventsChan - GLFW.setWindowSizeCallback win $ Just $ windowSizeCallback eventsChan - GLFW.setWindowCloseCallback win $ Just $ windowCloseCallback eventsChan - GLFW.setWindowRefreshCallback win $ Just $ windowRefreshCallback eventsChan - GLFW.setWindowFocusCallback win $ Just $ windowFocusCallback eventsChan - GLFW.setWindowIconifyCallback win $ Just $ windowIconifyCallback eventsChan - GLFW.setFramebufferSizeCallback win $ Just $ framebufferSizeCallback eventsChan - GLFW.setMouseButtonCallback win $ Just $ mouseButtonCallback eventsChan - GLFW.setCursorPosCallback win $ Just $ cursorPosCallback eventsChan - GLFW.setCursorEnterCallback win $ Just $ cursorEnterCallback eventsChan - GLFW.setScrollCallback win $ Just $ scrollCallback eventsChan - GLFW.setKeyCallback win $ Just $ keyCallback eventsChan - GLFW.setCharCallback win $ Just $ charCallback eventsChan - - GLFW.swapInterval 1 - - (fbWidth, fbHeight) <- GLFW.getFramebufferSize win - - initRendering - --generate map vertices - (mapBuffer, vert) <- getMapBufferObject - (ci, ni, vi, pri, vii, mi, nmi) <- initShader - - let zDistClosest = 10 - zDistFarthest = zDistClosest + 20 - fov = 90 --field of view - near = 1 --near plane - far = 100 --far plane - ratio = fromIntegral fbWidth / fromIntegral fbHeight - frust = createFrustum fov near far ratio - env = Env - { envEventsChan = eventsChan - , envWindow = win - , envZDistClosest = zDistClosest - , envZDistFarthest = zDistFarthest - } - state = State - { stateWindowWidth = fbWidth - , stateWindowHeight = fbHeight - , stateXAngle = pi/6 - , stateYAngle = pi/2 - , stateZDist = 10 - , statePositionX = 5 - , statePositionY = 5 - , stateMouseDown = False - , stateDragging = False - , stateDragStartX = 0 - , stateDragStartY = 0 - , stateDragStartXAngle = 0 - , stateDragStartYAngle = 0 - , shdrVertexIndex = vi - , shdrNormalIndex = ni - , shdrColorIndex = ci - , shdrProjMatIndex = pri - , shdrViewMatIndex = vii - , shdrModelMatIndex = mi - , shdrNormalMatIndex = nmi - , stateMap = mapBuffer - , mapVert = vert - , stateFrustum = frust - } - runDemo env state - - putStrLn "ended!" - --------------------------------------------------------------------------------- - --- GLFW-b is made to be very close to the C API, so creating a window is pretty --- clunky by Haskell standards. A higher-level API would have some function --- like withWindow. - -withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () -withWindow width height title f = do - GLFW.setErrorCallback $ Just simpleErrorCallback - r <- GLFW.init - when r $ do - m <- GLFW.createWindow width height title Nothing Nothing - case m of - (Just win) -> do - GLFW.makeContextCurrent m - f win - GLFW.setErrorCallback $ Just simpleErrorCallback - GLFW.destroyWindow win - Nothing -> return () - GLFW.terminate - where - simpleErrorCallback e s = - putStrLn $ unwords [show e, show s] - --------------------------------------------------------------------------------- - --- Each callback does just one thing: write an appropriate Event to the events --- TQueue. - -errorCallback :: TQueue Event -> GLFW.Error -> String -> IO () -windowPosCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () -windowSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () -windowCloseCallback :: TQueue Event -> GLFW.Window -> IO () -windowRefreshCallback :: TQueue Event -> GLFW.Window -> IO () -windowFocusCallback :: TQueue Event -> GLFW.Window -> GLFW.FocusState -> IO () -windowIconifyCallback :: TQueue Event -> GLFW.Window -> GLFW.IconifyState -> IO () -framebufferSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () -mouseButtonCallback :: TQueue Event -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO () -cursorPosCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO () -cursorEnterCallback :: TQueue Event -> GLFW.Window -> GLFW.CursorState -> IO () -scrollCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO () -keyCallback :: TQueue Event -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO () -charCallback :: TQueue Event -> GLFW.Window -> Char -> IO () - -errorCallback tc e s = atomically $ writeTQueue tc $ EventError e s -windowPosCallback tc win x y = atomically $ writeTQueue tc $ EventWindowPos win x y -windowSizeCallback tc win w h = atomically $ writeTQueue tc $ EventWindowSize win w h -windowCloseCallback tc win = atomically $ writeTQueue tc $ EventWindowClose win -windowRefreshCallback tc win = atomically $ writeTQueue tc $ EventWindowRefresh win -windowFocusCallback tc win fa = atomically $ writeTQueue tc $ EventWindowFocus win fa -windowIconifyCallback tc win ia = atomically $ writeTQueue tc $ EventWindowIconify win ia -framebufferSizeCallback tc win w h = atomically $ writeTQueue tc $ EventFramebufferSize win w h -mouseButtonCallback tc win mb mba mk = atomically $ writeTQueue tc $ EventMouseButton win mb mba mk -cursorPosCallback tc win x y = atomically $ writeTQueue tc $ EventCursorPos win x y -cursorEnterCallback tc win ca = atomically $ writeTQueue tc $ EventCursorEnter win ca -scrollCallback tc win x y = atomically $ writeTQueue tc $ EventScroll win x y -keyCallback tc win k sc ka mk = atomically $ writeTQueue tc $ EventKey win k sc ka mk -charCallback tc win c = atomically $ writeTQueue tc $ EventChar win c - --------------------------------------------------------------------------------- - -runDemo :: Env -> State -> IO () -runDemo env state = void $ evalRWST (adjustWindow >> run) env state - -run :: Pioneer () -run = do - win <- asks envWindow - - -- draw Scene - draw - liftIO $ do - GLFW.swapBuffers win - GLFW.pollEvents - -- getEvents & process - processEvents - - -- update State - - state <- get - -- change in camera-angle - if stateDragging state - then do - let sodx = stateDragStartX state - sody = stateDragStartY state - sodxa = stateDragStartXAngle state - sodya = stateDragStartYAngle state - (x, y) <- liftIO $ GLFW.getCursorPos win - let myrot = (x - sodx) / 2 - mxrot = (y - sody) / 2 - newXAngle = curb (pi/12) (0.45*pi) newXAngle' - newXAngle' = sodxa + mxrot/100 - newYAngle - | newYAngle' > pi = newYAngle' - 2 * pi - | newYAngle' < (-pi) = newYAngle' + 2 * pi - | otherwise = newYAngle' - newYAngle' = sodya + myrot/100 - put $ state - { stateXAngle = newXAngle - , stateYAngle = newYAngle - } --- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle] - else do - (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1 - put $ state - { stateXAngle = stateXAngle state + (2 * jxrot) - , stateYAngle = stateYAngle state + (2 * jyrot) - } - - -- get cursor-keys - if pressed - --TODO: Add sin/cos from stateYAngle - (kxrot, kyrot) <- liftIO $ getCursorKeyDirections win - modify $ \s -> - let - multc = cos $ stateYAngle s - mults = sin $ stateYAngle s - in - s { - statePositionX = statePositionX s - 0.2 * kxrot * multc - - 0.2 * kyrot * mults - , statePositionY = statePositionY s + 0.2 * kxrot * mults - - 0.2 * kyrot * multc - } - - {- - --modify the state with all that happened in mt time. - mt <- liftIO GLFW.getTime - modify $ \s -> s - { - } - -} - - q <- liftIO $ GLFW.windowShouldClose win - unless q run - -processEvents :: Pioneer () -processEvents = do - tc <- asks envEventsChan - me <- liftIO $ atomically $ tryReadTQueue tc - case me of - Just e -> do - processEvent e - processEvents - Nothing -> return () - -processEvent :: Event -> Pioneer () -processEvent ev = - case ev of - (EventError e s) -> do - printEvent "error" [show e, show s] - win <- asks envWindow - liftIO $ GLFW.setWindowShouldClose win True - - (EventWindowPos _ x y) -> - printEvent "window pos" [show x, show y] - - (EventWindowSize _ width height) -> - printEvent "window size" [show width, show height] - - (EventWindowClose _) -> - printEvent "window close" [] - - (EventWindowRefresh _) -> - printEvent "window refresh" [] - - (EventWindowFocus _ fs) -> - printEvent "window focus" [show fs] - - (EventWindowIconify _ is) -> - printEvent "window iconify" [show is] - - (EventFramebufferSize _ width height) -> do - printEvent "framebuffer size" [show width, show height] - modify $ \s -> s - { stateWindowWidth = width - , stateWindowHeight = height - } - adjustWindow - - (EventMouseButton _ mb mbs mk) -> do - printEvent "mouse button" [show mb, show mbs, showModifierKeys mk] - when (mb == GLFW.MouseButton'1) $ do - let pressed = mbs == GLFW.MouseButtonState'Pressed - modify $ \s -> s - { stateMouseDown = pressed - } - unless pressed $ - modify $ \s -> s - { stateDragging = False - } - - (EventCursorPos _ x y) -> do - {-let x' = round x :: Int - y' = round y :: Int - printEvent "cursor pos" [show x', show y']-} - state <- get - when (stateMouseDown state && not (stateDragging state)) $ - put $ state - { stateDragging = True - , stateDragStartX = x - , stateDragStartY = y - , stateDragStartXAngle = stateXAngle state - , stateDragStartYAngle = stateYAngle state - } - - (EventCursorEnter _ cs) -> - printEvent "cursor enter" [show cs] - - (EventScroll _ x y) -> do - let x' = round x :: Int - y' = round y :: Int - printEvent "scroll" [show x', show y'] - env <- ask - modify $ \s -> s - { stateZDist = - let zDist' = stateZDist s + realToFrac (negate $ y) - in curb (envZDistClosest env) (envZDistFarthest env) zDist' - } - adjustWindow - - (EventKey win k scancode ks mk) -> do - when (ks == GLFW.KeyState'Pressed) $ do - -- Q, Esc: exit - when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $ - liftIO $ GLFW.setWindowShouldClose win True - -- i: print GLFW information - when (k == GLFW.Key'I) $ - liftIO $ printInformation win - unless (elem k [GLFW.Key'Up - ,GLFW.Key'Down - ,GLFW.Key'Left - ,GLFW.Key'Right - ]) $ do - printEvent "key" [show k, show scancode, show ks, showModifierKeys mk] - - (EventChar _ c) -> - printEvent "char" [show c] - -adjustWindow :: Pioneer () -adjustWindow = do - state <- get - let fbWidth = stateWindowWidth state - fbHeight = stateWindowHeight state - fov = 90 --field of view - near = 1 --near plane - far = 100 --far plane - ratio = fromIntegral fbWidth / fromIntegral fbHeight - frust = createFrustum fov near far ratio - liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) - put $ state { - stateFrustum = frust - } - -draw :: Pioneer () -draw = do - env <- ask - state <- get - let xa = stateXAngle state - ya = stateYAngle state - (GL.UniformLocation proj) = shdrProjMatIndex state - (GL.UniformLocation nmat) = shdrNormalMatIndex state - (GL.UniformLocation vmat) = shdrViewMatIndex state - vi = shdrVertexIndex state - ni = shdrNormalIndex state - ci = shdrColorIndex state - numVert = mapVert state - map' = stateMap state - frust = stateFrustum state - camX = statePositionX state - camY = statePositionY state - zDist = stateZDist state - liftIO $ do - --(vi,GL.UniformLocation proj) <- initShader - GL.clear [GL.ColorBuffer, GL.DepthBuffer] - checkError "foo" - --set up projection (= copy from state) - with (distribute $ frust) $ \ptr -> - glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) - checkError "foo" - - --set up camera - let ! cam = getCam (camX,camY) zDist xa ya - with (distribute $ cam) $ \ptr -> - glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) - checkError "foo" - - --set up normal--Mat transpose((model*camera)^-1) - let normal = (case inv33 ((fmap (^._xyz) cam) ^. _xyz) of - (Just a) -> a - Nothing -> eye3) :: M33 CFloat - nmap = (collect (fmap id) normal) :: M33 CFloat --transpose... - - with (distribute $ nmap) $ \ptr -> - glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat))) - - checkError "nmat" - - GL.bindBuffer GL.ArrayBuffer GL.$= Just map' - GL.vertexAttribPointer ci GL.$= fgColorIndex - GL.vertexAttribArray ci GL.$= GL.Enabled - GL.vertexAttribPointer ni GL.$= fgNormalIndex - GL.vertexAttribArray ni GL.$= GL.Enabled - GL.vertexAttribPointer vi GL.$= fgVertexIndex - GL.vertexAttribArray vi GL.$= GL.Enabled - checkError "beforeDraw" - - GL.drawArrays GL.Triangles 0 numVert - checkError "draw" - -getCursorKeyDirections :: GLFW.Window -> IO (Double, Double) -getCursorKeyDirections win = do - y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up - y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down - x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left - x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right - let x0n = if x0 then (-1) else 0 - x1n = if x1 then 1 else 0 - y0n = if y0 then (-1) else 0 - y1n = if y1 then 1 else 0 - return (x0n + x1n, y0n + y1n) - -getJoystickDirections :: GLFW.Joystick -> IO (Double, Double) -getJoystickDirections js = do - maxes <- GLFW.getJoystickAxes js - return $ case maxes of - (Just (x:y:_)) -> (-y, x) - _ -> ( 0, 0) - -isPress :: GLFW.KeyState -> Bool -isPress GLFW.KeyState'Pressed = True -isPress GLFW.KeyState'Repeating = True -isPress _ = False - --------------------------------------------------------------------------------- - -printInformation :: GLFW.Window -> IO () -printInformation win = do - version <- GLFW.getVersion - versionString <- GLFW.getVersionString - monitorInfos <- runMaybeT getMonitorInfos - joystickNames <- getJoystickNames - clientAPI <- GLFW.getWindowClientAPI win - cv0 <- GLFW.getWindowContextVersionMajor win - cv1 <- GLFW.getWindowContextVersionMinor win - cv2 <- GLFW.getWindowContextVersionRevision win - robustness <- GLFW.getWindowContextRobustness win - forwardCompat <- GLFW.getWindowOpenGLForwardCompat win - debug <- GLFW.getWindowOpenGLDebugContext win - profile <- GLFW.getWindowOpenGLProfile win - - putStrLn $ render $ - nest 4 ( - text "------------------------------------------------------------" $+$ - text "GLFW C library:" $+$ - nest 4 ( - text "Version:" <+> renderVersion version $+$ - text "Version string:" <+> renderVersionString versionString - ) $+$ - text "Monitors:" $+$ - nest 4 ( - renderMonitorInfos monitorInfos - ) $+$ - text "Joysticks:" $+$ - nest 4 ( - renderJoystickNames joystickNames - ) $+$ - text "OpenGL context:" $+$ - nest 4 ( - text "Client API:" <+> renderClientAPI clientAPI $+$ - text "Version:" <+> renderContextVersion cv0 cv1 cv2 $+$ - text "Robustness:" <+> renderContextRobustness robustness $+$ - text "Forward compatibility:" <+> renderForwardCompat forwardCompat $+$ - text "Debug:" <+> renderDebug debug $+$ - text "Profile:" <+> renderProfile profile - ) $+$ - text "------------------------------------------------------------" - ) - where - renderVersion (GLFW.Version v0 v1 v2) = - text $ intercalate "." $ map show [v0, v1, v2] - - renderVersionString = - text . show - - renderMonitorInfos = - maybe (text "(error)") (vcat . map renderMonitorInfo) - - renderMonitorInfo (name, (x,y), (w,h), vms) = - text (show name) $+$ - nest 4 ( - location <+> size $+$ - fsep (map renderVideoMode vms) - ) - where - location = int x <> text "," <> int y - size = int w <> text "x" <> int h <> text "mm" - - renderVideoMode (GLFW.VideoMode w h r g b rr) = - brackets $ res <+> rgb <+> hz - where - res = int w <> text "x" <> int h - rgb = int r <> text "x" <> int g <> text "x" <> int b - hz = int rr <> text "Hz" - - renderJoystickNames pairs = - vcat $ map (\(js, name) -> text (show js) <+> text (show name)) pairs - - renderContextVersion v0 v1 v2 = - hcat [int v0, text ".", int v1, text ".", int v2] - - renderClientAPI = text . show - renderContextRobustness = text . show - renderForwardCompat = text . show - renderDebug = text . show - renderProfile = text . show - -type MonitorInfo = (String, (Int,Int), (Int,Int), [GLFW.VideoMode]) - -getMonitorInfos :: MaybeT IO [MonitorInfo] -getMonitorInfos = - getMonitors >>= mapM getMonitorInfo - where - getMonitors :: MaybeT IO [GLFW.Monitor] - getMonitors = MaybeT GLFW.getMonitors - - getMonitorInfo :: GLFW.Monitor -> MaybeT IO MonitorInfo - getMonitorInfo mon = do - name <- getMonitorName mon - vms <- getVideoModes mon - MaybeT $ do - pos <- liftIO $ GLFW.getMonitorPos mon - size <- liftIO $ GLFW.getMonitorPhysicalSize mon - return $ Just (name, pos, size, vms) - - getMonitorName :: GLFW.Monitor -> MaybeT IO String - getMonitorName mon = MaybeT $ GLFW.getMonitorName mon - - getVideoModes :: GLFW.Monitor -> MaybeT IO [GLFW.VideoMode] - getVideoModes mon = MaybeT $ GLFW.getVideoModes mon - -getJoystickNames :: IO [(GLFW.Joystick, String)] -getJoystickNames = - catMaybes `fmap` mapM getJoystick joysticks - where - getJoystick js = - fmap (maybe Nothing (\name -> Just (js, name))) - (GLFW.getJoystickName js) - --------------------------------------------------------------------------------- - -printEvent :: String -> [String] -> Pioneer () -printEvent cbname fields = - liftIO $ putStrLn $ cbname ++ ": " ++ unwords fields - -showModifierKeys :: GLFW.ModifierKeys -> String -showModifierKeys mk = - "[mod keys: " ++ keys ++ "]" - where - keys = if null xs then "none" else unwords xs - xs = catMaybes ys - ys = [ if GLFW.modifierKeysShift mk then Just "shift" else Nothing - , if GLFW.modifierKeysControl mk then Just "control" else Nothing - , if GLFW.modifierKeysAlt mk then Just "alt" else Nothing - , if GLFW.modifierKeysSuper mk then Just "super" else Nothing - ] - -curb :: Ord a => a -> a -> a -> a -curb l h x - | x < l = l - | x > h = h - | otherwise = x - --------------------------------------------------------------------------------- - -joysticks :: [GLFW.Joystick] -joysticks = - [ GLFW.Joystick'1 - , GLFW.Joystick'2 - , GLFW.Joystick'3 - , GLFW.Joystick'4 - , GLFW.Joystick'5 - , GLFW.Joystick'6 - , GLFW.Joystick'7 - , GLFW.Joystick'8 - , GLFW.Joystick'9 - , GLFW.Joystick'10 - , GLFW.Joystick'11 - , GLFW.Joystick'12 - , GLFW.Joystick'13 - , GLFW.Joystick'14 - , GLFW.Joystick'15 - , GLFW.Joystick'16 - ] diff --git a/src/Main.hs b/src/Main.hs index 259ff7f..73279e8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,17 +1,13 @@ {-# LANGUAGE BangPatterns, DoAndIfThenElse #-} module Main where -import Data.Int (Int8) -import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureSize2D) +import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D)) import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..)) -import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D) -import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (textureFilter) -import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureTarget2D(Texture2D)) import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding) -import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..)) +import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..),textureFilter) -- Monad-foo and higher functional stuff -import Control.Monad (unless, void, when, join, liftM) +import Control.Monad (unless, when, join) import Control.Arrow ((***)) -- data consistency/conversion @@ -19,10 +15,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.STM (TQueue, newTQueueIO) -import Control.Monad.RWS.Strict (RWST, ask, asks, - evalRWST, get, liftIO, - modify, put) -import Control.Monad.Trans.Class +import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Control.Monad.Trans.State (evalStateT) import Data.Functor ((<$>)) import Data.Distributive (distribute, collect) @@ -31,10 +24,8 @@ import Data.Monoid (mappend) -- FFI import Foreign (Ptr, castPtr, with, sizeOf) import Foreign.C (CFloat) -import Foreign.C.Types (CInt) import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) -import Data.Word (Word8) -- Math import Control.Lens ((^.), (.~), (%~)) @@ -42,8 +33,6 @@ import qualified Linear as L -- GUI import Graphics.UI.SDL as SDL ---import Graphics.UI.SDL.TTF as TTF ---import Graphics.UI.SDL.TTF.Types -- Render import qualified Graphics.Rendering.OpenGL.GL as GL @@ -54,58 +43,53 @@ import Graphics.GLUtil.BufferObjects (offset0) import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader -- Our modules import Map.Graphics -import Render.Misc (checkError, - createFrustum, getCam, - curb, tryWithTexture, +import Render.Misc (checkError, createFrustum, getCam, curb, genColorData) import Render.Render (initRendering, initMapShader, initHud) import UI.Callbacks -import UI.GUIOverlay import Types import Importer.IQM.Parser import Data.Attoparsec.Char8 (parseTest) import qualified Data.ByteString as B ---import ThirdParty.Flippers - -import qualified Debug.Trace as D (trace) +-- import qualified Debug.Trace as D (trace) -------------------------------------------------------------------------------- testParser :: IO () testParser = do - f <- B.readFile "sample.iqm" + f <- B.readFile "sample.iqm" parseTest (evalStateT parseIQM 0) f -------------------------------------------------------------------------------- main :: IO () -main = do - SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute! +main = + SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ --also: InitNoParachute -> faster, without parachute! SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL ,WindowShown -- window should be visible - ,WindowResizable -- and resizable + ,WindowResizable -- and resizable ,WindowInputFocus -- focused (=> active) ,WindowMouseFocus -- Mouse into it --,WindowInputGrabbed-- never let go of input (KB/Mouse) - ] $ \window -> do - withOpenGL window $ do - + ] $ \window' -> do + withOpenGL window' $ do + --Create Renderbuffer & Framebuffer -- We will render to this buffer to copy the result into textures renderBuffer <- GL.genObjectName frameBuffer <- GL.genObjectName GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer - - (Size fbWidth fbHeight) <- glGetDrawableSize window + + (Size fbWidth fbHeight) <- glGetDrawableSize window' initRendering --generate map vertices (mapBuffer, vert) <- getMapBufferObject (mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader - print window + print window' eventQueue <- newTQueueIO :: IO (TQueue Event) putStrLn "foo" now <- getCurrentTime @@ -114,9 +98,9 @@ main = do --TTF.setFontStyle font TTFNormal --TTF.setFontHinting font TTFHNormal - glHud <- initHud - let zDistClosest = 1 - zDistFarthest = zDistClosest + 50 + glHud' <- initHud + let zDistClosest' = 1 + zDistFarthest' = zDistClosest' + 50 --TODO: Move near/far/fov to state for runtime-changability & central storage fov = 90 --field of view near = 1 --near plane @@ -129,7 +113,7 @@ main = do , _left = False , _right = False } - glMap = GLMapState + glMap' = GLMapState { _shdrVertexIndex = vi , _shdrNormalIndex = ni , _shdrColorIndex = ci @@ -147,11 +131,9 @@ main = do } env = Env { _eventsChan = eventQueue - , _windowObject = window - , _zDistClosest = zDistClosest - , _zDistFarthest = zDistFarthest - --, _renderer = renderer - --, envFont = font + , _windowObject = window' + , _zDistClosest = zDistClosest' + , _zDistFarthest = zDistFarthest' } state = State { _window = WindowState @@ -188,8 +170,8 @@ main = do { _arrowsPressed = aks } , _gl = GLState - { _glMap = glMap - , _glHud = glHud + { _glMap = glMap' + , _glHud = glHud' , _glRenderbuffer = renderBuffer , _glFramebuffer = frameBuffer } @@ -203,8 +185,8 @@ main = do putStrLn "init done." uncurry mappend <$> evalRWST (adjustWindow >> run) env state - putStrLn "shutdown complete." - + putStrLn "shutdown complete." + --SDL.glDeleteContext mainGlContext --SDL.destroyRenderer renderer --destroyWindow window @@ -214,31 +196,28 @@ main = do draw :: Pioneers () draw = do state <- get - env <- ask let xa = state ^. camera.xAngle ya = state ^. camera.yAngle - (GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex - (GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex - (GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex - (GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex - (GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex - vi = state ^. gl.glMap.shdrVertexIndex - ni = state ^. gl.glMap.shdrNormalIndex - ci = state ^. gl.glMap.shdrColorIndex - numVert = state ^. gl.glMap.mapVert - map' = state ^. gl.glMap.stateMap - frust = state ^. camera.frustum + (GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex + (GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex + (GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex + (GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex + (GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex + vi = state ^. gl.glMap.shdrVertexIndex + ni = state ^. gl.glMap.shdrNormalIndex + ci = state ^. gl.glMap.shdrColorIndex + numVert = state ^. gl.glMap.mapVert + map' = state ^. gl.glMap.stateMap + frust = state ^. camera.frustum camX = state ^. camera.camPosition._x camY = state ^. camera.camPosition._y zDist' = state ^. camera.zDist tessFac = state ^. gl.glMap.stateTessellationFactor - window = env ^. windowObject - rb = state ^. gl.glRenderbuffer when (state ^. ui . uiHasChanged) prepareGUI liftIO $ do --bind renderbuffer and set sample 0 as target --GL.bindRenderbuffer GL.Renderbuffer GL.$= rb - --GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject + --GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject --checkError "bind renderbuffer" --checkError "clear renderbuffer" @@ -251,7 +230,7 @@ draw = do -- draw map --(vi,GL.UniformLocation proj) <- initShader - + GL.bindFramebuffer GL.Framebuffer GL.$= (state ^. gl.glFramebuffer) GL.bindRenderbuffer GL.Renderbuffer GL.$= (state ^. gl.glRenderbuffer) GL.framebufferRenderbuffer @@ -260,14 +239,14 @@ draw = do GL.Renderbuffer (state ^. gl.glRenderbuffer) textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture) - + GL.framebufferTexture2D GL.Framebuffer (GL.ColorAttachment 0) GL.Texture2D (state ^. gl.glMap.mapTexture) 0 - + -- Render to FrameBufferObject GL.drawBuffers GL.$= [GL.FBOColorAttachment 0] checkError "setup Render-Target" @@ -314,7 +293,8 @@ draw = do checkError "beforeDraw" glPatchParameteri gl_PATCH_VERTICES 3 - glPolygonMode gl_FRONT gl_LINE + + GL.cullFace GL.$= Just GL.Front glDrawArrays gl_PATCHES 0 (fromIntegral numVert) checkError "draw map" @@ -345,11 +325,11 @@ draw = do GL.activeTexture GL.$= GL.TextureUnit 1 textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture) GL.uniform (hud ^. hudBackIndex) GL.$= GL.Index1 (1::GL.GLint) - + GL.bindBuffer GL.ArrayBuffer GL.$= Just (hud ^. hudVBO) GL.vertexAttribPointer (hud ^. hudVertexIndex) GL.$= (GL.ToFloat, vad) GL.vertexAttribArray (hud ^. hudVertexIndex) GL.$= GL.Enabled - + GL.bindBuffer GL.ElementArrayBuffer GL.$= Just (hud ^. hudEBO) GL.drawElements GL.TriangleStrip 4 GL.UnsignedInt offset0 @@ -393,14 +373,14 @@ run = do | newYAngle' < (-pi) = newYAngle' + 2 * pi | otherwise = newYAngle' newYAngle' = sodya + myrot/100 - + modify $ ((camera.xAngle) .~ newXAngle) . ((camera.yAngle) .~ newYAngle) -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement - let + let multc = cos $ state ^. camera.yAngle mults = sin $ state ^. camera.yAngle modx x' = x' - 0.2 * kxrot * multc @@ -419,23 +399,24 @@ run = do -} mt <- liftIO $ do + let double = fromRational.toRational :: (Real a) => a -> Double now <- getCurrentTime diff <- return $ diffUTCTime now (state ^. io.clock) -- get time-diffs - title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 1.0/diff)::Int),"fps"] + title <- return $ unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"] setWindowTitle (env ^. windowObject) title sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds threadDelay sleepAmount return now -- set state with new clock-time modify $ io.clock .~ mt - shouldClose <- return $ state ^. window.shouldClose - unless shouldClose run + shouldClose' <- return $ state ^. window.shouldClose + unless shouldClose' run getArrowMovement :: Pioneers (Int, Int) getArrowMovement = do state <- get - aks <- return $ state ^. (keyboard.arrowsPressed) - let + aks <- return $ state ^. (keyboard.arrowsPressed) + let horz = left' + right' vert = up'+down' left' = if aks ^. left then -1 else 0 @@ -447,7 +428,6 @@ getArrowMovement = do adjustWindow :: Pioneers () adjustWindow = do state <- get - env <- ask let fbWidth = state ^. window.width fbHeight = state ^. window.height fov = 90 --field of view @@ -466,7 +446,7 @@ adjustWindow = do renderBuffer <- GL.genObjectName GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer GL.renderbufferStorage - GL.Renderbuffer -- use the only available renderbuffer + GL.Renderbuffer -- use the only available renderbuffer -- - must be this constant. GL.DepthComponent' -- 32-bit float-rgba-color (GL.RenderbufferSize fbCWidth fbCHeight) -- size of buffer @@ -521,7 +501,7 @@ processEvent e = do _ -> return () --liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e] - Keyboard movement _ isRepeated key -> --up/down window(ignored) true/false actualKey + Keyboard movement _ _{-isRepeated-} key -> --up/down window(ignored) true/false actualKey -- need modifiers? use "keyModifiers key" to get them let aks = keyboard.arrowsPressed in case keyScancode key of @@ -551,7 +531,7 @@ processEvent e = do liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] _ -> return () - MouseMotion _ mouseId st (SDL.Position x y) xrel yrel -> do + MouseMotion _ _{-mouseId-} _{-st-} (SDL.Position x y) _{-xrel-} _{-yrel-} -> do state <- get when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $ modify $ (mouse.isDragging .~ True) @@ -559,10 +539,10 @@ processEvent e = do . (mouse.dragStartY .~ (fromIntegral y)) . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) - + modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x)) . (mouse.mousePosition. Types._y .~ (fromIntegral y)) - MouseButton _ mouseId button state (SDL.Position x y) -> + MouseButton _ _{-mouseId-} button state (SDL.Position x y) -> case button of LeftButton -> do let pressed = state == Pressed @@ -577,10 +557,9 @@ processEvent e = do when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y) _ -> return () - MouseWheel _ mouseId hscroll vscroll -> do - env <- ask + MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do state <- get - let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in + let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist') Quit -> modify $ window.shouldClose .~ True -- there is more (joystic, touchInterface, ...), but currently ignored diff --git a/src/PioneerTypes.hs b/src/PioneerTypes.hs index 06027d7..1e28802 100644 --- a/src/PioneerTypes.hs +++ b/src/PioneerTypes.hs @@ -1,4 +1,4 @@ -module PioneerTypes +module PioneerTypes where data Structure = Flag -- Flag @@ -36,7 +36,7 @@ data Structure = Flag -- Flag deriving (Show, Eq) data Amount = Infinite -- Neverending supply - | Finite Int -- Finite supply + | Finite Int -- Finite supply -- Extremely preliminary, expand when needed data Commodity = WoodPlank @@ -54,9 +54,9 @@ data Resource = Coal instance Show Amount where show (Infinite) = "inexhaustable supply" - show (Finite n) = (show n) ++ " left" + show (Finite n) = show n ++ " left" instance Show Commodity where show WoodPlank = "wooden plank" - show Sword = "sword" + show Sword = "sword" show Fish = "fish" diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index 4a2e705..1c6f092 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -8,7 +8,6 @@ import Graphics.Rendering.OpenGL.GL.Shaders import Graphics.Rendering.OpenGL.GL.StateVar import Graphics.Rendering.OpenGL.GL.StringQueries import Graphics.Rendering.OpenGL.GLU.Errors -import Graphics.Rendering.OpenGL.Raw.Core31 import Graphics.UI.SDL.Types (Texture) import System.IO (hPutStrLn, stderr) import Linear @@ -62,7 +61,7 @@ createProgramUsing shaders = do createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat createFrustum fov n' f' rat = - let + let f = realToFrac f' n = realToFrac n' s = realToFrac $ recip (tan $ fov*0.5 * pi / 180) @@ -78,7 +77,7 @@ createFrustum fov n' f' rat = -- from vmath.h lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat -lookAt eye@(V3 ex ey ez) center up = +lookAt eye center up' = V4 (V4 xx xy xz (-dot x eye)) (V4 yx yy yz (-dot y eye)) @@ -86,7 +85,7 @@ lookAt eye@(V3 ex ey ez) center up = (V4 0 0 0 1) where z@(V3 zx zy zz) = normalize (eye ^-^ center) - x@(V3 xx xy xz) = normalize (cross up z) + x@(V3 xx xy xz) = normalize (cross up' z) y@(V3 yx yy yz) = normalize (cross z x) diff --git a/src/Render/Render.hs b/src/Render/Render.hs index d45a9c4..fa2e67c 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -2,8 +2,6 @@ module Render.Render where import qualified Data.ByteString as B -import Data.Array.Storable -import qualified Data.Vector.Storable as V import Foreign.Marshal.Array (withArray) import Foreign.Storable import Graphics.Rendering.OpenGL.GL.BufferObjects @@ -14,13 +12,10 @@ import Graphics.Rendering.OpenGL.GL.Shaders import Graphics.Rendering.OpenGL.GL.StateVar import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Graphics.Rendering.OpenGL.GL.VertexArrays (Capability (..), - vertexAttribArray, - VertexArrayDescriptor, - DataType(Float)) + vertexAttribArray) import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw.Core31 import Render.Misc -import Foreign.Ptr (Ptr, wordPtrToPtr) import Types import Graphics.GLUtil.BufferObjects (makeBuffer) @@ -169,7 +164,7 @@ initHud = do , _hudEBO = ebo , _hudProgram = program } - + diff --git a/src/Types.hs b/src/Types.hs index d5d262b..d7c1196 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -3,7 +3,7 @@ module Types where import Control.Concurrent.STM (TQueue) import qualified Graphics.Rendering.OpenGL.GL as GL -import Graphics.UI.SDL as SDL (Event, Window, Texture, Renderer) +import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) import Data.Time (UTCTime) import Linear.Matrix (M44) From f7dea8e9640ad8cd7b5e2a308f0b888ba1588da6 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 15 Apr 2014 17:28:38 +0200 Subject: [PATCH 10/10] haddock now works as well.. --- src/Map/Graphics.hs | 24 +++++++++++++----------- src/Render/Render.hs | 28 +++++++++++++++------------- 2 files changed, 28 insertions(+), 24 deletions(-) diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index f8562a5..f2e188d 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, BangPatterns #-} -module Map.Graphics +module Map.Graphics ( mapVertexArrayDescriptor, @@ -13,7 +13,7 @@ where import System.Random import Data.Array.IArray -import Data.Text as T +import Data.Text as T import Prelude as P --import Graphics.Rendering.OpenGL.GL @@ -33,8 +33,10 @@ import Linear import Map.Types import Map.StaticMaps +type Height = Float + type MapEntry = ( - Float, -- ^ Height + Height, TileType ) @@ -94,10 +96,10 @@ prettyMap (a:b:c:d:x:y:z:u:v:w:ms) = (a,b,c,d,x,y,z,u,v,w):(prettyMap ms) prettyMap _ = [] --generateTriangles :: PlayMap -> [GLfloat] -generateTriangles :: GraphicsMap -> [GLfloat] +generateTriangles :: GraphicsMap -> [GLfloat] generateTriangles map' = let ((xl,yl),(xh,yh)) = bounds map' in - P.concat [P.concat $ P.map (generateFirstTriLine map' y) [xl .. xh - 2] + P.concat [P.concat $ P.map (generateFirstTriLine map' y) [xl .. xh - 2] ++ P.map (generateSecondTriLine map' (y == yh) y) [xl .. xh - 2] | y <- [yl..yh]] @@ -132,8 +134,8 @@ generateSecondTriLine _ True _ _ = [] lookupVertex :: GraphicsMap -> Int -> Int -> [GLfloat] -lookupVertex map' x y = - let +lookupVertex map' x y = + let (cr, cg, cb) = colorLookup map' (x,y) (V3 vx vy vz) = coordLookup (x,y) $ heightLookup map' (x,y) (V3 nx ny nz) = normalLookup map' x y @@ -157,7 +159,7 @@ normalLookup map' x y = normalize $ normN + normNE + normSE + normS + normSW + n normNW = cross (vNW-vC) (vW -vC) --Vertex Normals vC = coordLookup (x,y) $ heightLookup map' (x,y) - --TODO: kill guards with eo + --TODO: kill guards with eo vNW | even x = coordLookup (x-1,y-1) $ heightLookup map' (x-1,y-1) | otherwise = coordLookup (x-1,y ) $ heightLookup map' (x-1,y ) @@ -180,12 +182,12 @@ normalLookup map' x y = normalize $ normN + normNE + normSE + normS + normSW + n heightLookup :: GraphicsMap -> (Int,Int) -> GLfloat heightLookup hs t = if inRange (bounds hs) t then fromRational $ toRational h else 0.0 - where + where (h,_) = hs ! t colorLookup :: GraphicsMap -> (Int,Int) -> (GLfloat, GLfloat, GLfloat) colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0) - where + where (_,tp) = hs ! t c = case tp of Ocean -> (0.50, 0.50, 1.00) @@ -256,7 +258,7 @@ testmap2 = do parseTemplate :: [Int] -> Text -> [MapEntry] -parseTemplate (r:rs) t = +parseTemplate (r:rs) t = (case T.head t of '~' -> (0, Ocean) 'S' -> (0, Beach) diff --git a/src/Render/Render.hs b/src/Render/Render.hs index fa2e67c..dd8678a 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -48,18 +48,20 @@ initBuffer varray = return bufferObject initMapShader :: IO ( - Program -- ^ the GLSL-Program - , AttribLocation -- ^ color - , AttribLocation -- ^ normal - , AttribLocation -- ^ vertex - , UniformLocation -- ^ ProjectionMat - , UniformLocation -- ^ ViewMat - , UniformLocation -- ^ ModelMat - , UniformLocation -- ^ NormalMat - , UniformLocation -- ^ TessLevelInner - , UniformLocation -- ^ TessLevelOuter - , TextureObject -- ^ Texture where to draw into - ) + Program -- the GLSL-Program + , AttribLocation -- color + , AttribLocation -- normal + , AttribLocation -- vertex + , UniformLocation -- ProjectionMat + , UniformLocation -- ViewMat + , UniformLocation -- ModelMat + , UniformLocation -- NormalMat + , UniformLocation -- TessLevelInner + , UniformLocation -- TessLevelOuter + , TextureObject -- Texture where to draw into + ) -- ^ (the GLSL-Program, color, normal, vertex, ProjectionMat, ViewMat, + -- ModelMat, NormalMat, TessLevelInner, TessLevelOuter, + -- Texture where to draw into) initMapShader = do ! vertexSource <- B.readFile mapVertexShaderFile ! tessControlSource <- B.readFile mapTessControlShaderFile @@ -138,7 +140,7 @@ initHud = do texIndex <- get (uniformLocation program "tex[1]") checkError "ui-tex" - -- | simple triangle over the whole screen. + -- simple triangle over the whole screen. let vertexBufferData = reverse [-1, -1, 1, -1, -1, 1, 1, 1] :: [GLfloat] vertexIndex <- get (attribLocation program "position")