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:
justin
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/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