Improve speed of polygon rendering by folding tree type
This commit is contained in:
+68
-41
@@ -15,34 +15,33 @@ type RGBA = (Float,Float,Float,Float)
|
||||
type Color = (Float,Float,Float,Float)
|
||||
|
||||
|
||||
type VerticesContainer a = Se.Seq a
|
||||
toVC = Se.fromList
|
||||
fromVC :: VerticesContainer a -> [a]
|
||||
fromVC = F.toList
|
||||
--type VerticesContainer a = Se.Seq a
|
||||
--toVC = Se.fromList
|
||||
--fromVC :: VerticesContainer a -> [a]
|
||||
--fromVC = F.toList
|
||||
--type VerticesContainer a = DL.DList a
|
||||
--toVC = DL.fromList
|
||||
--fromVC = DL.toList
|
||||
--type VerticesContainer a = [a]
|
||||
--toVC = id
|
||||
--fromVC = id
|
||||
type VerticesContainer a = [a]
|
||||
toVC = id
|
||||
fromVC = id
|
||||
{-# INLINE toVC #-}
|
||||
{-# INLINE fromVC #-}
|
||||
{-# INLINE mapVC #-}
|
||||
|
||||
mapVC :: (a -> b) -> VerticesContainer a -> VerticesContainer b
|
||||
mapVC = fmap
|
||||
|
||||
data NTree a b
|
||||
= NBranch a [NTree a b]
|
||||
| NLeaf b
|
||||
data FTree a
|
||||
= FBranch (a -> a) (FTree a)
|
||||
| FBranches [FTree a]
|
||||
| FLeaf a
|
||||
|
||||
reduceNTree :: NTree (a -> a) a -> NTree () a
|
||||
reduceNTree = reduceNTree' id
|
||||
where
|
||||
reduceNTree' :: (b -> b) -> NTree (b -> b) b -> NTree () b
|
||||
reduceNTree' f (NBranch g xs) = NBranch () $ map (reduceNTree' (f . g)) xs
|
||||
reduceNTree' f (NLeaf x) = NLeaf $ f x
|
||||
|
||||
concatLeaves :: NTree a b -> DL.DList b
|
||||
concatLeaves (NLeaf x) = DL.singleton x
|
||||
concatLeaves (NBranch _ xs) = mconcat (map concatLeaves xs)
|
||||
instance Foldable FTree where
|
||||
foldMap g (FBranch f t) = foldMap (g . f) t
|
||||
foldMap g (FBranches ts) = mconcat $ map (foldMap g) ts
|
||||
foldMap g (FLeaf x) = g x
|
||||
{-# INLINE foldMap #-}
|
||||
|
||||
--reduceShapeTree :: (Shape -> Shape) -> ShapeTree -> [Shape]
|
||||
--reduceShapeTree
|
||||
@@ -50,27 +49,51 @@ concatLeaves (NBranch _ xs) = mconcat (map concatLeaves xs)
|
||||
--reduceShapeTree
|
||||
-- (Leaf s) = [s]
|
||||
|
||||
data ShapeTree
|
||||
= TransformShape (Shape -> Shape) [ShapeTree]
|
||||
| Leaf Shape
|
||||
|
||||
data Shape
|
||||
= Shape
|
||||
{ _shPos :: VerticesContainer Point3
|
||||
, _shCol :: VerticesContainer RGBA
|
||||
}
|
||||
| TextShape
|
||||
{ _shPos :: VerticesContainer Point3
|
||||
, _shCol :: VerticesContainer RGBA
|
||||
, _shTex :: VerticesContainer Point2
|
||||
}
|
||||
-- data ShapeTree
|
||||
-- = TransformShape (Shape -> Shape) [ShapeTree]
|
||||
-- | Leaf Shape
|
||||
--
|
||||
-- data Shape
|
||||
-- = Shape
|
||||
-- { _shPos :: VerticesContainer Point3
|
||||
-- , _shCol :: VerticesContainer RGBA
|
||||
-- }
|
||||
-- | TextShape
|
||||
-- { _shPos :: VerticesContainer Point3
|
||||
-- , _shCol :: VerticesContainer RGBA
|
||||
-- , _shTex :: VerticesContainer Point2
|
||||
-- }
|
||||
--
|
||||
--combineShapes :: Shape -> Shape -> Shape
|
||||
--combineShapes sa sb = Shape
|
||||
-- { _shPos = _shPos sa <> _shPos sb
|
||||
-- , _shCol = _shCol sa <> _shCol sb
|
||||
-- }
|
||||
|
||||
data Picture = Scene
|
||||
flat2 (x,y) = [x,y]
|
||||
flat3 (x,y,z) = [x,y,z]
|
||||
flat4 (x,y,z,w) = [x,y,z,w]
|
||||
{-# INLINE flat2 #-}
|
||||
{-# INLINE flat3 #-}
|
||||
{-# INLINE flat4 #-}
|
||||
|
||||
data RenderType
|
||||
= RenderPoly [(Point3,Point4)]
|
||||
| RenderText [(Point3,Point4,Point2)]
|
||||
| RenderBlank
|
||||
|
||||
data Picture
|
||||
= Blank
|
||||
| Text String
|
||||
| Polygon [Point2]
|
||||
| Scale Float Float Picture
|
||||
| Translate Float Float Picture
|
||||
| Rotate Float Picture
|
||||
| SetDepth Float Picture
|
||||
| Color RGBA Picture
|
||||
| Pictures [Picture]
|
||||
|
||||
data Scene = Scene
|
||||
{ _scPosTri :: VerticesContainer Point3
|
||||
, _scColTri :: VerticesContainer RGBA
|
||||
, _scPosChar :: VerticesContainer Point3
|
||||
@@ -78,11 +101,15 @@ data Picture = Scene
|
||||
, _scTexChar :: VerticesContainer Point2
|
||||
}
|
||||
|
||||
emptyScene :: Scene
|
||||
{-# INLINE emptyScene #-}
|
||||
emptyScene = Scene mempty mempty mempty mempty mempty
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = Scene mempty mempty mempty mempty mempty
|
||||
blank = Blank
|
||||
|
||||
combineScenes :: Picture -> Picture -> Picture
|
||||
combineScenes :: Scene -> Scene -> Scene
|
||||
{-# INLINE combineScenes #-}
|
||||
combineScenes sa sb = Scene
|
||||
{ _scPosTri = _scPosTri sa <> _scPosTri sb
|
||||
@@ -92,10 +119,10 @@ combineScenes sa sb = Scene
|
||||
, _scTexChar = _scTexChar sa <> _scTexChar sb
|
||||
}
|
||||
|
||||
instance Semigroup Picture where
|
||||
instance Semigroup Scene where
|
||||
(<>) = combineScenes
|
||||
instance Monoid Picture where
|
||||
mempty = blank
|
||||
instance Monoid Scene where
|
||||
mempty = emptyScene
|
||||
--mappend = combineScenes
|
||||
|
||||
makeLenses ''Picture
|
||||
makeLenses ''Scene
|
||||
|
||||
+139
-36
@@ -1,7 +1,13 @@
|
||||
--{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
|
||||
module Picture.Render
|
||||
where
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.State
|
||||
|
||||
import Data.Bifunctor
|
||||
|
||||
import Picture
|
||||
import Geometry
|
||||
|
||||
@@ -12,10 +18,11 @@ import Foreign
|
||||
|
||||
import Codec.Picture
|
||||
|
||||
import Graphics.Rendering.OpenGL hiding (translate,scale,imageHeight,imageWidth)
|
||||
import Graphics.Rendering.OpenGL hiding (get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import qualified Data.Vector.Storable as V
|
||||
import qualified Data.DList as DL
|
||||
|
||||
@@ -29,61 +36,157 @@ toVec2 (x,y) = Vector2 x y
|
||||
toVec3 (x,y,z) = Vector3 x y z
|
||||
toVec4 (x,y,z,w) = Vector4 x y z w
|
||||
|
||||
flat2 (x,y) = toVC [x,y]
|
||||
flat3 (x,y,z) = toVC [x,y,z]
|
||||
flat4 (x,y,z,w) = toVC [x,y,z,w]
|
||||
|
||||
mapFlat :: (NFData b) => (a -> VerticesContainer b) -> VerticesContainer a -> [b]
|
||||
mapFlat f = fromVC . foldMap f
|
||||
|
||||
--marshallVs = V.unsafeWith . V.fromList
|
||||
--marshallVs = withArray
|
||||
polyToTris :: [s] -> [s]
|
||||
{-# INLINE polyToTris #-}
|
||||
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
|
||||
polyToTris _ = []
|
||||
|
||||
data Tx a = Tx [Tx a] | Lx a
|
||||
|
||||
deriving instance Foldable Tx
|
||||
|
||||
stateBump :: [Int] -> () -> State Int [Int]
|
||||
stateBump xs _ = do
|
||||
s <- get
|
||||
modify (+1)
|
||||
return (s:xs)
|
||||
|
||||
redT :: Foldable t => t () -> [Int]
|
||||
redT x = evalState (foldM stateBump [] x) 0
|
||||
|
||||
picToFTree :: Picture -> FTree [(Point3,Point4)]
|
||||
{-# INLINE picToFTree #-}
|
||||
picToFTree (Polygon ps) = FLeaf $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
picToFTree Blank = FLeaf $ []
|
||||
picToFTree (Text _) = FLeaf $ []
|
||||
picToFTree (Scale x y pic) = FBranch (map $ first $ scale3 x y) $ picToFTree pic
|
||||
picToFTree (Translate x y pic) = FBranch (map $ first $ translate3 x y) $ picToFTree pic
|
||||
picToFTree (Rotate a pic) = FBranch (map $ first $ rotate3 a) $ picToFTree pic
|
||||
picToFTree (SetDepth a pic) = FBranch (map $ first $ (\(x,y,_) -> (x,y,a))) $ picToFTree pic
|
||||
picToFTree (Color c pic) = FBranch (map $ second $ const c) $ picToFTree pic
|
||||
picToFTree (Pictures pics) = FBranches $ map picToFTree pics
|
||||
|
||||
pokePic :: Ptr Float -> Ptr Float -> FTree [(Point3,Point4)] -> IO Int
|
||||
pokePic = go 0
|
||||
where go n pa pb t = foldM (pokePoly pa pb) n t
|
||||
|
||||
pokePoly :: Ptr Float -> Ptr Float -> Int -> [(Point3,Point4)] -> IO Int
|
||||
pokePoly pa pb n vs = foldM (pokeVert pa pb) n vs
|
||||
|
||||
pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
|
||||
pokeVert pa pb n ((x,y,z),(r,g,b,a))
|
||||
| n > 20000 * 2 = return n
|
||||
| otherwise = do
|
||||
pokeElemOff pa (3*n+0) x
|
||||
pokeElemOff pa (3*n+1) y
|
||||
pokeElemOff pa (3*n+2) z
|
||||
pokeElemOff pb (4*n+0) r
|
||||
pokeElemOff pb (4*n+1) g
|
||||
pokeElemOff pb (4*n+2) b
|
||||
pokeElemOff pb (4*n+3) a
|
||||
return (n+1)
|
||||
|
||||
|
||||
|
||||
reducePicture :: Picture -> (DL.DList Float,DL.DList Float)
|
||||
{-# INLINE reducePicture #-}
|
||||
reducePicture = reducePicture' black id
|
||||
where
|
||||
reducePicture' :: RGBA -> (Point3 -> Point3) -> Picture -> (DL.DList Float,DL.DList Float)
|
||||
reducePicture' col tran Blank = (DL.empty,DL.empty)
|
||||
reducePicture' col tran (Text _) = (DL.empty,DL.empty)
|
||||
reducePicture' col tran (Polygon ps)
|
||||
= ( DL.fromList $ concatMap (flat3 . tran . zeroZ) (polyToTris ps)
|
||||
, DL.fromList $ concatMap (flat4 . const col) (polyToTris ps)
|
||||
)
|
||||
reducePicture' col tran (Scale x y pic)
|
||||
= reducePicture' col (tran . scale3 x y) pic
|
||||
reducePicture' col tran (Translate x y pic)
|
||||
= reducePicture' col (tran . translate3 x y) pic
|
||||
reducePicture' col tran (Rotate a pic)
|
||||
= reducePicture' col (tran . rotate3 a) pic
|
||||
reducePicture' col tran (SetDepth a pic)
|
||||
= reducePicture' col (tran . \(x,y,z) -> (x,y,a)) pic
|
||||
reducePicture' col tran (Color c pic)
|
||||
= reducePicture' c tran pic
|
||||
reducePicture' col tran (Pictures pics)
|
||||
= foldr com (DL.empty,DL.empty) $ map (reducePicture' col tran) pics
|
||||
where com (xs,ys) (xs',ys') = (xs <> xs', ys <> ys')
|
||||
|
||||
translate3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE translate3 #-}
|
||||
translate3 a b (x,y,z) = (x+a,y+b,z)
|
||||
scale3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE scale3 #-}
|
||||
scale3 a b (x,y,z) = (x*a,y*b,z)
|
||||
rotate3 :: Float -> Point3 -> Point3
|
||||
{-# INLINE rotate3 #-}
|
||||
rotate3 a (x,y,z) = (x',y',z)
|
||||
where (x',y') = rotateV a (x,y)
|
||||
|
||||
renderPicture' :: PreloadData -> Picture -> IO ()
|
||||
renderPicture' pdata (Scene posTri colTri posChar colChar texChar) = do
|
||||
renderPicture' pdata pic = do
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_basicVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
let firstIndex = 0
|
||||
let vertices :: [Float]
|
||||
vertices = mapFlat flat3 posTri
|
||||
numVertices = length posTri
|
||||
vertexSize = sizeOf (head vertices)
|
||||
pokeArray (_ptrPosVBO pdata) vertices
|
||||
bufferData ArrayBuffer $= (fromIntegral (3 * numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
|
||||
fSize = sizeOf (0::Float)
|
||||
numVert <- pokePic (_ptrPosVBO pdata) (_ptrColVBO pdata) $ picToFTree pic
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 3, _ptrPosVBO pdata, StreamDraw)
|
||||
-- marshallVs vertices $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
let colVs = mapFlat flat4 colTri
|
||||
colVsize = sizeOf $ head colVs
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 4, _ptrColVBO pdata, StreamDraw)
|
||||
-- marshallVs colVs $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVert)
|
||||
|
||||
renderPicture :: PreloadData -> Picture -> IO ()
|
||||
renderPicture pdata pic = do
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_basicVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
let firstIndex = 0
|
||||
let (vs,cs) = reducePicture pic
|
||||
vertices :: [Float]
|
||||
vertices = DL.toList vs
|
||||
numVertices = length vertices
|
||||
vertexSize = sizeOf (head vertices)
|
||||
pokeArray (_ptrPosVBO pdata) vertices
|
||||
bufferData ArrayBuffer $= (fromIntegral (length vertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
|
||||
-- marshallVs vertices $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
let colVs = DL.toList cs
|
||||
pokeArray (_ptrColVBO pdata) colVs
|
||||
bufferData ArrayBuffer $= (fromIntegral (4 * numVertices * colVsize), _ptrColVBO pdata, StreamDraw)
|
||||
bufferData ArrayBuffer $= (fromIntegral (length colVs * vertexSize), _ptrColVBO pdata, StreamDraw)
|
||||
-- marshallVs colVs $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices)
|
||||
|
||||
currentProgram $= Just (_textShader pdata)
|
||||
bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
let vertices' = mapFlat flat3 posChar
|
||||
numVertices' = length posChar
|
||||
vertexSize' = sizeOf $ head vertices'
|
||||
pokeArray (_ptrPosVBO pdata) vertices'
|
||||
bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
|
||||
--withArray vertices' $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
pokeArray (_ptrColVBO pdata) $ mapFlat flat4 colChar
|
||||
bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
pokeArray (_ptrTexVBO pdata) $ mapFlat flat2 texChar
|
||||
bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
|
||||
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVertices')
|
||||
---- currentProgram $= Just (_textShader pdata)
|
||||
---- bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
---- bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
---- let vertices' = concatMap flat3 posChar
|
||||
---- numVertices' = length posChar
|
||||
---- vertexSize' = sizeOf $ head vertices'
|
||||
---- pokeArray (_ptrPosVBO pdata) vertices'
|
||||
---- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
|
||||
---- --withArray vertices' $ \ptr -> do
|
||||
---- -- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
|
||||
---- bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
---- pokeArray (_ptrColVBO pdata) $ concatMap flat4 colChar
|
||||
---- bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
|
||||
---- bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
---- pokeArray (_ptrTexVBO pdata) $ concatMap flat2 texChar
|
||||
---- bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
|
||||
---- drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVertices')
|
||||
|
||||
|
||||
|
||||
bufferOffset :: Integral a => a -> Ptr b
|
||||
bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
|
||||
zeroZ :: Point2 -> Point3
|
||||
zeroZ (x,y) = (x,y,0)
|
||||
|
||||
Reference in New Issue
Block a user