From da86de6918d350c0f4ad204bca309278b13861c8 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 10 Mar 2021 18:45:59 +0100 Subject: [PATCH] Partial refactor of shader loading and drawing --- src/Picture/Data.hs | 12 +++++++- src/Picture/Preload.hs | 49 ++++++++++++++++++++++++++++++ src/Picture/Render.hs | 69 ++++++++++++++++++++++++++++++++++-------- 3 files changed, 116 insertions(+), 14 deletions(-) diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 0af1792a0..2a5fd023b 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -24,7 +24,7 @@ import Data.Traversable data RenderType = RenderPoly [(Point3,Point4)] | RenderText [(Point3,Point4,Point3)] - | RenderCirc (Point3,Point4,Float) +-- | RenderCirc (Point3,Point4,Float) | RenderArc (Point3,Point4,Point4) | RenderLine [(Point3,Point4)] | RenderEllipse [(Point3,Point4)] @@ -44,6 +44,16 @@ data FullShader = FullShader makeLenses ''VAO makeLenses ''FullShader + +drawShaders :: [FullShader] -> [Int] -> IO () +drawShaders fss is = + zipWithM_ f fss is + where f fs i = do + currentProgram $= Just (_shaderProgram fs) + bindVertexArrayObject $= (Just (_vao $ _shaderVAO fs)) + drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i) + + bindShaderBuffers :: [FullShader] -> [Int] -> IO () bindShaderBuffers fss is = zipWithM_ f fss is diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index fb6372718..755212802 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -29,6 +29,7 @@ data RenderData = RenderData , _lightmapCircleShader :: (Program, [UniformLocation]) , _backShader :: (Program, [UniformLocation]) , _wallShadowShader :: (Program, [UniformLocation]) + , _listShaders :: [FullShader] , _triVAO :: VAO , _lineVAO :: VAO , _textVAO :: VAO @@ -45,6 +46,43 @@ data RenderData = RenderData makeLenses ''RenderData +makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (RenderType -> [[[Float]]]) -> IO FullShader +makeShader s shaderlist alocs pm renStrat = do + (prog,unis) <- makeSourcedShader s shaderlist + vao <- setupVAO alocs + return $ FullShader { _shaderProgram = prog + , _shaderUniforms = unis + , _shaderVAO = vao + , _shaderPokeStrategy = renStrat + , _shaderDrawPrimitive = pm + } + +mkS :: IO FullShader +mkS = do + (prog,unis) <- makeSourcedShader "basic" [VertexShader,FragmentShader] + trivao <- setupVAO [(0,3),(1,4)] + return $ FullShader { _shaderProgram = prog + , _shaderUniforms = unis + , _shaderVAO = trivao + , _shaderPokeStrategy = pokeTriStrat + , _shaderDrawPrimitive = Triangles + } + +pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs +pokeTriStrat _ = [] + +pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> flat3 (flat3 a, flat4 b, flat3 c)) vs +pokeCharStrat _ = [] + +pokeArcStrat (RenderArc (a,b,c)) = [flat3 (flat3 a, flat4 b, flat4 c)] +pokeArcStrat _ = [] + +pokeLineStrat (RenderLine vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs +pokeLineStrat _ = [] + +pokeEllStrat (RenderEllipse vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs +pokeEllStrat _ = [] + floatSize = sizeOf (0.5 :: GLfloat) setupVAO :: [(GLuint,Int)] -> IO VAO @@ -92,6 +130,10 @@ loadTextures = do bufferOffset :: Integral a => a -> Ptr b bufferOffset = plusPtr nullPtr . fromIntegral +vert = VertexShader +geom = GeometryShader +frag = FragmentShader + preloadRender :: IO RenderData preloadRender = do -- compile shader programs @@ -106,6 +148,12 @@ preloadRender = do wssLightPosUniLoc <- GL.uniformLocation (fst wss) "lightPos" + bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat + lslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Lines pokeLineStrat + cslist <- makeShader "character" [vert,geom,frag] [(0,3),(1,4),(2,3)] Points pokeCharStrat + aslist <- makeShader "arc" [vert,geom,frag] [(0,3),(1,4),(2,3)] Points pokeArcStrat + eslist <- makeShader "ellipseInterpolate" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeEllStrat + --the following vbo is set up to contain one fixed vertex dummyvbo <- genObjectName dummyptr <- mallocArray numDrawableElements @@ -163,6 +211,7 @@ preloadRender = do , _circShader = cs , _ellipseShader = es , _arcShader = as + , _listShaders = [bslist,lslist,cslist,aslist,eslist] , _lightmapCircleShader = fcs , _backShader = bgs , _wallShadowShader = wss diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index b0a0d8dbb..767c233ac 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -64,7 +64,7 @@ overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs -overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c) +--overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c) overPos f (RenderArc (a,b,c)) = RenderArc (f a,b,c) overRot :: Float -> RenderType -> RenderType @@ -78,7 +78,7 @@ overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs overCol f (RenderEllipse vs) = RenderEllipse $ map (second $ f) vs overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs -overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c) +--overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c) overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c) overSca :: (Point2 -> Point2) -> RenderType -> RenderType @@ -284,13 +284,13 @@ pokeLineVert pa pb n (p,c) pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int {-# INLINE pokeCirc #-} -pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s)) - | n > 20000 * 2 = return n - | otherwise = do - pokeThreeOff pa n p - pokeFourOff pb n c - pokeElemOff pc n s - return (n+1) +--pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s)) +-- | n > 20000 * 2 = return n +-- | otherwise = do +-- pokeThreeOff pa n p +-- pokeFourOff pb n c +-- pokeElemOff pc n s +-- return (n+1) pokeCirc _ n _ = return n pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int @@ -333,7 +333,6 @@ rotate3 :: Float -> Point3 -> Point3 rotate3 a (x,y,z) = (x',y',z) where (x',y') = rotateV a (x,y) - twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float) {-# INLINE twoPtrsVAO #-} twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of @@ -343,7 +342,36 @@ threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float) threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of (a:b:c:_) -> (a,b,c) +setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [FullShader] -> IO () +setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do + let scalMat = Linear.Matrix.transpose $ + V4 (V4 (2*zoom/winx) 0 0 (0::GLfloat)) + (V4 0 (2*zoom/winy) 0 0) + (V4 0 0 1 0) + (V4 0 0 0 1) + let rotMat = Linear.Matrix.transpose $ + V4 (V4 (cos rot) (sin (-rot)) 0 0) + (V4 (sin rot) (cos rot) 0 0) + (V4 0 0 1 0) + (V4 0 0 0 1) + let tranMat = Linear.Matrix.transpose $ + V4 (V4 1 0 0 0) + (V4 0 1 0 0) + (V4 0 0 1 0) + (V4 (-tranx) (-trany) 0 1) + let wmat = scalMat !*! rotMat !*! tranMat + vToL (V4 a b c d) = [a,b,c,d] + wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat) +-- set common uniforms + forM_ fss $ \shad -> do + currentProgram $= Just (_shaderProgram shad) + uniform (_shaderUniforms shad !! 0) $= Vector2 winx winy + uniform (_shaderUniforms shad !! 1) $= zoom + uniform (_shaderUniforms shad !! 2) $= rot + uniform (_shaderUniforms shad !! 3) $= Vector2 tranx trany + uniform (_shaderUniforms shad !! 4) $= wmata + renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32) renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do @@ -427,15 +455,15 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) clear [DepthBuffer] -- draw layer 0 - ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic + ticks2 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic --((picToAlt 0 pic) :: [RenderType]) -- reset blend so that light map doesn't apply blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic + ticks3 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic -- set drawing for on top aticks <- SDL.ticks blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) - ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic + ticks4 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic bticks <- SDL.ticks -- reset uniforms (hacky for now) idmat <- (newMatrix RowMajor [1,0,0,0 @@ -466,6 +494,21 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p bufferOffset :: Integral a => a -> Ptr b bufferOffset = plusPtr nullPtr . fromIntegral +renderTree' :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) + -> f RenderType -> IO Word32 +renderTree' pdata rot zoom (tranx,trany) (winx,winy) tree = do + pokeStartTicks <- SDL.ticks + + let slist = _listShaders pdata + setShaderUniforms rot zoom (tranx,trany) (winx,winy) slist + + is <- F.foldM (pokeShaders slist) tree + + bindShaderBuffers slist is + drawShaders slist is + + pokeEndTicks <- SDL.ticks + return $ pokeEndTicks - pokeStartTicks -- the following code draws a picture tree -- it does not set nor change the blend function or depth buffer