Merge Picture and RenderType datatypes

app/Main.hs

@@ -57,7 +57,7 @@ doSideEffects preData w = do
     let lastFrameTicks = _frameTimer preData
     when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable
                 (_renderData preData)
-                (picToLTree Nothing . setLayer 1 . setDepth (-1)
+                (map snd $ setDepth (-1)
                     . translate (-0.5) (-0.8) . scale 0.0005 0.0005
                     . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
                 )

src/Dodge/Creature/Inanimate.hs

@@ -36,7 +36,7 @@ lamp h = defaultInanimate
     }
 lampPic :: Float -> Picture
 lampPic h = pictures
-    [ setLayer 0 $ pictures . map (Poly3D . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1)
+    [ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1)
     , setLayer 1 $ setDepth h $ color white $ circleSolid 3
     ]
 

src/Dodge/Render.hs

@@ -80,20 +80,20 @@ doDrawing pdata w = do
         else renderBlankWalls pdata nWalls
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType])
-    _ <- renderFoldable pdata $ picToLTree Nothing (polysToPic $ foregroundPics w)
+    _ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w)
-    _ <- renderFoldable pdata $ picToLTree (Just 0) pic
+    _ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic
     _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
 
     bindFramebuffer Framebuffer $= fst (_fboBloom pdata)
     clear [ColorBuffer]
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    _ <- renderFoldable pdata $ picToLTree (Just 1) pic
+    _ <- renderFoldable pdata $ map snd $ filter ((==1).fst) pic
     bindFramebuffer Framebuffer $= fst (_fboColor pdata)
     clear [ColorBuffer]
     depthMask $= Disabled
-    _ <- renderFoldable pdata $ picToLTree (Just 3) pic
+    _ <- renderFoldable pdata $ map snd $ filter ((==3).fst) pic
-    _ <- renderFoldable pdata $ picToLTree (Just 4) pic
+    _ <- renderFoldable pdata $ map snd $ filter ((==4).fst) pic
-    _ <- renderFoldable pdata $ picToLTree (Just 5) pic
+    _ <- renderFoldable pdata $ map snd $ filter ((==5).fst) pic
 
     depthMask $= Enabled
     bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata)
@@ -136,7 +136,7 @@ doDrawing pdata w = do
     drawShader (_fullscreenShader pdata) 4
 
     depthFunc $= Just Lequal
-    _ <- renderFoldable pdata $ picToLTree (Just 2) pic
+    _ <- renderFoldable pdata $ map snd $ filter ((==2).fst) pic
     renderWindows pdata windowPoints
 
     depthFunc $= Just Always
@@ -167,7 +167,7 @@ doDrawing pdata w = do
     depthMask $= Disabled
     blend $= Enabled
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    _ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
+    _ <- renderFoldable pdata $ map snd (fixedCoordPictures w)
     depthMask $= Enabled
 
     eTicks <- SDL.ticks

src/Picture.hs

@@ -54,8 +54,10 @@ import Geometry
 import Geometry.Vector3D
 import Geometry.Data
 import Picture.Data
+import Picture.Tree
 
---import Data.Bifunctor
+import Data.List
+import Data.Bifunctor
 --import qualified Data.DList as DL
 --import Graphics.Rendering.OpenGL (lineWidth, ($=))
 --import Control.Lens
@@ -63,17 +65,22 @@ import Picture.Data
 black :: RGBA
 black = (0,0,0,1)
 
