Improve speed of polygon rendering by folding tree type

src/Picture.hs

@@ -16,7 +16,6 @@ module Picture
     , rotate
     , rotateRad
     , scale
-    , blank
     , color
     , withAlpha
     , greyN
@@ -51,41 +50,48 @@ import Picture.Data
 import Data.Bifunctor
 import qualified Data.DList as DL
 
-import Graphics.Rendering.OpenGL (lineWidth, ($=),PrimitiveMode (..))
+import Graphics.Rendering.OpenGL (lineWidth, ($=))
 
 import Control.Lens
 
 black :: RGBA
 black = (0,0,0,1)
 
-polygonD :: Float -> [Point2] -> Picture
-{-# INLINE polygonD #-}
-polygonD d (a:b:c:ps) = blank
-    { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
-    , _scColTri = mapVC (const black) tris
-    }
-    where twoPs = zip (b:c:ps) (c:ps)
-          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
-polygonD _ _ = blank
+--polygonD :: Float -> [Point2] -> Picture
+--{-# INLINE polygonD #-}
+--polygonD d (a:b:c:ps) = blank
+--    { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
+--    , _scColTri = mapVC (const black) tris
+--    }
+--    where twoPs = zip (b:c:ps) (c:ps)
+--          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
+--polygonD _ _ = blank
 
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon (a:b:c:ps) = blank
-    { _scPosTri = fmap zeroZ tris
-    , _scColTri = fmap (const black) tris
-    }
-    where twoPs = zip (b:c:ps) (c:ps)
-          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
-polygon _ = blank
+polygon = Polygon
 
-color :: RGBA -> Picture -> Picture
-{-# INLINE color #-}
-color c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
+--polygon :: [Point2] -> Picture
+--{-# INLINE polygon #-}
+--polygon (a:b:c:ps) = NLeaf $ emptyScene
+--    { _scPosTri = fmap zeroZ tris
+--    , _scColTri = fmap (const black) tris
+--    }
+--    where twoPs = zip (b:c:ps) (c:ps)
+--          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
+--polygon _ = blank
+
+color' :: RGBA -> Scene -> Scene
+{-# INLINE color' #-}
+color' c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
     pic {_scColTri  = mapVC (const c) colTri
         ,_scColChar = mapVC (const c) colChar
         }
+color :: RGBA -> Picture -> Picture
+{-# INLINE color #-}
+color c pic = Color c pic
 
-overPos :: (Point3 -> Point3) -> Picture -> Picture
+overPos :: (Point3 -> Point3) -> Scene -> Scene
 {-# INLINE overPos #-}
 overPos f pic@(Scene {_scPosTri = posTri,_scPosChar= posChar}) =
     pic {_scPosTri  = mapVC f posTri
@@ -96,56 +102,77 @@ translate3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE translate3 #-}
 translate3 a b (x,y,z) = (x+a,y+b,z)
 
+translate' :: Float -> Float -> Scene -> Scene
+{-# INLINE translate' #-}
+--translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
+translate' x y = overPos $ translate3 x y
+
 translate :: Float -> Float -> Picture -> Picture
 {-# INLINE translate #-}
---translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
-translate x y = overPos $ translate3 x y
+translate x y pic = Translate x y pic
+
+setDepth' :: Float -> Scene -> Scene
+{-# INLINE setDepth' #-}
+setDepth' d = overPos $ \(x,y,z) -> (x,y,d)
 
 setDepth :: Float -> Picture -> Picture
---setDepth d = over scPosTri (mapVC $ (\(x,y,z)->(x,y,d)))
---             . over scPosChar (mapVC $ (\(x,y,z)->(x,y,d)))
-setDepth d = overPos $ \(x,y,z) -> (x,y,d)
+{-# INLINE setDepth #-}
+setDepth d pic = SetDepth d pic
 
 scale3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE scale3 #-}
 scale3 a b (x,y,z) = (x*a,y*b,z)
 
+scale' :: Float -> Float -> Scene -> Scene
+{-# INLINE scale' #-}
+--scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
+scale' x y pic = overPos (scale3 x y) $ over scTexChar (fmap (second (*x))) pic
+
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
---scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
-scale x y pic = overPos (scale3 x y) $ over scTexChar (fmap (second (*x))) pic
+scale x y pic = Scale x y pic
 
 rotate3 :: Float -> Point3 -> Point3
 {-# INLINE rotate3 #-}
 rotate3 a (x,y,z) = (x',y',z)
     where (x',y') = rotateV a (x,y)
 
-rotate :: Float -> Picture -> Picture
-{-# INLINE rotate #-}
---rotate a = over scPosTri (mapVC $ rotate3 (0 - degToRad a)) 
---            . over scPosChar (mapVC $ rotate3 (0 - degToRad a))
-rotate a = overPos $ rotate3 $ 0 - degToRad a
+rotate' :: Float -> Scene -> Scene
+{-# INLINE rotate' #-}
+rotate' a = overPos $ rotate3 $ 0 - degToRad a
 
---  -- this rotation uses radians, and is anticlockwise
-rotateRad :: Float -> Picture -> Picture
+--rotate :: Float -> Picture -> Picture
+--{-# INLINE rotate #-}
+--rotate a pic = NBranch (rotate' a) pic
+--
+----  -- this rotation uses radians, and is anticlockwise
+--rotateRad' :: Float -> Scene -> Scene
+--{-# INLINE rotateRad' #-}
+--rotateRad' a = overPos $ rotate3 a
+--
+--rotateRad :: Float -> Picture -> Picture
+--{-# INLINE rotateRad #-}
+--rotateRad a pic = NBranch (rotateRad' a) pic
+
+rotate a = rotateRad (0 - degToRad a)
+{-# INLINE rotate #-}
+
+rotateRad a = Rotate a
 {-# INLINE rotateRad #-}
---rotateRad a = over scPosTri (mapVC $ rotate3 a) 
---            . over scPosChar (mapVC $ rotate3 a)
-rotateRad a = overPos $ rotate3 a
 
 pictures :: [Picture] -> Picture
 {-# INLINE pictures #-}
-pictures = mconcat
+pictures = Pictures
 
 
 makeArc :: Float -> (Float,Float) -> [Point2]
 {-# INLINE makeArc #-}
 makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
     where as = [a,a+step.. b]
-          step = pi * 0.1
+          step = pi * 0.2
 
-circleSolidD :: Float -> Float -> Picture
-circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
+--circleSolidD :: Float -> Float -> Picture
+--circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
 
 circleSolid :: Float -> Picture
 {-# INLINE circleSolid #-}
@@ -162,21 +189,25 @@ circle rad = line $ makeArc rad (0,2*pi)
 
 text :: String -> Picture
 {-# INLINE text #-}
-text s = mconcat $ zipWith (\x -> translate x (0-dimText)) 
-                           [0,0.9*dimText..] 
-                           (map charToScene s)
+text = Text
 
-charToScene :: Char -> Picture
-charToScene c = Scene
-    {_scPosTri = mempty
-    ,_scColTri = mempty
-    ,_scPosChar = toVC [(0.0,0.0,0)]
-    ,_scColChar = toVC [white]
-    ,_scTexChar = toVC [(offset,100)]
-    }
-    where x = 1/128
-          s = offset * x
-          offset = fromIntegral (fromEnum c) - 32
+----text :: String -> Picture
+----{-# INLINE text #-}
+----text s = pictures $  zipWith (\x -> translate x (0-dimText)) 
+----                           [0,0.9*dimText..] 
+----                           (map charToScene s)
+----
+----charToScene :: Char -> Picture
+----charToScene c = NLeaf $ Scene
+----    {_scPosTri = mempty
+----    ,_scColTri = mempty
+----    ,_scPosChar = toVC [(0.0,0.0,0)]
+----    ,_scColChar = toVC [white]
+----    ,_scTexChar = toVC [(offset,100)]
+----    }
+----    where x = 1/128
+----          s = offset * x
+----          offset = fromIntegral (fromEnum c) - 32
 --charToScene :: Char -> Picture
 --charToScene c = Scene
 --    {_scPosTri = mempty
@@ -265,3 +296,9 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
 
 greyN :: Float -> Color
 greyN x = (x,x,x,1)
+
+
+--zeroZ :: Point2 -> Point3
+--{-# INLINE zeroZ #-}
+--zeroZ (x,y) = (x,y,0)
+