diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index ff1d6d0a8..eafa9c96e 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -136,7 +136,7 @@ renderBlankWalls -> GLmatrix GLfloat -> IO () renderBlankWalls pdata wps pmat = do - n <- F.foldM (pokeShader $ _wallBlankShader pdata) (map Render22x4 wps) + n <- F.foldM (pokeShader' $ _wallBlankShader pdata) (map Render22x4 wps) bindShaderBuffers [_wallBlankShader pdata] [n] currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata) uniform (_shaderMatrixUniform $ _wallBlankShader pdata) $= pmat @@ -150,7 +150,7 @@ renderTextureWalls -> GLmatrix GLfloat -> IO () renderTextureWalls pdata wps pmat = do - n <- F.foldM (pokeShader $ _wallTextureShader pdata) (map Render22x4 wps) + n <- F.foldM (pokeShader' $ _wallTextureShader pdata) (map Render22x4 wps) bindShaderBuffers [_wallTextureShader pdata] [n] currentProgram $= Just (_shaderProgram $ _wallTextureShader pdata) uniform (_shaderMatrixUniform $ _wallTextureShader pdata) $= pmat diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index b04adf6ac..d26926bba 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -38,8 +38,8 @@ makeLenses ''RenderData preloadRender :: IO RenderData preloadRender = do -- lighting shaders - lightningFloorShad <- makeShader "lighting/floor" [vert,geom,frag] [4] Points - (return . return . flat4 . _unRender1111) + lightingFloorShad <- makeShader "lighting/floor" [vert,geom,frag] [4] Points + pokeLightingFloorStrat wsShad <- makeShader "lighting/occlude" [vert,geom,frag] [4] Points pokeWPStrat >>= addUniforms ["lightPos"] wlLightShad @@ -62,21 +62,21 @@ preloadRender = do ,[[-1,-1],[0,0]] ,[[ 1,-1],[1,0]] ] - _ <- F.foldM (pokeShader fsShad) [RenderConst] -- fix fullscreen vertex positions now + _ <- F.foldM (pokeShader' fsShad) [RenderConst] -- fix fullscreen vertex positions now boxBlurShad <- makeShader "texture/boxBlur" [vert,frag] [2,2] TriangleStrip $ const [[[-1, 1],[0,1]] ,[[ 1, 1],[1,1]] ,[[-1,-1],[0,0]] ,[[ 1,-1],[1,0]] ] - _ <- F.foldM (pokeShader boxBlurShad) [RenderConst] -- fix fullscreen vertex positions now + _ <- F.foldM (pokeShader' boxBlurShad) [RenderConst] -- fix fullscreen vertex positions now grayscaleShad <- makeShader "texture/grayscale" [vert,frag] [2,2] TriangleStrip $ const [[[-1, 1],[0,1]] ,[[ 1, 1],[1,1]] ,[[-1,-1],[0,0]] ,[[ 1,-1],[1,0]] ] - _ <- F.foldM (pokeShader grayscaleShad) [RenderConst] -- fix fullscreen vertex positions now + _ <- F.foldM (pokeShader' grayscaleShad) [RenderConst] -- fix fullscreen vertex positions now -- background shader bgShad <- makeShader "background" [vert,geom,frag] [4,2] Points pokeBGStrat >>= addTexture "data/texture/marbleSlabs.png" @@ -99,7 +99,7 @@ preloadRender = do bindFramebuffer Framebuffer $= defaultFramebufferObject return $ RenderData { _pictureShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader] - , _lightingFloorShader = lightningFloorShad + , _lightingFloorShader = lightingFloorShad , _lightingOccludeShader = wsShad , _lightingWallShader = wlLightShad , _wallBlankShader = wlBlank @@ -193,6 +193,10 @@ pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeLineStrat,pokeEllStrat :: RenderType pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> [flat3 p,flat4 co]) vs pokeTriStrat _ = [] +pokeLightingFloorStrat :: RenderType -> [[[Float]]] +pokeLightingFloorStrat Render1111{_unRender1111=x} = [[flat4 x]] +pokeLightingFloorStrat _ = undefined + pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> [flat3 a, flat4 b, flat3 c]) vs pokeCharStrat _ = [] diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 989cb097f..ca5c1f342 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -34,7 +34,7 @@ setWallDepth setWallDepth pdata wallPoints (viewFromx,viewFromy) _ = do startTicks <- SDL.ticks colorMask $= Color4 Disabled Disabled Disabled Disabled - nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints) + nWalls <- F.foldM (pokeShader' $ _lightingOccludeShader pdata) (map Render22 wallPoints) bindShaderBuffers [_lightingOccludeShader pdata] [nWalls] currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata) @@ -76,9 +76,9 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _ bindFramebuffer Framebuffer $= _spareFBO pdata -- store wall and light positions into buffer - nWallLights <- F.foldM (pokeShader $ _lightingWallShader pdata) (map Render22 wallPoints) + nWallLights <- F.foldM (pokeShader' $ _lightingWallShader pdata) (map Render22 wallPoints) bindShaderBuffers [_lightingWallShader pdata] [nWallLights] - nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints) + nWalls <- F.foldM (pokeShader' $ _lightingOccludeShader pdata) (map Render22 wallPoints) bindShaderBuffers [_lightingOccludeShader pdata] [nWalls] -- set uniforms for shader that draws lights currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata) @@ -114,8 +114,7 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _ stencilTest $= Enabled forM_ lightPoints $ \(x,y,r,lum) -> do -- bind buffer for floor light circle - let lightPtr = (\(_,ptr,_) -> ptr) $ head - $ _vaoBufferTargets $ _shaderVAO $ _lightingFloorShader pdata + let lightPtr = _vboPointer $ _vaoVBO $ _shaderVAO $ _lightingFloorShader pdata pokeFourOff lightPtr 0 (x,y,r,lum) -- stencil out walls colorMask $= Color4 Disabled Disabled Disabled Disabled @@ -200,7 +199,8 @@ renderBackground pdata rot camZoom (tranx,trany) (winx,winy) = do -- set drawing for on top --blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) -- draw background - bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata + --bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata + bindArrayBuffers' 1 $ _vaoVBO $ _shaderVAO $ _backgroundShader pdata currentProgram $= Just (_shaderProgram $ _backgroundShader pdata) bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata) let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata @@ -248,7 +248,7 @@ renderShader -> IO Word32 renderShader shad dat = do sticks <- SDL.ticks - i <- F.foldM (pokeShader shad) dat + i <- F.foldM (pokeShader' shad) dat bindShaderBuffers [shad] [i] drawShader shad i eticks <- SDL.ticks diff --git a/src/Shader.hs b/src/Shader.hs index 0c3df3e2f..b32f0d19e 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -3,8 +3,10 @@ module Shader , addTexture , addUniforms , pokeShaders - , pokeShader - , bindArrayBuffers + --, pokeShader + , pokeShader' + --, bindArrayBuffers + , bindArrayBuffers' , bindShaderBuffers , makeSourcedShader , setupVAO @@ -41,7 +43,8 @@ extractProgAndUnis :: FullShader -> (Program,UniformLocation) extractProgAndUnis s = (_shaderProgram s, _shaderMatrixUniform s) pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int] -pokeShaders = traverse pokeShader +pokeShaders = traverse pokeShader' +--pokeShaders = traverse pokeShader pokeShader :: FullShader -> F.FoldM IO RenderType Int pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return @@ -49,13 +52,39 @@ pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return (_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ _shaderVAO fs fls = _shaderPokeStrategy fs +pokeShader' :: FullShader -> F.FoldM IO RenderType Int +pokeShader' fs = F.FoldM (pokeRender' fls ptr stride) (return 0) return + where + theVBO = _vaoVBO $ _shaderVAO fs + ptr = _vboPointer theVBO + stride = sum $ _vboAttribSizes theVBO + fls = _shaderPokeStrategy fs + pokeRender :: (RenderType -> [[[Float]]]) -> [(Ptr Float,Int)] -> Int -> RenderType -> IO Int pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt) +pokeRender' + :: (RenderType + -> [[[Float]]]) + -> Ptr Float + -> Int -- ^ stride + -> Int + -> RenderType + -> IO Int +pokeRender' toFs ptr stride n rt = pokeList' ptr stride n (toFs rt) + pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int pokeList ptrs = foldM (pokePtrs ptrs) +pokeList' :: Ptr Float -> Int -> Int -> [[[Float]]] -> IO Int +pokeList' ptr stride = foldM (pokePtrs' ptr stride) + +pokePtrs' :: Ptr Float -> Int -> Int -> [[Float]] -> IO Int +pokePtrs' ptr stride n fss = do + pokeArrayOff ptr (stride * n) (concat fss) + return $ n + 1 + pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int pokePtrs ptrIs n fss = do zipWithM_ f ptrIs fss @@ -73,10 +102,18 @@ bindArrayBuffers numVs ps = do bindBuffer ArrayBuffer $= Just bo bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, DynamicDraw) +bindArrayBuffers' :: Int -> VBO -> IO () +bindArrayBuffers' numVs theVBO = do + bindBuffer ArrayBuffer $= Just (_vbo theVBO) + bufferData ArrayBuffer $= + (fromIntegral $ floatSize * numVs * (sum $ _vboAttribSizes theVBO), _vboPointer theVBO, DynamicDraw) + + bindShaderBuffers :: [FullShader] -> [Int] -> IO () bindShaderBuffers = zipWithM_ f where - f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs + --f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs + f fs i = bindArrayBuffers' i $ _vaoVBO $ _shaderVAO fs drawShaders :: [FullShader] -> [Int] -> IO () drawShaders = zipWithM_ drawShader @@ -137,7 +174,7 @@ floatSize = sizeOf (0.5 :: GLfloat) {-# INLINE floatSize #-} bufferOffset :: Integral a => a -> Ptr b -bufferOffset = plusPtr nullPtr . fromIntegral +bufferOffset = plusPtr nullPtr . (* floatSize) . fromIntegral numDrawableElements :: Int {-# INLINE numDrawableElements #-} @@ -147,9 +184,9 @@ setupVAO :: [Int] -> IO VAO setupVAO sizes = do theVAO <- genObjectName bindVertexArrayObject $= Just theVAO - theVBO <- setupVBO $ sizes vbos <- forM (zip (map fromIntegral [(0::Int)..]) sizes) setupArrayBuffer ptrs <- forM (zip vbos sizes) setupVBOPointers + theVBO <- setupVBO $ sizes return $ VAO { _vao = theVAO , _vaoBufferTargets = ptrs