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

Rendering optimisations (mainly inlining)

Browse Source
This commit is contained in:
jgk
2021-07-31 23:38:37 +02:00
parent d7649b951b
commit 54c912224b
7 changed files with 92 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Render.hs
+1 -2
View File
@@ -49,7 +49,6 @@ doDrawing pdata w = do
(wallPointsCol,windowPoints) = wallsAndWindows w
lightPoints = lightsForGloom w
viewFroms = _cameraViewFrom w
pic = worldPictures w
-- bind as much data into vbos as feasible at this point
-- poke wall points and colors
nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
@@ -79,7 +78,7 @@ doDrawing pdata w = do
_ <- renderFoldable pdata $ polysToPic $ foregroundPics w
vnums <- pokeBindFoldableLayer pdata pic
vnums <- pokeBindFoldableLayer pdata $ worldPictures w
let shads = _pictureShaders pdata
renderLayer 0 shads vnums
src/Dodge/Render/Picture.hs
+6 -3
View File
@@ -21,9 +21,12 @@ import Data.List (partition)
import qualified Data.IntMap.Lazy as IM
worldPictures :: World -> Picture
worldPictures w =
concat (IM.elems $ _decorations w) ++ testPic w ++ concat
[ concatMap (dbArg _pjDraw) . IM.elems $ _projectiles w
worldPictures w = concat $
(IM.elems $ _decorations w) ++
(map (dbArg _pjDraw) . IM.elems $ _projectiles w) ++
(map (crDraw w) . IM.elems $ _creatures w) ++
(map (dbArg _ptDraw) $ _particles w) ++
[ testPic w
, concatMap drawItem . IM.elems $ _floorItems w
, concatMap (crDraw w) . IM.elems $ _creatures w
, concatMap clDraw . reverse $ _clouds w
src/Dodge/WorldEvent/Explosion.hs
+3 -3
View File
@@ -72,14 +72,14 @@ makeExplosionAt p w
. explosionFlashAt p
$ makeShockwaveAt [] p 50 10 1 white w
where
fVs = replicateM 75 (randInCirc 1) & evalState $ _randGen w
fPs'' = replicateM 75 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w
fVs = replicateM 15 (randInCirc 1) & evalState $ _randGen w
fPs'' = replicateM 15 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w
(fPs',zs) = let (a,b,c) = unzip3 $ map fromV3 fPs''
in (zipWith V2 a b, c)
fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) fPs'
inversePushOut v = (15 - magV v) * 0.01 *.* v
fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
sizes = randomRs (2,6) $ _randGen w
sizes = randomRs (2,9) $ _randGen w
times = randomRs (20,25) $ _randGen w
mF q z v size time = makeFlameletTimed q z v Nothing size time
newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times
src/Picture.hs
+31 -12
View File
@@ -63,7 +63,7 @@ import Picture.Data
--import Data.Bifunctor
--import qualified Data.DList as DL
--import Graphics.Rendering.OpenGL (lineWidth, ($=))
import Control.Lens
--import Control.Lens
blank :: Picture
{-# INLINE blank #-}
@@ -160,17 +160,16 @@ translate3 :: Float -> Float -> Point3 -> Point3
translate3 !a !b !(V3 x y z) = V3 (x+a) (y+b) z
translate :: Float -> Float -> Picture -> Picture
--{-# INLINE translate #-}
--translate x y = map $ second $ overPos (translate3 x y)
{-# INLINE translate #-}
translate !x !y = map $! overPos $! translate3 x y
setDepth :: Float -> Picture -> Picture
--{-# INLINE setDepth #-}
{-# INLINE setDepth #-}
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d)
addDepth :: Float -> Picture -> Picture
--{-# INLINE addDepth #-}
{-# INLINE addDepth #-}
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
@@ -185,12 +184,12 @@ scale3 :: Float -> Float -> Point3 -> Point3
scale3 a b (V3 x y z) = (V3 (x*a) (y*b) (z))
scale :: Float -> Float -> Picture -> Picture
--{-# INLINE scale #-}
{-# INLINE scale #-}
--scale x y = map . second . overPos $ scale3 x y
scale x y = map $ overPos $ scale3 x y
rotate :: Float -> Picture -> Picture
--{-# INLINE rotate #-}
{-# INLINE rotate #-}
rotate a = map $ overPos $ rotate3 a
pictures :: [Picture] -> Picture
@@ -230,12 +229,10 @@ text s = map f $ stringToList s
line :: [Point2] -> Picture
{-# INLINE line #-}
--line = Line
line = flip thickLine 1
lineCol :: [(Point2,RGBA)] -> Picture
{-# INLINE lineCol #-}
--lineCol = LineCol
lineCol = flip thickLineCol 1
thickLine :: [Point2] -> Float -> Picture
@@ -296,6 +293,7 @@ thickArc startA endA rad wdth
w = 1 - wdth / r
thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
{-# INLINE thickArcHelp #-}
thickArcHelp startA endA rad wdth = map f
[( (V3 0 0 0),black,(V3 0 0 wdth))
,((V3 xa ya 0),black,(V3 1 0 wdth))
@@ -330,9 +328,23 @@ chartreuse= V4 0.5 1 0 1
orange = V4 1 0.5 0 1
white = V4 1 1 1 1
black = V4 0 0 0 1
{-# INLINE red #-}
{-# INLINE green #-}
{-# INLINE blue #-}
{-# INLINE yellow #-}
{-# INLINE cyan #-}
{-# INLINE magenta #-}
{-# INLINE rose #-}
{-# INLINE violet #-}
{-# INLINE azure #-}
{-# INLINE aquamarine #-}
{-# INLINE chartreuse #-}
{-# INLINE orange #-}
{-# INLINE white #-}
{-# INLINE black #-}
mixColors :: Float -> Float -> Color -> Color -> Color
{-# INLINE mixColors #-}
mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
let fullrat = rata + ratb
normrata = rata / fullrat
@@ -341,26 +353,33 @@ mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
in (V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2))
light :: Color -> Color
{-# INLINE light #-}
light (V4 r g b a) = (V4 (r+0.2) (g+0.2) (b+0.2) (a))
dark :: Color -> Color
{-# INLINE dark #-}
dark (V4 r g b a) = (V4 (r-0.2) (g-0.2) (b-0.2) (a))
dim :: Color -> Color
{-# INLINE dim #-}
dim (V4 r g b a) = (V4 (r/1.2) (g/1.2) (b/1.2) (a))
bright :: Color -> Color
{-# INLINE bright #-}
bright (V4 r g b a) = (V4 (r*1.2) (g*1.2) (b*1.2) (a))
greyN :: Float -> Color
{-# INLINE greyN #-}
greyN x = toV4 (x,x,x,1)
overPos :: (Point3 -> Point3) -> Verx -> Verx
{-# INLINE overPos #-}
overPos = over vxPos
--overPos = over vxPos
overPos f vx = vx {_vxPos = f (_vxPos vx)}
overCol :: (Point4 -> Point4) -> Verx -> Verx
overCol = over vxCol
{-# INLINE overCol #-}
overCol f vx = vx {_vxCol = f (_vxCol vx)}
-- no premature optimisation, consider changing to use texture arrays
stringToList :: String -> [(Point3,Point4,Point2)]
src/Render.hs
+10 -4
View File
@@ -157,15 +157,21 @@ pokeBindFoldable pdata m = do
zeroCounts :: PicShads Int
zeroCounts = PicShads 0 0 0 0 0 0
pokeBindFoldableLayer
-- :: Foldable f
:: RenderData
pokeVerxLayers
:: PicShads VBO
-> [Verx]
-> Layers (PicShads Int)
-> IO (Layers (PicShads Int))
pokeVerxLayers = undefined
pokeBindFoldableLayer
:: RenderData
-> Picture
-> IO (Layers (PicShads Int))
pokeBindFoldableLayer pdata m = do
let shads = _pictureShaders pdata
slist'' <- pokeLayVerxs (fmap (_vaoVBO . _vshaderVAO) shads) m
slist'' <- pokeLayVerxsPart (fmap (_vaoVBO . _vshaderVAO) shads) m (pure $ pure 0)
bindShaderLay shads slist''
return slist''
src/Shader/Data.hs
+10
View File
@@ -37,6 +37,8 @@ module Shader.Data
-- TODO make lenses for VBO object
-- , textureObject
) where
--import Geometry.Data
import Graphics.Rendering.OpenGL
import Foreign
import Control.Lens
@@ -139,6 +141,14 @@ data FullShader = FullShader
{- | Datatype containing the reference to a texture object. -}
newtype ShaderTexture = ShaderTexture
{ _textureObject :: TextureObject }
--data PicVerxs = PicVerxs
-- { _pvPoly :: (Point3,Point4)
-- , _pvPolyz :: (Point3,Point4,Float)
-- , _pvBez :: (Point3,Point4,Point4)
-- , _pvText :: (Point3,Point4,Point2)
-- , _pvArc :: (Point3,Point3,Point3)
-- , _pvEll :: (Point3,Point4)
-- }
data EPrimitiveMode
= EPoints
src/Shader/Poke.hs
+31 -10
View File
@@ -7,6 +7,8 @@ module Shader.Poke
, pokePoint33s
, pokeVerxs
, pokeLayVerxs
, pokeLayVerxsPart
, pokeLayVerxsPartM
, pokeLayVerxsM
, poke224s
) where
@@ -22,7 +24,7 @@ import Foreign
import Control.Monad
--import qualified Control.Foldl as F
--import qualified Data.IntMap.Strict as IM
import Control.Lens
--import Control.Lens
pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int)
pokeVerxs vbos vxs0 = go vxs0 (pure 0)
@@ -32,7 +34,7 @@ pokeVerxs vbos vxs0 = go vxs0 (pure 0)
-- this is very brittle, but want to optimise speed if possible here
pokeVerx :: PicShads VBO -> PicShads Int -> Verx -> IO ()
--{-# INLINE pokeVerx #-}
{-# INLINE pokeVerx #-}
pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case theType of
PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) (_psPoly offsets * 7 * floatSize)) thePos theCol
PolyzV x -> poke34 thePtr thePos theCol
@@ -124,6 +126,17 @@ pokeLayVerxsM !vbos = foldM f (pure $ pure 0)
where
f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx)
pokeLayVerxsPartM :: PicShads VBO -> [Verx] -> Layers (PicShads Int) -> IO (Layers (PicShads Int))
pokeLayVerxsPartM !vbos vxs0 count0 = foldM f count0 vxs0
where
f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx)
pokeLayVerxsPart :: PicShads VBO -> [Verx] -> Layers (PicShads Int) -> IO (Layers (PicShads Int))
pokeLayVerxsPart !vbos vxs0 count0 = go vxs0 count0
where
go [] count = return count
go (!vx:vxs) !count = pokeLayVerx vbos count vx >> (go vxs $! addLayCountVerx count vx)
pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (Layers (PicShads Int))
pokeLayVerxs !vbos vxs0 = go vxs0 (pure (pure 0))
where
@@ -132,7 +145,7 @@ pokeLayVerxs !vbos vxs0 = go vxs0 (pure (pure 0))
-- this is very brittle, but want to optimise speed if possible here
pokeLayVerx :: PicShads VBO -> Layers (PicShads Int) -> Verx -> IO ()
--{-# INLINE pokeLayVerx #-}
{-# INLINE pokeLayVerx #-}
pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vxLayer = theLay} = case theType of
PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) ((_psPoly offsets + layOff) * 7 * floatSize)) thePos theCol
PolyzV x -> poke34 thePtr thePos theCol
@@ -164,13 +177,21 @@ pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vx
addLayCountVerx :: Layers (PicShads Int) -> Verx -> Layers (PicShads Int)
--{-# INLINE addLayCountVerx #-}
addLayCountVerx !m !vx = case _vxLayer vx of
0 -> m & lay0 %~ f
1 -> m & lay1 %~ f
2 -> m & lay2 %~ f
3 -> m & lay3 %~ f
4 -> m & lay4 %~ f
5 -> m & lay5 %~ f
addLayCountVerx !m@Layers
{ _lay0 = a0
, _lay1 = a1
, _lay2 = a2
, _lay3 = a3
, _lay4 = a4
, _lay5 = a5
}
!vx = case _vxLayer vx of
0 -> m { _lay0 = f a0 }
1 -> m { _lay1 = f a1 }
2 -> m { _lay2 = f a2 }
3 -> m { _lay3 = f a3 }
4 -> m { _lay4 = f a4 }
5 -> m { _lay5 = f a5 }
_ -> undefined
where
f = flip addCountVerx vx