+zl :: RenderType -> [(Int,RenderType)]
+zl rt = [(0,rt)]
+
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon = Polygon
+polygon ps = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
 
 polygonZ :: [Point2] -> Float -> Picture
 {-# INLINE polygonZ #-}
-polygonZ = PolygonZ
+polygonZ ps z = zl $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
 
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
-polygonCol = PolygonCol
+polygonCol vs    = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+  where 
+    (ps,cs) = unzip vs
 
 poly3 :: [Point3] -> Picture
 {-# INLINE poly3 #-}
@@ -81,14 +88,14 @@ poly3 = poly3Col . map (, black)
 
 poly3Col :: [(Point3,RGBA)] -> Picture
 {-# INLINE poly3Col #-}
-poly3Col = Poly3D
+poly3Col vs = zl $ RenderPoly $ polyToTris vs
 
 -- note that much of work computing the width of the bezier curve is done here
 bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
 bezierQuad cola colc ra rc a b c 
     | a == b && b == c = blank
     | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
-    | otherwise = BezierQuad
+    | otherwise = bzhelp
         [-- ( (0,0) , cola, (0,0), (0,0) )
          (aIn, cola, (fa aIn,fc aIn) , (1,0) )
         ,(aIn, cola, (fa aIn,fc aIn) , (1,0) )
@@ -118,6 +125,12 @@ bezierQuad cola colc ra rc a b c
     fa' = extrapolate aIn cIn bIn
     fc' = extrapolate cIn aIn bIn
 
+bzhelp vs = zl $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
+  where 
+    (ps,cols,offps,rads) = unzip4 vs
+    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
+
+
 -- given a one and two zeros of a linear function over x and y,
 -- determine the function
 -- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
@@ -135,7 +148,7 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) =
 
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}
-color c = OverPic id (const c)
+color c = map $ second $ overCol (const c)
 
 translate3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE translate3 #-}
@@ -143,19 +156,19 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
 
 translate :: Float -> Float -> Picture -> Picture
 {-# INLINE translate #-}
-translate x y = OverPic (translate3 x y) id
+translate x y = map $ second $ overPos (translate3 x y)
 
 setDepth :: Float -> Picture -> Picture
 {-# INLINE setDepth #-}
-setDepth d = OverPic (\(x,y,_) -> (x,y,d)) id
+setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
 
 addDepth :: Float -> Picture -> Picture
 {-# INLINE addDepth #-}
-addDepth d = OverPic (\(x,y,z) -> (x,y,z+d)) id
+addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
 
 setLayer :: Int -> Picture -> Picture
 {-# INLINE setLayer #-}
-setLayer = OnLayer
+setLayer = map . first . const
 
 scale3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE scale3 #-}
@@ -163,15 +176,15 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
-scale x y = OverPic (scale3 x y) id
+scale x y = map $ second $ overPos $ (scale3 x y)
 
 rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
-rotate a = OverPic (rotate3 a) id
+rotate a = map $ second $ overPos $ (rotate3 a)
 
 pictures :: [Picture] -> Picture
 {-# INLINE pictures #-}
-pictures = Pictures
+pictures = concat
 
 makeArc :: Float -> (Float,Float) -> [Point2]
 {-# INLINE makeArc #-}
@@ -182,11 +195,15 @@ makeArc rad (a,b) = map (`rotateV` (0,rad)) angles
 
 circleSolid :: Float -> Picture
 {-# INLINE circleSolid #-}
-circleSolid = Circle white white
+circleSolid = circleSolidCol white white
 
 circleSolidCol :: Color -> Color -> Float -> Picture
 {-# INLINE circleSolidCol #-}
-circleSolidCol = Circle
+circleSolidCol colC colE r = zl $ RenderEllipse 
+    [( (-r, r,0), colC)
+    ,( (-r,-r,0), colE)
+    ,( ( r,-r,0), black)
+    ]
 
 circle :: Float -> Picture
 {-# INLINE circle #-}
@@ -194,7 +211,7 @@ circle rad = thickArc 0 (2*pi) rad 1
 
 text :: String -> Picture
 {-# INLINE text #-}
-text = Text
+text s = zl $ RenderText $ stringToList s
 
 line :: [Point2] -> Picture
 {-# INLINE line #-}
@@ -256,13 +273,26 @@ thickArc :: Float -> Float -> Float -> Float -> Picture
 thickArc startA endA rad wdth
     | endA - startA > pi = pictures 
         [ thickArc (startA + pi) endA rad wdth
-        , ThickArc startA (startA + pi) r w
+        , thickArcHelp startA (startA + pi) r w
         ]
-    | otherwise = ThickArc startA endA r w
+    | otherwise = thickArcHelp startA endA r w
   where
     r = rad + 0.5 * wdth
     w = 1 - wdth / r
 
+thickArcHelp startA endA rad wdth = zl $ RenderArc 
+    [(  (0,0,0),black,(0,0,wdth))
+    ,((xa,ya,0),black,(1,0,wdth))
+    ,((xb,yb,0),black,(1,1,wdth))
+    ,(  (0,0,0),black,(0,0,wdth))
+    ,((xb,yb,0),black,(1,1,wdth))
+    ,((xc,yc,0),black,(0,1,wdth))
+    ]
+  where
+    (xa,ya) = rotateV startA (rad,0)
+    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
+    (xc,yc) = rotateV endA (rad,0)
+
 withAlpha :: Float -> RGBA -> RGBA
 {-# INLINE withAlpha #-}
 withAlpha a (x,y,z,a') = (x,y,z,a*a')

src/Picture/Data.hs

@@ -99,20 +99,20 @@ flat4 (x,y,z,w) = [x,y,z,w]
 {-# INLINE flat3 #-}
 {-# INLINE flat4 #-}
 
-data Picture
+type Picture = [(Int,RenderType)]
-    = Blank
+--    = Blank
-    | Text String
+--    | Text String
-    | Polygon [Point2]
+--    | Polygon [Point2]
-    | PolygonZ [Point2] Float
+--    | PolygonZ [Point2] Float
-    | BezierQuad [(Point2,RGBA,Point2,Point2)]
+--    | BezierQuad [(Point2,RGBA,Point2,Point2)]
-    | PolygonCol [(Point2,RGBA)]
+--    | PolygonCol [(Point2,RGBA)]
-    | Poly3D [(Point3,RGBA)]
+--    | Poly3D [(Point3,RGBA)]
-    | Circle RGBA RGBA Float
+--    | Circle RGBA RGBA Float
-    | ThickArc Float Float Float Float
+--    | ThickArc Float Float Float Float
-    | Pictures [Picture]
+--    | Pictures [Picture]
-    | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
+--    | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
-    | OnLayer Int Picture
+--    | OnLayer Int Picture
 
 blank :: Picture
 {-# INLINE blank #-}
-blank = Blank
+blank = []

src/Picture/ToPolyhedra.hs

@@ -3,9 +3,9 @@ module Picture.ToPolyhedra
 import Picture.Data
 import Geometry.Data
 
-toPolyhedra :: Picture -> [[Point3]]
+--toPolyhedra :: Picture -> [[Point3]]
-toPolyhedra (OnLayer _ pic) = toPolyhedra pic
+--toPolyhedra (OnLayer _ pic) = toPolyhedra pic
-toPolyhedra (Pictures pics) = concatMap toPolyhedra pics
+--toPolyhedra (Pictures pics) = concatMap toPolyhedra pics
-toPolyhedra (OverPic f _ pic) = map (map f) $ toPolyhedra pic
+--toPolyhedra (OverPic f _ pic) = map (map f) $ toPolyhedra pic
-toPolyhedra (Poly3D vs) = [map fst vs]
+--toPolyhedra (Poly3D vs) = [map fst vs]
-toPolyhedra _ = []
+--toPolyhedra _ = []

src/Picture/Tree.hs

@@ -1,11 +1,8 @@
 {- Transform a picture into renderable objects. -}
 module Picture.Tree
-    ( picToLTree
+    ( overPos
-    , picToLTree'
+    , overCol
-    , picToFTree
+    , stringToList
-    , picToRenderList
-    , picToAlt
-    , picToRList
     )
     where
 import Picture.Data
@@ -20,189 +17,62 @@ import qualified Data.DList as DL
 import Control.Applicative
 --import Data.Maybe (isNothing)
 
-picToLTree'
+--picToLTree'
-    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
+--    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
-    -> Picture
-    -> LTree RenderType
-picToLTree' x p = rnf (picToLTree x p) `seq` picToLTree x p
-
--- todo: refactor out the layer check somehow
--- consider generalising to alternative rather than using LTree
--- | Transform a picture into a tree of renderable objects
-picToLTree 
-    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
-    -> Picture
-    -> LTree RenderType
---{-# INLINE picToLTree #-}
-picToLTree _ (Polygon ps)
-    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-picToLTree _ (PolygonZ ps z)
-    = LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
-picToLTree _ (PolygonCol vs)
-    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
-  where 
-    (ps,cs) = unzip vs
-picToLTree _ (Poly3D vs) = LLeaf $ RenderPoly $ polyToTris vs
-picToLTree _ (BezierQuad vs) = LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
-  where 
-    (ps,cols,offps,rads) = unzip4 vs
-    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
-picToLTree _ (Circle colC colE r) = LLeaf $ RenderEllipse 
-    [( (-r, r,0), colC)
-    ,( (-r,-r,0), colE)
-    ,( ( r,-r,0), black)
-    ]
-picToLTree _ (ThickArc startA endA rad wdth) = LLeaf $ RenderArc 
-    [(  (0,0,0),black,(0,0,wdth))
-    ,((xa,ya,0),black,(1,0,wdth))
-    ,((xb,yb,0),black,(1,1,wdth))
-    ,(  (0,0,0),black,(0,0,wdth))
-    ,((xb,yb,0),black,(1,1,wdth))
-    ,((xc,yc,0),black,(0,1,wdth))
-    ]
-  where
-    (xa,ya) = rotateV startA (rad,0)
-    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
-    (xc,yc) = rotateV endA (rad,0)
-picToLTree _ (Text s) = LLeaf $ RenderText $ stringToList s
-picToLTree _ Blank = LBranches []
-picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
---picToLTree j (Pictures pics) = LBranches . forceFoldable $ map (picToLTree j) pics
-picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
-picToLTree j (OverPic f f' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f') ps)
-picToLTree j (OverPic f f' pic) = overPos f . overCol f' <$> picToLTree j pic
-picToLTree (Just j) (OnLayer i pic) 
-    | j == i = picToLTree Nothing pic
-    | otherwise = LBranches []
-picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic
-
-picToFTree 
-    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
-    -> Picture
-    -> FTree RenderType
---{-# INLINE picToFTree #-}
-picToFTree _ (Polygon ps)
-    = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-picToFTree _ (PolygonZ ps z)
-    = FLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
-picToFTree _ (PolygonCol vs)
-    = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
-  where 
-    (ps,cs) = unzip vs
-picToFTree _ (Poly3D vs) = FLeaf $ RenderPoly $ polyToTris vs
-picToFTree _ (BezierQuad vs) = FLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
-  where 
-    (ps,cols,offps,rads) = unzip4 vs
-    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
-picToFTree _ (Circle colC colE r) = FLeaf $ RenderEllipse 
-    [( (-r, r,0), colC)
-    ,( (-r,-r,0), colE)
-    ,( ( r,-r,0), black)
-    ]
-picToFTree _ (ThickArc startA endA rad wdth) = FLeaf $ RenderArc 
-    [(  (0,0,0),black,(0,0,wdth))
-    ,((xa,ya,0),black,(1,0,wdth))
-    ,((xb,yb,0),black,(1,1,wdth))
-    ,(  (0,0,0),black,(0,0,wdth))
-    ,((xb,yb,0),black,(1,1,wdth))
-    ,((xc,yc,0),black,(0,1,wdth))
-    ]
-  where
-    (xa,ya) = rotateV startA (rad,0)
-    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
-    (xc,yc) = rotateV endA (rad,0)
-picToFTree _ (Text s) = FLeaf $ RenderText $ stringToList s
-picToFTree _ Blank = FBranches []
-picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
-picToFTree j (OverPic f f' pic) = FBranch (overPos f . overCol f') $ picToFTree j pic
-picToFTree (Just j) (OnLayer i pic) | j == i = picToFTree Nothing pic
-                                    | otherwise = FBranches []
-picToFTree Nothing  (OnLayer _ pic) = picToFTree Nothing pic
-
--- might want to use the Alt newType
-picToAlt
-    :: (Alternative t, Monoid (t RenderType))
-    => Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
-    -> Picture
-    -> t RenderType
-{-# INLINE picToAlt #-}
-picToAlt _ Blank = empty
-picToAlt j (Pictures pics) = foldMap (picToAlt j) pics
-picToAlt j (OverPic f f' (OverPic g g' pic)) = picToAlt j $ OverPic (f . g) (f' . g') pic
---picToAlt j (OverPic f f' (Pictures ps)) = concat $ fmap (picToAlt j . OverPic f f') ps
-picToAlt j (OverPic f f' pic) = overPos f . overCol f' <$> picToAlt j pic
-picToAlt (Just j) (OnLayer i pic)
-    | j == i = picToAlt Nothing pic
-    | otherwise = empty
-picToAlt Nothing (OnLayer _ pic) = picToAlt Nothing pic
-picToAlt _ pic = pure $ picToRenderType pic
-
-picToRList 
-    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
-    -> Picture
-    -> DL.DList RenderType
-picToRList = picToAlt
-
-picToRenderList
-    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
-    -> Picture
-    -> [RenderType]
-{-# INLINE picToRenderList #-}
-picToRenderList _ Blank = []
-picToRenderList j (Pictures pics) = concatMap (picToRenderList j) pics
-picToRenderList j (OverPic f f' (OverPic g g' pic)) = picToRenderList j $ OverPic (f . g) (f' . g') pic
-picToRenderList j (OverPic f f' (Pictures ps)) = concatMap (picToRenderList j . OverPic f f') ps
-picToRenderList j (OverPic f f' pic) = overPos f . overCol f' <$> picToRenderList j pic
-picToRenderList (Just j) (OnLayer i pic)
-    | j == i = picToRenderList Nothing pic
-    | otherwise = []
-picToRenderList Nothing (OnLayer _ pic) = picToRenderList Nothing pic
-picToRenderList _ pic = [picToRenderType pic]
-
-picToRenderType 
-    :: Picture
-    -> RenderType
-{-# INLINE picToRenderType #-}
-picToRenderType (Polygon ps)
-    = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-picToRenderType (PolygonZ ps z)
-    = RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
-picToRenderType (PolygonCol vs)
-    = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
-  where 
-    (ps,cs) = unzip vs
-picToRenderType (Poly3D vs) = RenderPoly $ polyToTris vs
-picToRenderType (BezierQuad vs) = RenderBezQ $ zip3 (map zeroZ ps) cols rs
-  where 
-    (ps,cols,offps,rads) = unzip4 vs
-    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
-picToRenderType (Circle colC colE r) = RenderEllipse 
-    [( (-r, r,0), colC)
-    ,( (-r,-r,0), colE)
-    ,( ( r,-r,0), black)
-    ]
-picToRenderType (ThickArc startA endA rad wdth) = RenderArc 
-    [(  (0,0,0),black,(0,0,wdth))
-    ,((xa,ya,0),black,(1,0,wdth))
-    ,((xb,yb,0),black,(1,1,wdth))
-    ,(  (0,0,0),black,(0,0,wdth))
-    ,((xb,yb,0),black,(1,1,wdth))
-    ,((xc,yc,0),black,(0,1,wdth))
-    ]
-  where
-    (xa,ya) = rotateV startA (rad,0)
-    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
-    (xc,yc) = rotateV endA (rad,0)
-picToRenderType (Text s) = RenderText $ stringToList s
-picToRenderType _ = error "Tried to make a render type from a tree picture"
---
---picToAlternative
---    :: Alternative t
---    => Maybe Int
 --    -> Picture
---    -> t RenderType
+--    -> LTree RenderType
---picToAlternative _ Blank = empty
+--picToLTree' x p = rnf (picToLTree x p) `seq` picToLTree x p
---picToAlternative j (Pictures pics) = undefined
+--
+---- todo: refactor out the layer check somehow
+---- consider generalising to alternative rather than using LTree
+---- | Transform a picture into a tree of renderable objects
+--picToLTree 
+--    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
+--    -> Picture
+--    -> LTree RenderType
+----{-# INLINE picToLTree #-}
+--picToLTree _ (Polygon ps)
+--    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+--picToLTree _ (PolygonZ ps z)
+--    = LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
+--picToLTree _ (PolygonCol vs)
+--    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+--  where 
+--    (ps,cs) = unzip vs
+--picToLTree _ (Poly3D vs) = LLeaf $ RenderPoly $ polyToTris vs
+--picToLTree _ (BezierQuad vs) = LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
+--  where 
+--    (ps,cols,offps,rads) = unzip4 vs
+--    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
+--picToLTree _ (Circle colC colE r) = LLeaf $ RenderEllipse 
+--    [( (-r, r,0), colC)
+--    ,( (-r,-r,0), colE)
+--    ,( ( r,-r,0), black)
+--    ]
+--picToLTree _ (ThickArc startA endA rad wdth) = LLeaf $ RenderArc 
+--    [(  (0,0,0),black,(0,0,wdth))
+--    ,((xa,ya,0),black,(1,0,wdth))
+--    ,((xb,yb,0),black,(1,1,wdth))
+--    ,(  (0,0,0),black,(0,0,wdth))
+--    ,((xb,yb,0),black,(1,1,wdth))
+--    ,((xc,yc,0),black,(0,1,wdth))
+--    ]
+--  where
+--    (xa,ya) = rotateV startA (rad,0)
+--    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
+--    (xc,yc) = rotateV endA (rad,0)
+--picToLTree _ (Text s) = LLeaf $ RenderText $ stringToList s
+--picToLTree _ Blank = LBranches []
+--picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
+----picToLTree j (Pictures pics) = LBranches . forceFoldable $ map (picToLTree j) pics
+--picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
+--picToLTree j (OverPic f f' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f') ps)
+--picToLTree j (OverPic f f' pic) = overPos f . overCol f' <$> picToLTree j pic
+--picToLTree (Just j) (OnLayer i pic) 
+--    | j == i = picToLTree Nothing pic
+--    | otherwise = LBranches []
+--picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic
+
     
 white, black :: Color
 white = (1,1,1,1)

src/Polyhedra.hs

@@ -83,7 +83,12 @@ boxABC a b c =
     faceNA = rhombus c b
 
 polyToPics :: Polyhedra -> [Picture]
-polyToPics = map Poly3D . _pyFaces
+polyToPics = map helpPoly3D . _pyFaces
+
+helpPoly3D vs = zl $ RenderPoly $ polyToTris vs
+  where
+    zl :: RenderType -> [(Int,RenderType)]
+    zl rt = [(0,rt)]
 
 polysToPic :: [Polyhedra] -> Picture
 polysToPic = pictures . concatMap polyToPics