justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Partial refactor of shader loading and drawing

Browse Source
This commit is contained in:
jgk
2021-03-10 18:45:59 +01:00
parent b4b77fe345
commit da86de6918
3 changed files with 116 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Picture/Data.hs
+11 -1
View File
@@ -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
src/Picture/Preload.hs
+49
View File
@@ -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
src/Picture/Render.hs
+56 -13
View File
@@ -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