Improve speed of polygon rendering by folding tree type

src/Picture/Data.hs

@@ -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