From 8bd8db922e4d6f39a18d603532af4467aae42435 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 13 May 2014 10:40:35 +0200 Subject: [PATCH 01/25] added shadow-map - added shadow-map - compiles and smap gets initialized/generated - generation ist stil incorrect (cam, light-dir, ...) --- src/Main.hs | 8 +++ src/Render/Render.hs | 152 ++++++++++++++++++++++++++++++------------- src/Types.hs | 1 + 3 files changed, 114 insertions(+), 47 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0aa092d..7db4c40 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -304,6 +304,7 @@ adjustWindow = do let hudtexid = state ^. gl.glHud.hudTexture maptexid = state ^. gl.glMap.renderedMapTexture + smaptexid = state ^. gl.glMap.shadowMapTexture allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do --default to ugly pink to see if --somethings go wrong. @@ -320,6 +321,13 @@ adjustWindow = do textureFilter Texture2D GL.$= ((Linear', Nothing), Linear') texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0 (GL.PixelData GL.RGBA GL.UnsignedByte ptr) + allocaBytes (2048*2048) $ \ptr -> do + let smapdata = genColorData (2048*2048) [0] + pokeArray ptr smapdata + textureBinding Texture2D GL.$= Just smaptexid + textureFilter Texture2D GL.$= ((Nearest,Nothing), Nearest) + texImage2D Texture2D GL.NoProxy 0 GL.DepthComponent16 (GL.TextureSize2D 2048 2048) 0 + (GL.PixelData GL.DepthComponent GL.UnsignedByte ptr) checkError "setting up HUD-Tex" return renderBuffer modify $ gl.glRenderbuffer .~ rb diff --git a/src/Render/Render.hs b/src/Render/Render.hs index c6e4369..39fde96 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -119,6 +119,8 @@ initMapShader tessFac (buf, vertDes) = do overTex <- genObjectName texts <- genObjectNames 6 + + smap <- genObjectName testobj <- parseIQM "sample.iqm" @@ -154,6 +156,7 @@ initMapShader tessFac (buf, vertDes) = do , _mapVert = vertDes , _overviewTexture = overTex , _mapTextures = texts + , _shadowMapTexture = smap , _mapObjects = objs , _objectProgram = objProgram } @@ -190,7 +193,7 @@ initHud = do att <- get (activeAttribs program) putStrLn $ unlines $ "Attributes: ":map show att - putStrLn $ unlines $ ["Indices: ", show (texIndex)] + putStrLn $ unlines $ ["Indices: ", show texIndex] checkError "initHud" return GLHud @@ -299,38 +302,123 @@ renderObject :: MapObject -> IO () renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) = renderIQM model pos (L.V3 1 1 1) +drawMap :: Pioneers () +drawMap = do + state <- RWS.get + let + 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 + tessFac = state ^. gl.glMap.stateTessellationFactor + (UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex + (UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex + liftIO $ do + glUniform1f tli (fromIntegral tessFac) + glUniform1f tlo (fromIntegral tessFac) + + bindBuffer ArrayBuffer $= Just map' + vertexAttribPointer ci $= fgColorIndex + vertexAttribArray ci $= Enabled + vertexAttribPointer ni $= fgNormalIndex + vertexAttribArray ni $= Enabled + vertexAttribPointer vi $= fgVertexIndex + vertexAttribArray vi $= Enabled + checkError "beforeDraw" + + glPatchParameteri gl_PATCH_VERTICES 3 + + cullFace $= Just Front + + glDrawArrays gl_PATCHES 0 (fromIntegral numVert) + + checkError "draw map" + + ---- RENDER MAPOBJECTS -------------------------------------------- + + currentProgram $= Just (state ^. gl.glMap.objectProgram) + + mapM_ renderObject (state ^. gl.glMap.mapObjects) + + -- set sample 1 as target in renderbuffer + {-framebufferRenderbuffer + DrawFramebuffer --write-only + (ColorAttachment 1) --sample 1 + Renderbuffer --const + rb --buffer-} render :: Pioneers () render = do state <- RWS.get let xa = state ^. camera.xAngle ya = state ^. camera.yAngle - (UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex - (UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex - (UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex - (UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex - (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.Types.frustum camPos = state ^. camera.camObject zDist' = state ^. camera.zDist - tessFac = state ^. gl.glMap.stateTessellationFactor + (UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex + (UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex + (UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex liftIO $ do ---- RENDER MAP IN TEXTURE ------------------------------------------ bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer) - bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer) + {-bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer) framebufferRenderbuffer Framebuffer DepthAttachment Renderbuffer - (state ^. gl.glRenderbuffer) - textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) + (state ^. gl.glRenderbuffer)-} + + -- SHADOWMAP + textureBinding Texture2D $= Just (state ^. gl.glMap.shadowMapTexture) + framebufferTexture2D + Framebuffer + DepthAttachment + Texture2D + (state ^. gl.glMap.shadowMapTexture) + 0 + drawBuffer $= NoBuffers --color-buffer is not needed but must(?) be set up + checkError "setup Render-Target" + + clear [DepthBuffer] + checkError "clearing shadowmap-buffer" + + --TODO: simplified program for shadows? + currentProgram $= Just (state ^. gl.glMap.mapProgram) + checkError "setting up shadowmap-program" + + --set up projection (= copy from state) + --TODO: Fix + with (distribute frust) $ \ptr -> + glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat))) + checkError "copy shadowmap-projection" + + --set up camera + --TODO: Fix + let ! cam = getCam camPos zDist' xa ya + with (distribute cam) $ \ptr -> + glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat))) + checkError "copy shadowmap-cam" + + --set up normal--Mat transpose((model*camera)^-1) + --needed? + let normal' = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of + (Just a) -> a + 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 (L.M33 CFloat))) + + checkError "nmat" + drawMap + liftIO $ do + checkError "draw ShadowMap" + + -- COLORMAP + textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) framebufferTexture2D Framebuffer (ColorAttachment 0) @@ -371,38 +459,8 @@ render = do checkError "nmat" - glUniform1f tli (fromIntegral tessFac) - glUniform1f tlo (fromIntegral tessFac) - - bindBuffer ArrayBuffer $= Just map' - vertexAttribPointer ci $= fgColorIndex - vertexAttribArray ci $= Enabled - vertexAttribPointer ni $= fgNormalIndex - vertexAttribArray ni $= Enabled - vertexAttribPointer vi $= fgVertexIndex - vertexAttribArray vi $= Enabled - checkError "beforeDraw" - - glPatchParameteri gl_PATCH_VERTICES 3 - - cullFace $= Just Front - - glDrawArrays gl_PATCHES 0 (fromIntegral numVert) - - checkError "draw map" - - ---- RENDER MAPOBJECTS -------------------------------------------- - - currentProgram $= Just (state ^. gl.glMap.objectProgram) - - mapM_ renderObject (state ^. gl.glMap.mapObjects) - - -- set sample 1 as target in renderbuffer - {-framebufferRenderbuffer - DrawFramebuffer --write-only - (ColorAttachment 1) --sample 1 - Renderbuffer --const - rb --buffer-} + drawMap --draw map -> put to another function for readability + liftIO $ do ---- COMPOSE RENDERING -------------------------------------------- -- Render to BackBuffer (=Screen) diff --git a/src/Types.hs b/src/Types.hs index 8583f1a..95192bd 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -116,6 +116,7 @@ data GLMapState = GLMapState , _mapProgram :: !GL.Program , _renderedMapTexture :: !TextureObject --TODO: Probably move to UI? , _overviewTexture :: !TextureObject + , _shadowMapTexture :: !TextureObject , _mapTextures :: ![TextureObject] --TODO: Fix size on list? , _objectProgram :: !GL.Program , _mapObjects :: ![MapObject] From dd12f7b136ffb94360082702801a6ef1fbe141be Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 13 May 2014 11:25:06 +0200 Subject: [PATCH 02/25] seperated shaders - shadowmap now uses own shader - not used only defined - changed a bit in tyes. needs refinement - new indices need to be read out and used. refs #495 @3h --- src/Render/Misc.hs | 13 ++++++++++-- src/Render/Render.hs | 49 ++++++++++++++++++++++++++++---------------- src/Types.hs | 23 +++++++++++++-------- 3 files changed, 56 insertions(+), 29 deletions(-) diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index 48e84f9..0fbf58c 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ForeignFunctionInterface #-} module Render.Misc where import Control.Monad @@ -75,6 +74,16 @@ createFrustum fov n' f' rat = (V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n)))) (V4 0 0 (-1) 0) +-- | Creates an orthogonal frustum with given width, height, near and far-plane +createFrustumOrtho :: Float -> Float -> Float -> Float -> M44 CFloat +createFrustumOrtho w' h' n' f' = + let [w,h,n,f] = map realToFrac [w',h',n',f'] + in + V4 (V4 (0.5/w) 0 0 0) + (V4 0 (0.5/h) 0 0) + (V4 0 0 (-2/(f-n)) ((-f+n)/(f-n))) + (V4 0 0 0 1) + -- from vmath.h lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat lookAt eye center up' = @@ -128,5 +137,5 @@ tryWithTexture t f fail' = genColorData :: Int -- ^ Amount -> [Int8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet. -> [Int8] -genColorData n c = take ((length c)*n) (cycle c) +genColorData n c = take (length c*n) (cycle c) diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 39fde96..c51bbd9 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -33,6 +33,8 @@ mapTessEvalShaderFile :: String mapTessEvalShaderFile = "shaders/map/tessEval.shader" mapFragmentShaderFile :: String mapFragmentShaderFile = "shaders/map/fragment.shader" +mapFragmentShaderShadowMapFile :: String +mapFragmentShaderShadowMapFile = "shaders/map/fragmentShadow.shader" objectVertexShaderFile :: String objectVertexShaderFile = "shaders/mapobjects/vertex.shader" @@ -66,6 +68,7 @@ initMapShader tessFac (buf, vertDes) = do ! tessControlSource <- B.readFile mapTessControlShaderFile ! tessEvalSource <- B.readFile mapTessEvalShaderFile ! fragmentSource <- B.readFile mapFragmentShaderFile + ! fragmentShadowSource <- B.readFile mapFragmentShaderShadowMapFile vertexShader <- compileShaderSource VertexShader vertexSource checkError "compile Vertex" tessControlShader <- compileShaderSource TessControlShader tessControlSource @@ -74,7 +77,10 @@ initMapShader tessFac (buf, vertDes) = do checkError "compile TessEval" fragmentShader <- compileShaderSource FragmentShader fragmentSource checkError "compile Frag" + fragmentShadowShader <- compileShaderSource FragmentShader fragmentShadowSource + checkError "compile Frag" program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader] + shadowProgram <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShadowShader] checkError "compile Program" currentProgram $= Just program @@ -139,17 +145,21 @@ initMapShader tessFac (buf, vertDes) = do currentProgram $= Just objProgram checkError "initShader" + let sdata = MapShaderData + { shdrVertexIndex = vertexIndex + , shdrColorIndex = colorIndex + , shdrNormalIndex = normalIndex + , shdrProjMatIndex = projectionMatrixIndex + , shdrViewMatIndex = viewMatrixIndex + , shdrModelMatIndex = modelMatrixIndex + , shdrNormalMatIndex = normalMatrixIndex + , shdrTessInnerIndex = tessLevelInner + , shdrTessOuterIndex = tessLevelOuter + } + return GLMapState { _mapProgram = program - , _shdrColorIndex = colorIndex - , _shdrNormalIndex = normalIndex - , _shdrVertexIndex = vertexIndex - , _shdrProjMatIndex = projectionMatrixIndex - , _shdrViewMatIndex = viewMatrixIndex - , _shdrModelMatIndex = modelMatrixIndex - , _shdrNormalMatIndex = normalMatrixIndex - , _shdrTessInnerIndex = tessLevelInner - , _shdrTessOuterIndex = tessLevelOuter + , _mapShaderData = sdata , _renderedMapTexture = tex , _stateTessellationFactor = tessFac , _stateMap = buf @@ -159,6 +169,7 @@ initMapShader tessFac (buf, vertDes) = do , _shadowMapTexture = smap , _mapObjects = objs , _objectProgram = objProgram + , _shadowMapProgram = shadowProgram } initHud :: IO GLHud @@ -306,14 +317,15 @@ drawMap :: Pioneers () drawMap = do state <- RWS.get let - vi = state ^. gl.glMap.shdrVertexIndex - ni = state ^. gl.glMap.shdrNormalIndex - ci = state ^. gl.glMap.shdrColorIndex + d = state ^. gl.glMap.mapShaderData + vi = shdrVertexIndex d + ni = shdrNormalIndex d + ci = shdrColorIndex d numVert = state ^. gl.glMap.mapVert map' = state ^. gl.glMap.stateMap tessFac = state ^. gl.glMap.stateTessellationFactor - (UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex - (UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex + (UniformLocation tli) = shdrTessInnerIndex d + (UniformLocation tlo) = shdrTessOuterIndex d liftIO $ do glUniform1f tli (fromIntegral tessFac) glUniform1f tlo (fromIntegral tessFac) @@ -356,9 +368,10 @@ render = do frust = state ^. camera.Types.frustum camPos = state ^. camera.camObject zDist' = state ^. camera.zDist - (UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex - (UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex - (UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex + d = state ^. gl.glMap.mapShaderData + (UniformLocation proj) = shdrProjMatIndex d + (UniformLocation nmat) = shdrNormalMatIndex d + (UniformLocation vmat) = shdrViewMatIndex d liftIO $ do ---- RENDER MAP IN TEXTURE ------------------------------------------ @@ -391,7 +404,7 @@ render = do --set up projection (= copy from state) --TODO: Fix - with (distribute frust) $ \ptr -> + with (distribute (createFrustumOrtho 20 20 0 100)) $ \ptr -> glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat))) checkError "copy shadowmap-projection" diff --git a/src/Types.hs b/src/Types.hs index 95192bd..f16333c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -101,15 +101,7 @@ data KeyboardState = KeyboardState data GLMapState = GLMapState - { _shdrVertexIndex :: !GL.AttribLocation - , _shdrColorIndex :: !GL.AttribLocation - , _shdrNormalIndex :: !GL.AttribLocation - , _shdrProjMatIndex :: !GL.UniformLocation - , _shdrViewMatIndex :: !GL.UniformLocation - , _shdrModelMatIndex :: !GL.UniformLocation - , _shdrNormalMatIndex :: !GL.UniformLocation - , _shdrTessInnerIndex :: !GL.UniformLocation - , _shdrTessOuterIndex :: !GL.UniformLocation + { _mapShaderData :: !MapShaderData , _stateTessellationFactor :: !Int , _stateMap :: !GL.BufferObject , _mapVert :: !GL.NumArrayIndices @@ -120,6 +112,19 @@ data GLMapState = GLMapState , _mapTextures :: ![TextureObject] --TODO: Fix size on list? , _objectProgram :: !GL.Program , _mapObjects :: ![MapObject] + , _shadowMapProgram :: !GL.Program + } + +data MapShaderData = MapShaderData + { shdrVertexIndex :: !GL.AttribLocation + , shdrColorIndex :: !GL.AttribLocation + , shdrNormalIndex :: !GL.AttribLocation + , shdrProjMatIndex :: !GL.UniformLocation + , shdrViewMatIndex :: !GL.UniformLocation + , shdrModelMatIndex :: !GL.UniformLocation + , shdrNormalMatIndex :: !GL.UniformLocation + , shdrTessInnerIndex :: !GL.UniformLocation + , shdrTessOuterIndex :: !GL.UniformLocation } data MapObject = MapObject !IQM !MapCoordinates !MapObjectState From 13fbb9b81616f854b30b8bff2afd91ef332b152f Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 13 May 2014 12:52:00 +0200 Subject: [PATCH 03/25] minor fixture --- src/Render/Render.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Render/Render.hs b/src/Render/Render.hs index c51bbd9..6d49e27 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -403,14 +403,14 @@ render = do checkError "setting up shadowmap-program" --set up projection (= copy from state) - --TODO: Fix + --TODO: Fix width/depth with (distribute (createFrustumOrtho 20 20 0 100)) $ \ptr -> glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat))) checkError "copy shadowmap-projection" --set up camera - --TODO: Fix - let ! cam = getCam camPos zDist' xa ya + --TODO: Fix magic constants... and camPos + let ! cam = getCam camPos 1 0.7 0 with (distribute cam) $ \ptr -> glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat))) checkError "copy shadowmap-cam" From f598d72e9a8d1fa7743e04ee4079f2d25cfce048 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 13 May 2014 13:03:28 +0200 Subject: [PATCH 04/25] changed num mountains and height --- src/Map/Creation.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 554cb6c..8ae1717 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -72,9 +72,9 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d) heightToTerrain :: MapType -> YCoord -> TileType heightToTerrain GrassIslandMap y | y < 0.1 = Ocean - | y < 1 = Beach - | y < 5 = Grass - | y < 10 = Hill + | y < 0.2 = Beach + | y < 1 = Grass + | y < 3 = Hill | otherwise = Mountain heightToTerrain _ _ = undefined @@ -87,16 +87,16 @@ river = undefined mnt :: IO [PlayMap -> PlayMap] mnt = do g <- newStdGen - let seeds = take 10 $ randoms g - return $ map (gaussMountain) seeds + let seeds = take 50 $ randoms g + return $ map gaussMountain seeds gaussMountain :: Int -> PlayMap -> PlayMap gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp where g = mkStdGen seed c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g))) - amp = head $ randomRs (5.0, 20.0) g - sig = head $ randomRs (5.0, 25.0) g + amp = head $ randomRs (2.0, 5.0) g + sig = head $ randomRs (1.0, 5.0) g fi = fromIntegral htt = heightToTerrain From 1bfec031e2932b5a77783a180219f27205d3fe2b Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 13 May 2014 14:11:02 +0200 Subject: [PATCH 05/25] fixed import --- src/Render/Misc.hs | 4 ++++ src/Render/Render.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index 0fbf58c..f7163a5 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -139,3 +139,7 @@ genColorData :: Int -- ^ Amount -> [Int8] genColorData n c = take (length c*n) (cycle c) +-- from GLUtil +-- |Allocate and fill a 'BufferObject' from a list of 'Storable's. +makeBuffer :: Storable a => BufferTarget -> [a] -> IO BufferObject +makeBuffer target elems = makeBufferLen target (length elems) elems diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 6d49e27..b732045 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -7,7 +7,7 @@ import Foreign.Storable import Graphics.Rendering.OpenGL.GL import Graphics.Rendering.OpenGL.Raw.Core31 import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader -import Graphics.GLUtil.BufferObjects (offset0) +import Graphics.GLUtil.BufferObjects import qualified Linear as L import Control.Lens ((^.)) import Control.Monad.RWS.Strict (liftIO) From b5a4d03f8cc7b2ffb82b224d4024bb33a77c9bb4 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 13 May 2014 15:04:20 +0200 Subject: [PATCH 06/25] array-objects get initialized - initialized array-objects - still need to be rendered and collected to a VertexBufferObject refs #482 @2h --- src/Importer/IQM/Parser.hs | 26 ++++++++++++++++++++++++-- src/Importer/IQM/Types.hs | 2 ++ src/Render/Misc.hs | 5 ----- 3 files changed, 26 insertions(+), 7 deletions(-) diff --git a/src/Importer/IQM/Parser.hs b/src/Importer/IQM/Parser.hs index 1d5b9fe..e68ad95 100644 --- a/src/Importer/IQM/Parser.hs +++ b/src/Importer/IQM/Parser.hs @@ -13,6 +13,8 @@ import Data.ByteString.Char8 (pack) import Data.ByteString (split, null, ByteString) import Data.ByteString.Unsafe (unsafeUseAsCString) import qualified Data.ByteString as B +import Graphics.GLUtil +import Graphics.Rendering.OpenGL.GL.BufferObjects import Data.Word import Data.Int import Unsafe.Coerce @@ -211,10 +213,29 @@ parseIQM a = -- Fill Vertex-Arrays with data of Offsets let va = vertexArrays raw va' <- mapM (readInVAO f) va - return $ raw { - vertexArrays = va' + vbo <- sequence $ map toVBOfromVAO va + return $ raw + { vertexArrays = va' + , vertexArrayObjects = vbo } +-- | Creates a BufferObject on the Graphicscard for each BufferObject + +toVBOfromVAO :: IQMVertexArray -> IO BufferObject +toVBOfromVAO (IQMVertexArray type' _ _ num _ ptr) = + fromPtr (toBufferTargetfromVAType type') (fromIntegral num) ptr + +-- | translates from VA-type to BufferTarget + +toBufferTargetfromVAType :: IQMVertexArrayType -> BufferTarget +toBufferTargetfromVAType IQMPosition = ArrayBuffer +toBufferTargetfromVAType IQMTexCoord = TextureBuffer +toBufferTargetfromVAType IQMNormal = ArrayBuffer +toBufferTargetfromVAType IQMBlendIndexes = ElementArrayBuffer +toBufferTargetfromVAType IQMBlendWeights = ArrayBuffer +toBufferTargetfromVAType IQMColor = ArrayBuffer +toBufferTargetfromVAType _ = ArrayBuffer + -- | Allocates memory for the Vertex-data and copies it over there -- from the given input-String -- @@ -254,6 +275,7 @@ doIQMparse = , texts = filter (not.null) (split (unsafeCoerce '\0') text) , meshes = meshes' , vertexArrays = vaf + , vertexArrayObjects = [] --initialized later, after vaf get allocated. } -- | Helper-Function for Extracting a random substring out of a Bytestring diff --git a/src/Importer/IQM/Types.hs b/src/Importer/IQM/Types.hs index 847320f..0692398 100644 --- a/src/Importer/IQM/Types.hs +++ b/src/Importer/IQM/Types.hs @@ -13,6 +13,7 @@ import Graphics.Rendering.OpenGL.Raw.Types import Prelude as P import Foreign.Storable import Foreign.C.Types +import Graphics.Rendering.OpenGL.GL.BufferObjects hiding (Offset) -- | Mesh-Indices to distinguish the meshes referenced newtype Mesh = Mesh Word32 deriving (Show, Eq) @@ -108,6 +109,7 @@ data IQM = IQM , texts :: [ByteString] , meshes :: [IQMMesh] , vertexArrays :: [IQMVertexArray] + , vertexArrayObjects :: [BufferObject] } deriving (Show, Eq) -- | Different Vertex-Array-Types in IQM diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index f7163a5..a00a408 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -138,8 +138,3 @@ genColorData :: Int -- ^ Amount -> [Int8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet. -> [Int8] genColorData n c = take (length c*n) (cycle c) - --- from GLUtil --- |Allocate and fill a 'BufferObject' from a list of 'Storable's. -makeBuffer :: Storable a => BufferTarget -> [a] -> IO BufferObject -makeBuffer target elems = makeBufferLen target (length elems) elems From db0631eb4badaee587645c9e9462a5068d7e0952 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Wed, 14 May 2014 20:04:06 +0200 Subject: [PATCH 07/25] forgot file --- shaders/map/fragmentShadow.shader | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 shaders/map/fragmentShadow.shader diff --git a/shaders/map/fragmentShadow.shader b/shaders/map/fragmentShadow.shader new file mode 100644 index 0000000..3ec66e9 --- /dev/null +++ b/shaders/map/fragmentShadow.shader @@ -0,0 +1,15 @@ +#version 330 + +smooth in vec3 teNormal; +smooth in vec3 tePosition; +smooth in float fogDist; +smooth in float gmix; +in vec4 teColor; +in vec3 tePatchDistance; + +uniform mat4 ViewMatrix; +uniform mat4 ProjectionMatrix; + +void main(void) +{ +} From 87946cb5012816061229ef8919650d86f6f63154 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Wed, 14 May 2014 20:13:40 +0200 Subject: [PATCH 08/25] modified camara-height-limit to reflect later game better --- src/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 8390f1f..0d97808 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -93,8 +93,8 @@ main = --TTF.setFontHinting font TTFHNormal glHud' <- initHud - let zDistClosest' = 1 - zDistFarthest' = zDistClosest' + 50 + let zDistClosest' = 2 + zDistFarthest' = zDistClosest' + 10 --TODO: Move near/far/fov to state for runtime-changability & central storage fov = 90 --field of view near = 1 --near plane From 67428146ca595603139fd9d81adf2dc8986bad95 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Thu, 15 May 2014 10:44:54 +0200 Subject: [PATCH 09/25] added height function --- src/Map/Map.hs | 60 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 58 insertions(+), 2 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 7ea3593..ced09c0 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -1,9 +1,11 @@ module Map.Map where import Map.Types +import Map.Creation -import Data.Array (bounds) -import Data.List (sort, group) +import Data.Function (on) +import Data.Array (bounds, (!)) +import Data.List (sort, sortBy, group) -- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet. unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates @@ -36,6 +38,60 @@ giveNeighbourhood _ 0 (a,b) = [(a,b)] giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns +-- | Calculates the height of any given point on the map. +-- Does not add camera distance to ground to that. +-- +-- This ueses barycentric coordinate stuff. Wanna read more? +-- http://en.wikipedia.org/wiki/Barycentric_coordinate_system_%28mathematics%29 +-- http://www.alecjacobson.com/weblog/?p=1596 +-- +giveMapHeight :: PlayMap + -> (Float, Float) -- ^ Coordinates on X/Z-axes + -> Float -- ^ Terrain Height at that position +giveMapHeight mp (x,z) = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc] + ar = area (fi a) (fi b) (fi c) + λa = area (fi b) (fi c) (x, z) / ar + λb = area (fi a) (fi c) (x, z) / ar + λc = area (fi a) (fi b) (x, z) / ar + in (λa * hlu a) + (λb * hlu b) + (λc * hlu c) + where + + fi :: (Int, Int) -> (Float, Float) + fi (m, n) = (fromIntegral m, fromIntegral n) + + -- Height LookUp + hlu :: (Int, Int) -> Float + hlu (k,j) = let node = mp ! (k,j) + in case node of + (Full _ y _ _ _ _ _ _) -> y + (Minimal _ ) -> 1.0 + + ff = (floor x, floor z) :: (Int, Int) + fc = (floor x, ceiling z) :: (Int, Int) + cf = (ceiling x, floor z) :: (Int, Int) + cc = (ceiling x, ceiling z) :: (Int, Int) + + tff = (ff, dist (x,z) ff) + tfc = (fc, dist (x,z) fc) + tcf = (cf, dist (x,z) cf) + tcc = (cc, dist (x,z) cc) + + getTrianglePoints :: [((Int,Int), Float)] -> [(Int,Int)] + getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd))) + + dist :: (Float, Float) -> (Int, Int) -> Float + dist (x1,z1) (x2,z2) = let x' = x1 - fromIntegral x2 + z' = z1 - fromIntegral z2 + in sqrt $ x'*x' + z'*z' + + -- Heron's Formula: http://en.wikipedia.org/wiki/Heron%27s_formula + area :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float + area (x1,z1) (x2,z2) (x3,z3) = let a = sqrt $ (x1-x2)*(x1-x2) + (z1-z2)*(z1-z2) + b = sqrt $ (x2-x3)*(x2-x3) + (z2-z3)*(z2-z3) + c = sqrt $ (x1-x3)*(x1-x3) + (z1-z3)*(z1-z3) + s = (a+b+c)/2 + in sqrt $ s * (s-a) * (s-b) * (s-c) + -- removing duplicates in O(n log n), losing order and adding Ord requirement remdups :: Ord a => [a] -> [a] remdups = map head . group . sort From eb3ee975e8f4d9f3d9476b83f8f850746e011b51 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Thu, 15 May 2014 12:01:30 +0200 Subject: [PATCH 10/25] =?UTF-8?q?Restructured=20Node=20constructors.=20Rip?= =?UTF-8?q?ples=20are=20getting=20worse!=20(=E2=95=AF=C2=B0=E2=96=A1=C2=B0?= =?UTF-8?q?=EF=BC=89=E2=95=AF=EF=B8=B5=20=E2=94=BB=E2=94=81=E2=94=BB?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Pioneers.cabal | 1 - src/Map/Creation.hs | 28 ++++++++++++------------- src/Map/Graphics.hs | 6 ++---- src/Map/Map.hs | 5 +---- src/Map/StaticMaps.hs | 49 ------------------------------------------- src/Map/Types.hs | 13 ++++++------ 6 files changed, 24 insertions(+), 78 deletions(-) delete mode 100644 src/Map/StaticMaps.hs diff --git a/Pioneers.cabal b/Pioneers.cabal index fadfec1..bf7c426 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -16,7 +16,6 @@ executable Pioneers Map.Types, Map.Graphics, Map.Creation, - Map.StaticMaps, Importer.IQM.Types, Importer.IQM.Parser, Render.Misc, diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 554cb6c..c2304f0 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,7 +2,6 @@ module Map.Creation where import Map.Types -import Map.StaticMaps -- import Map.Map unused (for now) import Data.Array @@ -18,6 +17,10 @@ infix 5 -<- (-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap f -<- g = f . g +-- entirely empty map, only uses the minimal constructor +mapEmpty :: PlayMap +mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]] + exportedMap :: IO PlayMap exportedMap = do mounts <- mnt return $ aplAll mounts mapEmpty @@ -52,7 +55,7 @@ gauss3Dgeneral :: Floating q => -> q -- ^ Coordinate in question on X -> q -- ^ Coordinate in question on Z -> q -- ^ elevation on coordinate in question -gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Integer)/(2 * sX^(2 :: Integer)))+((z-z0)^(2 :: Integer)/(2 * sZ^(2 :: Integer))))) +gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int))))) -- specialised 3D gaussian with an origin on 100/100, an amplitude of 15 and two sigmas of 15 gauss3D :: Floating q => @@ -71,8 +74,8 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d) -- TODO: Implement Desert-Generator heightToTerrain :: MapType -> YCoord -> TileType heightToTerrain GrassIslandMap y - | y < 0.1 = Ocean - | y < 1 = Beach + | y < 0.1 = Ocean + | y < 1 = Beach | y < 5 = Grass | y < 10 = Hill | otherwise = Mountain @@ -93,20 +96,17 @@ mnt = do g <- newStdGen gaussMountain :: Int -> PlayMap -> PlayMap gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp where - g = mkStdGen seed - c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g))) - amp = head $ randomRs (5.0, 20.0) g - sig = head $ randomRs (5.0, 25.0) g - fi = fromIntegral + gs = map mkStdGen (map (*seed) [1..]) + c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1)))) + amp = head $ randomRs ((5.0, 20.0) :: (Float, Float)) (gs !! 2) + sig = head $ randomRs ((5.0, 25.0) :: (Float, Float)) (gs !! 3) htt = heightToTerrain -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map liftUp :: (Int, Int) -> Node -> Node - liftUp (gx,gz) (Full (x,z) y _ b pl pa r s) = let y_neu = max y e - in Full (x,z) y_neu (htt GrassIslandMap y_neu) b pl pa r s - where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z) - liftUp (gx, gz) (Minimal (x,z)) = Full (x,z) e (htt GrassIslandMap e) BFlag NoPlayer NoPath Plain [] - where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z) + liftUp (gx,gz) (Node (x,z) (rx,rz,y) _ b pl pa r s) = let y_neu = max y e + in Node (x,z) (rx, rz, y_neu) (htt GrassIslandMap y_neu) b pl pa r s + where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz -- | Makes sure the edges of the Map are mountain-free makeIsland :: PlayMap -> PlayMap diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 858b1f4..a99348b 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -50,16 +50,14 @@ stripify :: (Int,Int) -> (Int,Int) stripify (x,z) = (if even z then 2*x else 2*x+1, z `div` 2) strp :: Node -> Node -strp (Full xz y tt bi pli p ri si) = Full (stripify xz) y tt bi pli p ri si -strp (Minimal xz ) = Minimal (stripify xz) +strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si -- extract graphics information from Playmap convertToGraphicsMap :: PlayMap -> GraphicsMap convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp] where graphicsyfy :: Node -> MapEntry - graphicsyfy (Minimal _ ) = (1.0, Grass) - graphicsyfy (Full _ y t _ _ _ _ _ ) = (y, t) + graphicsyfy (Node _ (_,_,y) t _ _ _ _ _ ) = (y, t) lineHeight :: GLfloat lineHeight = 0.8660254 diff --git a/src/Map/Map.hs b/src/Map/Map.hs index ced09c0..53a0976 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -61,10 +61,7 @@ giveMapHeight mp (x,z) = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc] -- Height LookUp hlu :: (Int, Int) -> Float - hlu (k,j) = let node = mp ! (k,j) - in case node of - (Full _ y _ _ _ _ _ _) -> y - (Minimal _ ) -> 1.0 + hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mp ! (k,j) in y ff = (floor x, floor z) :: (Int, Int) fc = (floor x, ceiling z) :: (Int, Int) diff --git a/src/Map/StaticMaps.hs b/src/Map/StaticMaps.hs deleted file mode 100644 index 5ef9942..0000000 --- a/src/Map/StaticMaps.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Map.StaticMaps -where - -import Map.Types -import Data.Array - --- entirely empty map, only uses the minimal constructor -mapEmpty :: PlayMap -mapEmpty = array ((0,0), (199,199)) [((a,b), Minimal (a,b)) | a <- [0..199], b <- [0..199]] - ---mapCenterMountain :: PlayMap ---mapCenterMountain = array ((0,0),(199,199)) nodes --- where --- nodes = water ++ beach ++ grass ++ hill ++ mountain --- water = [((a,b), Full (a,b) 0.0 Ocean BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) > 95] --- beach = [((a,b), Full (a,b) (g2d a b) Beach BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 95, m2d (a,b) > 75] --- grass = [((a,b), Full (a,b) (g2d a b) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 75, m2d (a,b) > 25] --- hill = [((a,b), Full (a,b) (g2d a b) Hill BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 25, m2d (a,b) > 10] --- mountain = [((a,b), Full (a,b) (g2d a b) Mountain BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 10] - --- g2d :: Int -> Int -> Float --- g2d x y = gauss3D (fromIntegral x) (fromIntegral y) - --- m2d :: (Int,Int) -> Int --- m2d (x,y) = mnh2D (x,y) (100,100) - --- small helper for some hills. Should be replaced by multi-layer perlin-noise --- TODO: Replace as given in comment. ---_noisyMap :: (Floating q) => q -> q -> q ---_noisyMap x y = gauss3Dgeneral 15 100.0 100.0 15.0 15.0 x y --- + gauss3Dgeneral 5 10.0 10.0 10.0 10.0 x y --- + gauss3Dgeneral 5 150.0 120.0 10.0 10.0 x y --- + gauss3Dgeneral 5 50.0 75.0 10.0 10.0 x y - --- generates a noisy map --- TODO: add real noise to a simple pattern ---mapNoise :: PlayMap ---mapNoise = array ((0,0),(199,199)) nodes --- where --- nodes = [((a,b), Full (a,b) --- (height a b) --- (heightToTerrain GrassIslandMap $ height a b) --- BNothing --- NoPlayer --- NoPath --- Plain --- []) | a <- [0..199], b <- [0..199]] --- where --- height a b = _noisyMap (fromIntegral a) (fromIntegral b) diff --git a/src/Map/Types.hs b/src/Map/Types.hs index c62837f..dd66236 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -5,10 +5,12 @@ import Types import Data.Array -type PlayMap = Array (XCoord, ZCoord) Node +type PlayMap = Array (Xindex, Zindex) Node -type XCoord = Int -type ZCoord = Int +type Xindex = Int +type Zindex = Int +type XCoord = Float +type ZCoord = Float type YCoord = Float data MapType = GrassIslandMap @@ -66,7 +68,6 @@ data TileType = Ocean | Mountain -- ^ Not accessible deriving (Show, Eq) --- TODO: Record Syntax -data Node = Full (XCoord, ZCoord) YCoord TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo - | Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1 +-- TODO: Record Syntax? +data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo deriving (Show) From 8e2d46c7ef27a8c3dc6aab2f43490e63ea62576b Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Thu, 15 May 2014 12:06:18 +0200 Subject: [PATCH 11/25] Fixed the hell out of that snow! --- src/Map/Graphics.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index a99348b..0995741 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -201,8 +201,8 @@ colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0) Beach -> (0.90, 0.85, 0.70) Desert -> (1.00, 0.87, 0.39) Grass -> (0.30, 0.90, 0.10) - Hill -> (0.80, 0.80, 0.80) - Mountain -> (0.50, 0.50, 0.50) + Mountain -> (0.80, 0.80, 0.80) + Hill -> (0.50, 0.50, 0.50) coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat coordLookup (x,z) y = From d83c87db1d671f11c78a08ffba9f8c79a625be62 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Thu, 15 May 2014 15:10:10 +0200 Subject: [PATCH 12/25] cam now moves with height. - cam still has NaN-Issues --- src/Main.hs | 12 +++++---- src/Map/Graphics.hs | 5 ++-- src/Map/Types.hs | 63 ++++++++++++++++++++++++++++++++++++++++++-- src/Render/Render.hs | 1 + src/Render/Types.hs | 35 +++++++++++++++--------- src/Types.hs | 63 ++------------------------------------------ 6 files changed, 96 insertions(+), 83 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0d97808..9f6c15e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -43,6 +43,7 @@ import Render.Render (initRendering, import Render.Types import UI.Callbacks import Map.Graphics +import Map.Creation (exportedMap) import Types import Importer.IQM.Parser --import Data.Attoparsec.Char8 (parseTest) @@ -53,7 +54,7 @@ import Importer.IQM.Parser -------------------------------------------------------------------------------- testParser :: String -> IO () -testParser a = putStrLn . show =<< parseIQM a +testParser a = print =<< parseIQM a {-do f <- B.readFile a putStrLn "reading in:" @@ -85,7 +86,8 @@ main = (SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window' initRendering --generate map vertices - glMap' <- initMapShader 4 =<< getMapBufferObject + curMap <- exportedMap + glMap' <- initMapShader 4 =<< getMapBufferObject curMap eventQueue <- newTQueueIO :: IO (TQueue SDL.Event) now <- getCurrentTime --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10 @@ -125,7 +127,7 @@ main = , _yAngle = pi/2 , _zDist = 10 , _frustum = frust - , _camObject = createFlatCam 25 25 + , _camObject = createFlatCam 25 25 curMap } , _io = IOState { _clock = now @@ -153,7 +155,7 @@ main = , _glFramebuffer = frameBuffer } , _game = GameState - { + { _currentMap = curMap } , _ui = UIState { _uiHasChanged = True @@ -216,7 +218,7 @@ run = do - 0.2 * kyrot * mults mody y' = y' + 0.2 * kxrot * mults - 0.2 * kyrot * multc - modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y))) + modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (state ^. game.currentMap)) {- --modify the state with all that happened in mt time. diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 0995741..7c9c93f 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -85,9 +85,8 @@ fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal -getMapBufferObject :: IO (BufferObject, NumArrayIndices) -getMapBufferObject = do - eMap <- exportedMap +getMapBufferObject :: PlayMap -> IO (BufferObject, NumArrayIndices) +getMapBufferObject eMap = do myMap' <- return $ convertToGraphicsMap $ convertToStripeMap eMap ! myMap <- return $ generateTriangles myMap' len <- return $ fromIntegral $ P.length myMap `div` numComponents diff --git a/src/Map/Types.hs b/src/Map/Types.hs index dd66236..cd3f246 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -1,8 +1,6 @@ module Map.Types where -import Types - import Data.Array type PlayMap = Array (Xindex, Zindex) Node @@ -71,3 +69,64 @@ data TileType = Ocean -- TODO: Record Syntax? data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo deriving (Show) + +data Structure = Flag -- Flag + | Woodcutter -- Huts + | Forester + | Stonemason + | Fisher + | Hunter + | Barracks + | Guardhouse + | LookoutTower + | Well + | Sawmill -- Houses + | Slaughterhouse + | Mill + | Bakery + | IronSmelter + | Metalworks + | Armory + | Mint + | Shipyard + | Brewery + | Storehouse + | Watchtower + | Catapult + | GoldMine -- Mines + | IronMine + | GraniteMine + | CoalMine + | Farm -- Castles + | PigFarm + | DonkeyBreeder + | Harbor + | Fortress + deriving (Show, Eq) + +data Amount = Infinite -- Neverending supply + | Finite Int -- Finite supply + +-- Extremely preliminary, expand when needed +data Commodity = WoodPlank + | Sword + | Fish + deriving Eq + +data Resource = Coal + | Iron + | Gold + | Granite + | Water + | Fishes + deriving (Show, Eq) + +instance Show Amount where + show (Infinite) = "inexhaustable supply" + show (Finite n) = show n ++ " left" + +instance Show Commodity where + show WoodPlank = "wooden plank" + show Sword = "sword" + show Fish = "fish" + diff --git a/src/Render/Render.hs b/src/Render/Render.hs index b732045..7863ceb 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -24,6 +24,7 @@ import Render.Types import Graphics.GLUtil.BufferObjects (makeBuffer) import Importer.IQM.Parser import Importer.IQM.Types +import Map.Map (giveMapHeight) mapVertexShaderFile :: String mapVertexShaderFile = "shaders/map/vertex.shader" diff --git a/src/Render/Types.hs b/src/Render/Types.hs index e7273b2..0b60da1 100644 --- a/src/Render/Types.hs +++ b/src/Render/Types.hs @@ -4,6 +4,10 @@ module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where import Linear import Foreign.C (CFloat) import Render.Misc (lookAt) +import Map.Map (giveMapHeight) +import Map.Types (PlayMap) +import GHC.Float +import qualified Debug.Trace as D type Distance = Double type Pitch = Double @@ -11,30 +15,32 @@ type Yaw = Double class GLCamera a where getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat - moveBy :: a -> (Position -> Position) -> a - move :: a -> Position -> a + moveBy :: a -> (Position -> Position) -> PlayMap -> a + move :: a -> Position -> PlayMap -> a type Position = (Double, Double) type Radius = Double -data Camera = Flat Position +type Height = Double + +data Camera = Flat Position Height | Sphere Position Radius -- | create a Flatcam-Camera starting at given x/z-Coordinates -createFlatCam :: Double -> Double -> Camera -createFlatCam x z = Flat (x,z) +createFlatCam :: Double -> Double -> PlayMap -> Camera +createFlatCam x z map' = Flat (x,z) (float2Double $ giveMapHeight map' (double2Float x,double2Float z)) -- | create a Flatcam-Camera starting at given pitch/azimuth/radius createSphereCam :: Double -> Double -> Double -> Camera -createSphereCam p a r = Sphere (p,a) r +createSphereCam p a = Sphere (p,a) instance GLCamera Camera where - getCam (Flat (x',z')) dist' xa' ya' = + getCam (Flat (x',z') y') dist' xa' ya' = lookAt (cpos ^+^ at') at' up where - at' = V3 x 0 z + at' = V3 x y z cpos = crot !* (V3 0 0 (-dist)) crot = ( (fromQuaternion $ axisAngle upmap (xa::CFloat)) @@ -44,6 +50,7 @@ instance GLCamera Camera where upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat) !* (V3 1 0 0) x = realToFrac x' + y = realToFrac y' z = realToFrac z' dist = realToFrac dist' xa = realToFrac xa' @@ -68,12 +75,16 @@ instance GLCamera Camera where dist = realToFrac dist' xa = realToFrac xa' ya = realToFrac ya' - moveBy (Sphere (inc, az) r) f = undefined - moveBy (Flat (x', z')) f = Flat (f (x',z')) - move c (x', z') = moveBy c (\(x,z) -> (x+x',z+z')) + moveBy (Sphere (inc, az) r) f map = undefined + moveBy (Flat (x', z') y) f map = Flat (x,z) (float2Double y) + where + (x,z) = f (x', z') + y = giveMapHeight map (fc x,fc z) + fc = double2Float + move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map sphereToCart :: (Floating a) => a -> a -> a -> V3 a sphereToCart r inc az = V3 (r * (sin inc) * (cos az)) (r * (sin inc) * (sin az)) - (r * (cos inc)) \ No newline at end of file + (r * (cos inc)) diff --git a/src/Types.hs b/src/Types.hs index f16333c..d9795bf 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -15,6 +15,7 @@ import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types import Importer.IQM.Types import UI.UIBase +import Map.Types (PlayMap) data Coord3D a = Coord3D a a a @@ -56,7 +57,7 @@ data IOState = IOState } data GameState = GameState - { + { _currentMap :: !PlayMap } data MouseState = MouseState @@ -186,63 +187,3 @@ $(makeLenses ''Position) $(makeLenses ''Env) $(makeLenses ''UIState) -data Structure = Flag -- Flag - | Woodcutter -- Huts - | Forester - | Stonemason - | Fisher - | Hunter - | Barracks - | Guardhouse - | LookoutTower - | Well - | Sawmill -- Houses - | Slaughterhouse - | Mill - | Bakery - | IronSmelter - | Metalworks - | Armory - | Mint - | Shipyard - | Brewery - | Storehouse - | Watchtower - | Catapult - | GoldMine -- Mines - | IronMine - | GraniteMine - | CoalMine - | Farm -- Castles - | PigFarm - | DonkeyBreeder - | Harbor - | Fortress - deriving (Show, Eq) - -data Amount = Infinite -- Neverending supply - | Finite Int -- Finite supply - --- Extremely preliminary, expand when needed -data Commodity = WoodPlank - | Sword - | Fish - deriving Eq - -data Resource = Coal - | Iron - | Gold - | Granite - | Water - | Fishes - deriving (Show, Eq) - -instance Show Amount where - show (Infinite) = "inexhaustable supply" - show (Finite n) = show n ++ " left" - -instance Show Commodity where - show WoodPlank = "wooden plank" - show Sword = "sword" - show Fish = "fish" - From f2fbf101ef8c24380573af789c8abe0d2df83fa8 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 11:30:15 +0200 Subject: [PATCH 13/25] Camera function not NaNing / breaking anymore / merge tessalation --- src/Map/Creation.hs | 26 ++------------------------ src/Map/Map.hs | 31 ++++++++++++++++++++++++------- 2 files changed, 26 insertions(+), 31 deletions(-) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 944d2b9..91faee9 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -2,21 +2,10 @@ module Map.Creation where import Map.Types --- import Map.Map unused (for now) import Data.Array import System.Random --- preliminary -infix 5 ->- -(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap -f ->- g = g . f - --- also preliminary -infix 5 -<- -(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap -f -<- g = f . g - -- entirely empty map, only uses the minimal constructor mapEmpty :: PlayMap mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]] @@ -57,17 +46,6 @@ gauss3Dgeneral :: Floating q => -> q -- ^ elevation on coordinate in question gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int))))) --- specialised 3D gaussian with an origin on 100/100, an amplitude of 15 and two sigmas of 15 -gauss3D :: Floating q => - q -- ^ X-Coordinate - -> q -- ^ Z-Coordinate - -> q -- ^ elevation on coordinate in quesion -gauss3D = gauss3Dgeneral 15 100.0 100.0 15.0 15.0 - --- 2D Manhattan distance -mnh2D :: (Int,Int) -> (Int,Int) -> Int -mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d) - -- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome -- (like Deserts on Grass-Islands or Grass on Deserts) -- @@ -75,9 +53,9 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d) heightToTerrain :: MapType -> YCoord -> TileType heightToTerrain GrassIslandMap y | y < 0.1 = Ocean - | y < 0.2 = Beach + | y < 0.2 = Beach | y < 1 = Grass - | y < 3 = Hill + | y < 3 = Hill | otherwise = Mountain heightToTerrain _ _ = undefined diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 53a0976..98c5912 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -1,7 +1,6 @@ module Map.Map where import Map.Types -import Map.Creation import Data.Function (on) import Data.Array (bounds, (!)) @@ -48,14 +47,32 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in giveMapHeight :: PlayMap -> (Float, Float) -- ^ Coordinates on X/Z-axes -> Float -- ^ Terrain Height at that position -giveMapHeight mp (x,z) = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc] - ar = area (fi a) (fi b) (fi c) - λa = area (fi b) (fi c) (x, z) / ar - λb = area (fi a) (fi c) (x, z) / ar - λc = area (fi a) (fi b) (x, z) / ar - in (λa * hlu a) + (λb * hlu b) + (λc * hlu c) +giveMapHeight mp (x,z) + | outsideMap (x,z) = 0.0 + | (isInt z 6) && (isInt x 6) = hlu (round x, round z) + | (isInt z 6) = let dist_down = x - fromIntegral ((floor x) :: Int) + dist_up = fromIntegral ((ceiling x) :: Int) - x + in (1 - dist_down) * (hlu (floor x, round z)) + (1 - dist_up) * (hlu (ceiling x, round z)) + | (isInt x 6) = let dist_down = z - fromIntegral ((floor z) :: Int) + dist_up = fromIntegral ((ceiling z) :: Int) - z + in (1 - dist_down) * (hlu (round x, floor z)) + (1 - dist_up) * (hlu (round x, ceiling z)) + | otherwise = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc] + ar = area (fi a) (fi b) (fi c) + λa = area (fi b) (fi c) (x, z) / ar + λb = area (fi a) (fi c) (x, z) / ar + λc = area (fi a) (fi b) (x, z) / ar + in (λa * hlu a) + (λb * hlu b) + (λc * hlu c) where + --Returns if q is an int to n decimal places + isInt :: RealFrac b => b -> Int -> Bool + isInt q n = (round $ 10^((fromIntegral n) :: Integer) * (q - (fromIntegral ((round q):: Integer)))) == (0 :: Integer) + + outsideMap :: (Float, Float) -> Bool + outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mp + fr = fromIntegral + in mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d) + fi :: (Int, Int) -> (Float, Float) fi (m, n) = (fromIntegral m, fromIntegral n) From 1c1aedda3021e3c843b998836c6123e7bc20c93e Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 11:39:29 +0200 Subject: [PATCH 14/25] Grass is back, bettered mountains --- src/Map/Creation.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 91faee9..205c99b 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -54,7 +54,7 @@ heightToTerrain :: MapType -> YCoord -> TileType heightToTerrain GrassIslandMap y | y < 0.1 = Ocean | y < 0.2 = Beach - | y < 1 = Grass + | y < 1.5 = Grass | y < 3 = Hill | otherwise = Mountain heightToTerrain _ _ = undefined @@ -77,7 +77,7 @@ gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp gs = map mkStdGen (map (*seed) [1..]) c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1)))) amp = head $ randomRs ((2.0, 5.0) :: (Float, Float)) (gs !! 2) - sig = head $ randomRs ((1.0, 15.0) :: (Float, Float)) (gs !! 3) + sig = head $ randomRs ((2.0, 8.0) :: (Float, Float)) (gs !! 3) htt = heightToTerrain -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map From 15d55e157701d5149f983dcbcab351d48c3faafa Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 15:58:07 +0200 Subject: [PATCH 15/25] compensating for stripe depth --- src/Map/Graphics.hs | 1 - src/Map/Map.hs | 27 +++++++++++++++------------ 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 7c9c93f..71df337 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -30,7 +30,6 @@ import Linear import Control.Arrow ((***)) import Map.Types -import Map.Creation type Height = Float diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 98c5912..657be5d 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -38,7 +38,7 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns -- | Calculates the height of any given point on the map. --- Does not add camera distance to ground to that. + -- Does not add camera distance to ground to that. -- -- This ueses barycentric coordinate stuff. Wanna read more? -- http://en.wikipedia.org/wiki/Barycentric_coordinate_system_%28mathematics%29 @@ -48,14 +48,14 @@ giveMapHeight :: PlayMap -> (Float, Float) -- ^ Coordinates on X/Z-axes -> Float -- ^ Terrain Height at that position giveMapHeight mp (x,z) - | outsideMap (x,z) = 0.0 - | (isInt z 6) && (isInt x 6) = hlu (round x, round z) - | (isInt z 6) = let dist_down = x - fromIntegral ((floor x) :: Int) - dist_up = fromIntegral ((ceiling x) :: Int) - x - in (1 - dist_down) * (hlu (floor x, round z)) + (1 - dist_up) * (hlu (ceiling x, round z)) - | (isInt x 6) = let dist_down = z - fromIntegral ((floor z) :: Int) - dist_up = fromIntegral ((ceiling z) :: Int) - z - in (1 - dist_down) * (hlu (round x, floor z)) + (1 - dist_up) * (hlu (round x, ceiling z)) + | outsideMap (x',z) = 0.0 + | (isInt z 6) && (isInt x' 6) = hlu (round x', round z) + | (isInt z 6) = let dist_down = x' - fromIntegral ((floor x') :: Int) + dist_up = fromIntegral ((ceiling x') :: Int) - x' + in (1 - dist_down) * (hlu (floor x', round z)) + (1 - dist_up) * (hlu (ceiling x', round z)) + | (isInt x' 6) = let dist_down = z - fromIntegral ((floor z) :: Int) + dist_up = fromIntegral ((ceiling z) :: Int) - z + in (1 - dist_down) * (hlu (round x', floor z)) + (1 - dist_up) * (hlu (round x', ceiling z)) | otherwise = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc] ar = area (fi a) (fi b) (fi c) λa = area (fi b) (fi c) (x, z) / ar @@ -64,6 +64,9 @@ giveMapHeight mp (x,z) in (λa * hlu a) + (λb * hlu b) + (λc * hlu c) where + -- compensating + x' = x * ((sqrt 3) / 2) + --Returns if q is an int to n decimal places isInt :: RealFrac b => b -> Int -> Bool isInt q n = (round $ 10^((fromIntegral n) :: Integer) * (q - (fromIntegral ((round q):: Integer)))) == (0 :: Integer) @@ -94,9 +97,9 @@ giveMapHeight mp (x,z) getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd))) dist :: (Float, Float) -> (Int, Int) -> Float - dist (x1,z1) (x2,z2) = let x' = x1 - fromIntegral x2 - z' = z1 - fromIntegral z2 - in sqrt $ x'*x' + z'*z' + dist (x1,z1) (x2,z2) = let xf = x1 - fromIntegral x2 + zf = z1 - fromIntegral z2 + in sqrt $ xf*xf + zf*zf -- Heron's Formula: http://en.wikipedia.org/wiki/Heron%27s_formula area :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float From 5b2537188f213e157eba208ea44539ea437f66ee Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 17:26:40 +0200 Subject: [PATCH 16/25] (\_/) =(^.^)= (")_(") bunny approves this commit! (rewrote the whole damn camera-height-function. Should be better now.) --- src/Map/Creation.hs | 4 +-- src/Map/Graphics.hs | 2 +- src/Map/Map.hs | 84 ++++++++++++++------------------------------- src/Map/Types.hs | 6 ++-- src/Render/Types.hs | 7 ++-- 5 files changed, 34 insertions(+), 69 deletions(-) diff --git a/src/Map/Creation.hs b/src/Map/Creation.hs index 205c99b..38a49a6 100644 --- a/src/Map/Creation.hs +++ b/src/Map/Creation.hs @@ -76,8 +76,8 @@ gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp where gs = map mkStdGen (map (*seed) [1..]) c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1)))) - amp = head $ randomRs ((2.0, 5.0) :: (Float, Float)) (gs !! 2) - sig = head $ randomRs ((2.0, 8.0) :: (Float, Float)) (gs !! 3) + amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2) + sig = head $ randomRs ((2.0, 8.0) :: (Double, Double)) (gs !! 3) htt = heightToTerrain -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map diff --git a/src/Map/Graphics.hs b/src/Map/Graphics.hs index 71df337..6de0cab 100644 --- a/src/Map/Graphics.hs +++ b/src/Map/Graphics.hs @@ -31,7 +31,7 @@ import Control.Arrow ((***)) import Map.Types -type Height = Float +type Height = Double type MapEntry = ( Height, diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 657be5d..5730778 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -2,9 +2,8 @@ module Map.Map where import Map.Types -import Data.Function (on) import Data.Array (bounds, (!)) -import Data.List (sort, sortBy, group) +import Data.List (sort, group) -- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet. unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates @@ -38,76 +37,43 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns -- | Calculates the height of any given point on the map. - -- Does not add camera distance to ground to that. --- --- This ueses barycentric coordinate stuff. Wanna read more? --- http://en.wikipedia.org/wiki/Barycentric_coordinate_system_%28mathematics%29 --- http://www.alecjacobson.com/weblog/?p=1596 --- +-- Does not add camera distance to ground to that. giveMapHeight :: PlayMap - -> (Float, Float) -- ^ Coordinates on X/Z-axes - -> Float -- ^ Terrain Height at that position -giveMapHeight mp (x,z) - | outsideMap (x',z) = 0.0 - | (isInt z 6) && (isInt x' 6) = hlu (round x', round z) - | (isInt z 6) = let dist_down = x' - fromIntegral ((floor x') :: Int) - dist_up = fromIntegral ((ceiling x') :: Int) - x' - in (1 - dist_down) * (hlu (floor x', round z)) + (1 - dist_up) * (hlu (ceiling x', round z)) - | (isInt x' 6) = let dist_down = z - fromIntegral ((floor z) :: Int) - dist_up = fromIntegral ((ceiling z) :: Int) - z - in (1 - dist_down) * (hlu (round x', floor z)) + (1 - dist_up) * (hlu (round x', ceiling z)) - | otherwise = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc] - ar = area (fi a) (fi b) (fi c) - λa = area (fi b) (fi c) (x, z) / ar - λb = area (fi a) (fi c) (x, z) / ar - λc = area (fi a) (fi b) (x, z) / ar - in (λa * hlu a) + (λb * hlu b) + (λc * hlu c) + -> (Double, Double) + -> Double +giveMapHeight mop (x,z) + | outsideMap (x,z) = 0.0 + | otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups where - - -- compensating - x' = x * ((sqrt 3) / 2) - - --Returns if q is an int to n decimal places - isInt :: RealFrac b => b -> Int -> Bool - isInt q n = (round $ 10^((fromIntegral n) :: Integer) * (q - (fromIntegral ((round q):: Integer)))) == (0 :: Integer) - - outsideMap :: (Float, Float) -> Bool - outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mp + outsideMap :: (Double, Double) -> Bool + outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop fr = fromIntegral in mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d) - fi :: (Int, Int) -> (Float, Float) - fi (m, n) = (fromIntegral m, fromIntegral n) - - -- Height LookUp - hlu :: (Int, Int) -> Float - hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mp ! (k,j) in y + -- Height LookUp on PlayMap + hlu :: (Int, Int) -> Double + hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y + -- reference Points ff = (floor x, floor z) :: (Int, Int) fc = (floor x, ceiling z) :: (Int, Int) cf = (ceiling x, floor z) :: (Int, Int) cc = (ceiling x, ceiling z) :: (Int, Int) - tff = (ff, dist (x,z) ff) - tfc = (fc, dist (x,z) fc) - tcf = (cf, dist (x,z) cf) - tcc = (cc, dist (x,z) cc) + -- tupels with reference point and distance + tups = map (\t -> (t, dist (x,z) t)) [ff,fc,cf,cc] - getTrianglePoints :: [((Int,Int), Float)] -> [(Int,Int)] - getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd))) + -- total distance of all for reference point from the point in question + totald = sum $ map (\(_,d) -> d) tups - dist :: (Float, Float) -> (Int, Int) -> Float - dist (x1,z1) (x2,z2) = let xf = x1 - fromIntegral x2 - zf = z1 - fromIntegral z2 - in sqrt $ xf*xf + zf*zf - - -- Heron's Formula: http://en.wikipedia.org/wiki/Heron%27s_formula - area :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float - area (x1,z1) (x2,z2) (x3,z3) = let a = sqrt $ (x1-x2)*(x1-x2) + (z1-z2)*(z1-z2) - b = sqrt $ (x2-x3)*(x2-x3) + (z2-z3)*(z2-z3) - c = sqrt $ (x1-x3)*(x1-x3) + (z1-z3)*(z1-z3) - s = (a+b+c)/2 - in sqrt $ s * (s-a) * (s-b) * (s-c) + -- Real distance on PlayMap + dist :: (Double, Double) -> (Int, Int) -> Double + dist (x1,z1) pmp = let xf = x1 - realx + zf = z1 - realz + in sqrt $ xf*xf + zf*zf + where + realx = (\(Node _ (nx,_,_) _ _ _ _ _ _) -> nx) (mop ! pmp) + realz = (\(Node _ (_,nz,_) _ _ _ _ _ _) -> nz) (mop ! pmp) -- removing duplicates in O(n log n), losing order and adding Ord requirement remdups :: Ord a => [a] -> [a] diff --git a/src/Map/Types.hs b/src/Map/Types.hs index cd3f246..2ca5d61 100644 --- a/src/Map/Types.hs +++ b/src/Map/Types.hs @@ -7,9 +7,9 @@ type PlayMap = Array (Xindex, Zindex) Node type Xindex = Int type Zindex = Int -type XCoord = Float -type ZCoord = Float -type YCoord = Float +type XCoord = Double +type ZCoord = Double +type YCoord = Double data MapType = GrassIslandMap | DesertMap diff --git a/src/Render/Types.hs b/src/Render/Types.hs index 0b60da1..8e7bf49 100644 --- a/src/Render/Types.hs +++ b/src/Render/Types.hs @@ -29,7 +29,7 @@ data Camera = Flat Position Height -- | create a Flatcam-Camera starting at given x/z-Coordinates createFlatCam :: Double -> Double -> PlayMap -> Camera -createFlatCam x z map' = Flat (x,z) (float2Double $ giveMapHeight map' (double2Float x,double2Float z)) +createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z)) -- | create a Flatcam-Camera starting at given pitch/azimuth/radius createSphereCam :: Double -> Double -> Double -> Camera @@ -76,11 +76,10 @@ instance GLCamera Camera where xa = realToFrac xa' ya = realToFrac ya' moveBy (Sphere (inc, az) r) f map = undefined - moveBy (Flat (x', z') y) f map = Flat (x,z) (float2Double y) + moveBy (Flat (x', z') y) f map = Flat (x,z) y where (x,z) = f (x', z') - y = giveMapHeight map (fc x,fc z) - fc = double2Float + y = giveMapHeight map (x,z) move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map sphereToCart :: (Floating a) => a -> a -> a -> V3 a From a71ce917ecb33f241c505403b79b0a9fb841368b Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 17:43:31 +0200 Subject: [PATCH 17/25] fixed floor/ceiling crap --- src/Map/Map.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 5730778..36269dc 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -55,10 +55,10 @@ giveMapHeight mop (x,z) hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y -- reference Points - ff = (floor x, floor z) :: (Int, Int) - fc = (floor x, ceiling z) :: (Int, Int) - cf = (ceiling x, floor z) :: (Int, Int) - cc = (ceiling x, ceiling z) :: (Int, Int) + ff = ((floor x)-1, (floor z)-1) :: (Int, Int) + fc = ((floor x)-1, (floor z)+2) :: (Int, Int) + cf = ((floor x)+2, (floor z)-1) :: (Int, Int) + cc = ((floor x)+2, (floor z)+2) :: (Int, Int) -- tupels with reference point and distance tups = map (\t -> (t, dist (x,z) t)) [ff,fc,cf,cc] From cd4250336b3bd0c02e52b83c9c8269a6c0765565 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 17:56:03 +0200 Subject: [PATCH 18/25] moar reference points --- src/Map/Map.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 36269dc..85890b2 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -55,13 +55,13 @@ giveMapHeight mop (x,z) hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y -- reference Points - ff = ((floor x)-1, (floor z)-1) :: (Int, Int) - fc = ((floor x)-1, (floor z)+2) :: (Int, Int) - cf = ((floor x)+2, (floor z)-1) :: (Int, Int) - cc = ((floor x)+2, (floor z)+2) :: (Int, Int) + refs :: [(Int, Int)] + refs = map (tadd (floor x, floor z)) [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)] + where + tadd (a,b) (c,d) = (a+b,c+d) -- tupels with reference point and distance - tups = map (\t -> (t, dist (x,z) t)) [ff,fc,cf,cc] + tups = map (\t -> (t, dist (x,z) t)) refs -- total distance of all for reference point from the point in question totald = sum $ map (\(_,d) -> d) tups From c624121e236c161046cb3940b95e839d6f4fb420 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 18:48:46 +0200 Subject: [PATCH 19/25] Clamped reference points --- src/Map/Map.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 85890b2..2880d87 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -49,15 +49,16 @@ giveMapHeight mop (x,z) outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop fr = fromIntegral in mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d) - + -- Height LookUp on PlayMap hlu :: (Int, Int) -> Double hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y -- reference Points refs :: [(Int, Int)] - refs = map (tadd (floor x, floor z)) [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)] + refs = remdups $ map clmp $ map (tadd (floor x, floor z)) mods where + mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)] tadd (a,b) (c,d) = (a+b,c+d) -- tupels with reference point and distance @@ -66,6 +67,15 @@ giveMapHeight mop (x,z) -- total distance of all for reference point from the point in question totald = sum $ map (\(_,d) -> d) tups + -- clamp, as she is programmed + clamp :: (Ord a) => a -> a -> a -> a + clamp mn mx = max mn . min mx + + -- clamp for tupels + clmp :: (Int, Int) -> (Int, Int) + clmp (a,b) = let ((xmin,zmin),(xmax,zmax)) = bounds mop + in ((clamp (xmin+2) (xmax-2) a),(clamp (zmin+2) (zmax-2) b)) + -- Real distance on PlayMap dist :: (Double, Double) -> (Int, Int) -> Double dist (x1,z1) pmp = let xf = x1 - realx From ffa45515c3a95981457361d8527cb9cc465451c3 Mon Sep 17 00:00:00 2001 From: Jonas Betzendahl Date: Fri, 16 May 2014 18:59:26 +0200 Subject: [PATCH 20/25] attempting to compensate once more --- src/Map/Map.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 2880d87..2a3cb26 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -42,9 +42,11 @@ giveMapHeight :: PlayMap -> (Double, Double) -> Double giveMapHeight mop (x,z) - | outsideMap (x,z) = 0.0 - | otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups + | outsideMap (x,z') = 0.0 + | otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups where + z' = z * ((sqrt 3)/2) + outsideMap :: (Double, Double) -> Bool outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop fr = fromIntegral @@ -56,13 +58,13 @@ giveMapHeight mop (x,z) -- reference Points refs :: [(Int, Int)] - refs = remdups $ map clmp $ map (tadd (floor x, floor z)) mods + refs = remdups $ map clmp $ map (tadd (floor x, floor z')) mods where mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)] tadd (a,b) (c,d) = (a+b,c+d) -- tupels with reference point and distance - tups = map (\t -> (t, dist (x,z) t)) refs + tups = map (\t -> (t, dist (x,z') t)) refs -- total distance of all for reference point from the point in question totald = sum $ map (\(_,d) -> d) tups From 2944d367037324db2a994293b4f5112a12dda089 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 16 May 2014 19:06:05 +0200 Subject: [PATCH 21/25] changed camera-height --- src/Render/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Render/Types.hs b/src/Render/Types.hs index 8e7bf49..5191322 100644 --- a/src/Render/Types.hs +++ b/src/Render/Types.hs @@ -40,7 +40,7 @@ instance GLCamera Camera where getCam (Flat (x',z') y') dist' xa' ya' = lookAt (cpos ^+^ at') at' up where - at' = V3 x y z + at' = V3 x (y+2) z cpos = crot !* (V3 0 0 (-dist)) crot = ( (fromQuaternion $ axisAngle upmap (xa::CFloat)) From 27d78735956d0558000d475f72a3de1caed47478 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 16 May 2014 22:05:27 +0200 Subject: [PATCH 22/25] reworked Types to support STM - deadlocks somewhere... --- src/Main.hs | 67 ++++++++++++++++++++++++++------------------ src/Render/Render.hs | 13 +++++---- src/Types.hs | 6 ++-- src/UI/Callbacks.hs | 19 +++++++++---- 4 files changed, 64 insertions(+), 41 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0a7e867..e5f9328 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,8 +12,8 @@ import Control.Arrow ((***)) -- data consistency/conversion import Control.Concurrent (threadDelay) -import Control.Concurrent.STM (TQueue, - newTQueueIO) +import Control.Concurrent.STM (TQueue, newTQueueIO, atomically) +import Control.Concurrent.STM.TMVar (newTMVarIO, takeTMVar, putTMVar, readTMVar) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Data.Functor ((<$>)) @@ -94,16 +94,26 @@ main = --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10 --TTF.setFontStyle font TTFNormal --TTF.setFontHinting font TTFHNormal - - glHud' <- initHud - let zDistClosest' = 2 - zDistFarthest' = zDistClosest' + 10 - --TODO: Move near/far/fov to state for runtime-changability & central storage + let fov = 90 --field of view near = 1 --near plane far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio + cam' <- newTMVarIO CameraState + { _xAngle = pi/6 + , _yAngle = pi/2 + , _zDist = 10 + , _frustum = frust + , _camObject = createFlatCam 25 25 curMap + } + game' <- newTMVarIO GameState + { _currentMap = curMap + } + glHud' <- initHud + let zDistClosest' = 2 + zDistFarthest' = zDistClosest' + 10 + --TODO: Move near/far/fov to state for runtime-changability & central storage (guiMap, guiRoots) = createGUI aks = ArrowKeyState { _up = False @@ -123,17 +133,11 @@ main = , _height = fbHeight , _shouldClose = False } - , _camera = CameraState - { _xAngle = pi/6 - , _yAngle = pi/2 - , _zDist = 10 - , _frustum = frust - , _camObject = createFlatCam 25 25 curMap - } , _io = IOState { _clock = now , _tessClockFactor = 0 } + , _camera = cam' , _mouse = MouseState { _isDown = False , _isDragging = False @@ -155,9 +159,7 @@ main = , _glRenderbuffer = renderBuffer , _glFramebuffer = frameBuffer } - , _game = GameState - { _currentMap = curMap - } + , _game = game' , _ui = UIState { _uiHasChanged = True , _uiMap = guiMap @@ -207,20 +209,26 @@ run = do | otherwise = newYAngle' newYAngle' = sodya + myrot/100 - modify $ ((camera.xAngle) .~ newXAngle) - . ((camera.yAngle) .~ newYAngle) + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam + putTMVar (state ^. camera) cam' -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement - let - multc = cos $ state ^. camera.yAngle - mults = sin $ state ^. camera.yAngle - modx x' = x' - 0.2 * kxrot * multc - - 0.2 * kyrot * mults - mody y' = y' + 0.2 * kxrot * mults - - 0.2 * kyrot * multc - modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (state ^. game.currentMap)) + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + game' <- readTMVar (state ^. game) + let + multc = cos $ cam ^. yAngle + mults = sin $ cam ^. yAngle + modx x' = x' - 0.2 * kxrot * multc + - 0.2 * kyrot * mults + mody y' = y' + 0.2 * kxrot * mults + - 0.2 * kyrot * multc + cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam + putTMVar (state ^. camera) cam' {- --modify the state with all that happened in mt time. @@ -290,7 +298,10 @@ adjustWindow = do ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) - modify $ camera.frustum .~ frust + liftIO $ atomically $ do + cam <- readTMVar (state ^. camera) + cam' <- return $ frustum .~ frust $ cam + putTMVar (state ^. camera) cam' rb <- liftIO $ do -- bind ints to CInt for lateron. let fbCWidth = (fromInteger.toInteger) fbWidth diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 7863ceb..ee91b27 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -12,6 +12,8 @@ import qualified Linear as L import Control.Lens ((^.)) import Control.Monad.RWS.Strict (liftIO) import qualified Control.Monad.RWS.Strict as RWS (get) +import Control.Concurrent.STM.TMVar (readTMVar) +import Control.Concurrent.STM (atomically) import Data.Distributive (distribute, collect) -- FFI import Foreign (Ptr, castPtr, with) @@ -364,11 +366,12 @@ drawMap = do render :: Pioneers () render = do state <- RWS.get - let xa = state ^. camera.xAngle - ya = state ^. camera.yAngle - frust = state ^. camera.Types.frustum - camPos = state ^. camera.camObject - zDist' = state ^. camera.zDist + cam <- liftIO $ atomically $ readTMVar (state ^. camera) + let xa = cam ^. xAngle + ya = cam ^. yAngle + frust = cam ^. Types.frustum + camPos = cam ^. camObject + zDist' = cam ^. zDist d = state ^. gl.glMap.mapShaderData (UniformLocation proj) = shdrProjMatIndex d (UniformLocation nmat) = shdrNormalMatIndex d diff --git a/src/Types.hs b/src/Types.hs index 75932ea..c722d11 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Types where -import Control.Concurrent.STM (TQueue) +import Control.Concurrent.STM (TQueue, TMVar) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -161,12 +161,12 @@ data UIState = UIState data State = State { _window :: !WindowState - , _camera :: !CameraState + , _camera :: TMVar CameraState , _io :: !IOState , _mouse :: !MouseState , _keyboard :: !KeyboardState , _gl :: !GLState - , _game :: !GameState + , _game :: TMVar GameState , _ui :: !UIState } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 31d5a73..9ce6cc5 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -13,6 +13,8 @@ import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL +import Control.Concurrent.STM.TMVar (readTMVar, takeTMVar, putTMVar) +import Control.Concurrent.STM (atomically) import Render.Misc (curb,genColorData) @@ -105,11 +107,13 @@ eventCallback e = do state <- get if state ^. mouse.isDown && not (state ^. mouse.isDragging) then + do + cam <- liftIO $ atomically $ readTMVar (state ^. camera) modify $ (mouse.isDragging .~ True) . (mouse.dragStartX .~ fromIntegral x) . (mouse.dragStartY .~ fromIntegral y) - . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) - . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) + . (mouse.dragStartXAngle .~ (cam ^. xAngle)) + . (mouse.dragStartYAngle .~ (cam ^. yAngle)) else mouseMoveHandler (x, y) modify $ (mouse.mousePosition. Types._x .~ fromIntegral x) . (mouse.mousePosition. Types._y .~ fromIntegral y) @@ -134,8 +138,13 @@ eventCallback e = do SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll do state <- get - let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in - modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + let zDist' = (cam ^. zDist) + realToFrac (negate vscroll) + zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' + cam' <- return $ zDist .~ zDist'' $ cam + putTMVar (state ^. camera) cam' + -- there is more (joystic, touchInterface, ...), but currently ignored SDL.Quit -> modify $ window.shouldClose .~ True _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] @@ -340,4 +349,4 @@ copyGUI tex (vX, vY) widget = do mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. ---TODO: Maybe queues are better? \ No newline at end of file +--TODO: Maybe queues are better? From 0d65a485d563d1d3b9635317f9a8f09d414b0129 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 17 May 2014 11:40:23 +0200 Subject: [PATCH 23/25] changed constant in Map.Map --- src/Map/Map.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 2a3cb26..b92e926 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -41,11 +41,11 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in giveMapHeight :: PlayMap -> (Double, Double) -> Double -giveMapHeight mop (x,z) +giveMapHeight mop (x, z) | outsideMap (x,z') = 0.0 | otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups where - z' = z * ((sqrt 3)/2) + z' = z * 2/(sqrt 3) outsideMap :: (Double, Double) -> Bool outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop From 230e31bf635690103e19222b4a25cdce04b1d27b Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 17 May 2014 12:57:49 +0200 Subject: [PATCH 24/25] changed TMVar to TVar - compiles & runs again --- src/Main.hs | 20 ++++++++++---------- src/Render/Render.hs | 4 ++-- src/Types.hs | 6 +++--- src/UI/Callbacks.hs | 8 ++++---- 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index e5f9328..f4d401c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -13,7 +13,7 @@ import Control.Arrow ((***)) -- data consistency/conversion import Control.Concurrent (threadDelay) import Control.Concurrent.STM (TQueue, newTQueueIO, atomically) -import Control.Concurrent.STM.TMVar (newTMVarIO, takeTMVar, putTMVar, readTMVar) +import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Data.Functor ((<$>)) @@ -100,14 +100,14 @@ main = far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio - cam' <- newTMVarIO CameraState + cam' <- newTVarIO CameraState { _xAngle = pi/6 , _yAngle = pi/2 , _zDist = 10 , _frustum = frust , _camObject = createFlatCam 25 25 curMap } - game' <- newTMVarIO GameState + game' <- newTVarIO GameState { _currentMap = curMap } glHud' <- initHud @@ -210,16 +210,16 @@ run = do newYAngle' = sodya + myrot/100 liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) + cam <- readTVar (state ^. camera) cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) - game' <- readTMVar (state ^. game) + cam <- readTVar (state ^. camera) + game' <- readTVar (state ^. game) let multc = cos $ cam ^. yAngle mults = sin $ cam ^. yAngle @@ -228,7 +228,7 @@ run = do mody y' = y' + 0.2 * kxrot * mults - 0.2 * kyrot * multc cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' {- --modify the state with all that happened in mt time. @@ -299,9 +299,9 @@ adjustWindow = do frust = createFrustum fov near far ratio liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) liftIO $ atomically $ do - cam <- readTMVar (state ^. camera) + cam <- readTVar (state ^. camera) cam' <- return $ frustum .~ frust $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' rb <- liftIO $ do -- bind ints to CInt for lateron. let fbCWidth = (fromInteger.toInteger) fbWidth diff --git a/src/Render/Render.hs b/src/Render/Render.hs index ee91b27..59fe4ed 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -12,7 +12,7 @@ import qualified Linear as L import Control.Lens ((^.)) import Control.Monad.RWS.Strict (liftIO) import qualified Control.Monad.RWS.Strict as RWS (get) -import Control.Concurrent.STM.TMVar (readTMVar) +import Control.Concurrent.STM.TVar (readTVarIO) import Control.Concurrent.STM (atomically) import Data.Distributive (distribute, collect) -- FFI @@ -366,7 +366,7 @@ drawMap = do render :: Pioneers () render = do state <- RWS.get - cam <- liftIO $ atomically $ readTMVar (state ^. camera) + cam <- liftIO $ readTVarIO (state ^. camera) let xa = cam ^. xAngle ya = cam ^. yAngle frust = cam ^. Types.frustum diff --git a/src/Types.hs b/src/Types.hs index c722d11..cbdba50 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Types where -import Control.Concurrent.STM (TQueue, TMVar) +import Control.Concurrent.STM (TQueue, TVar) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -161,12 +161,12 @@ data UIState = UIState data State = State { _window :: !WindowState - , _camera :: TMVar CameraState + , _camera :: TVar CameraState , _io :: !IOState , _mouse :: !MouseState , _keyboard :: !KeyboardState , _gl :: !GLState - , _game :: TMVar GameState + , _game :: TVar GameState , _ui :: !UIState } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 9ce6cc5..6b5d7f3 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -13,7 +13,7 @@ import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL -import Control.Concurrent.STM.TMVar (readTMVar, takeTMVar, putTMVar) +import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar) import Control.Concurrent.STM (atomically) @@ -108,7 +108,7 @@ eventCallback e = do if state ^. mouse.isDown && not (state ^. mouse.isDragging) then do - cam <- liftIO $ atomically $ readTMVar (state ^. camera) + cam <- liftIO $ readTVarIO (state ^. camera) modify $ (mouse.isDragging .~ True) . (mouse.dragStartX .~ fromIntegral x) . (mouse.dragStartY .~ fromIntegral y) @@ -139,11 +139,11 @@ eventCallback e = do do state <- get liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) + cam <- readTVar (state ^. camera) let zDist' = (cam ^. zDist) + realToFrac (negate vscroll) zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' cam' <- return $ zDist .~ zDist'' $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' -- there is more (joystic, touchInterface, ...), but currently ignored SDL.Quit -> modify $ window.shouldClose .~ True From aa6a5c060fdad190acba114a6fea4b8dd544b7ec Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 17 May 2014 23:19:34 +0200 Subject: [PATCH 25/25] added some helper-functions for handling gamestate --- src/Types.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index cbdba50..7a27ed9 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Types where -import Control.Concurrent.STM (TQueue, TVar) +import Control.Concurrent.STM (TQueue, TVar, readTVar, writeTVar, atomically) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -9,7 +9,8 @@ import qualified Data.HashMap.Strict as Map import Data.Time (UTCTime) import Linear.Matrix (M44) import Linear (V3) -import Control.Monad.RWS.Strict (RWST) +import Control.Monad.RWS.Strict (RWST, liftIO, get) +import Control.Monad (when) import Control.Lens import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types @@ -188,3 +189,18 @@ $(makeLenses ''Position) $(makeLenses ''Env) $(makeLenses ''UIState) +-- helper-functions for types + +-- | atomically change gamestate on condition +changeIfGamestate :: (GameState -> Bool) -> (GameState -> GameState) -> Pioneers () +changeIfGamestate cond f = do + state <- get + liftIO $ atomically $ do + game' <- readTVar (state ^. game) + when (cond game') (writeTVar (state ^. game) (f game')) + + +-- | atomically change gamestate +changeGamestate :: (GameState -> GameState) -> Pioneers () +changeGamestate = changeIfGamestate (const True) +