Give proper foldl' and foldr methods for LTrees

src/Dodge/Render.hs

@@ -78,7 +78,7 @@ doDrawing pdata w = do
     if w ^. config . wall_textured
         then renderTextureWalls pdata nWalls
         else renderBlankWalls pdata nWalls
-    _ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w)
+    _ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
     _ <- renderFoldable pdata $ picToLTree (Just 0) pic
     _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
 

src/Picture/Data.hs

@@ -4,8 +4,8 @@ module Picture.Data
     where
 import Geometry.Data
 
---import Data.Foldable
-
+import Data.Foldable
+--import qualified Data.List as L
 --import Data.Monoid
 --import Data.Traversable
 --import qualified Data.Foldable as F
@@ -54,6 +54,14 @@ instance Foldable LTree where
     foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts
     foldMap g (LLeaf a) = g a
     {-# INLINE foldMap #-}
+    foldr _ x (LBranches []) = x
+    foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t
+    foldr g x (LLeaf y) = g y x
+    {-# INLINE foldr #-}
+    foldl' _ x (LBranches []) = x
+    foldl' g x (LBranches (t:ts)) = foldl' g x t `seq` foldl' g (foldl' g x t) (LBranches ts)
+    foldl' g x (LLeaf y) = g x y
+    {-# INLINE foldl' #-}
 instance Functor LTree where
     fmap f (LBranches ts) = LBranches $ fmap (fmap f) ts
     fmap f (LLeaf x) = LLeaf (f x)

src/Picture/Tree.hs

@@ -1,6 +1,8 @@
 {- Transform a picture into renderable objects. -}
 module Picture.Tree
     ( picToLTree
+    , picToRenderList
+    , picToAlt
     )
     where
 import Picture.Data
@@ -9,7 +11,7 @@ import Geometry.Data
 
 import Data.Bifunctor
 import Data.List
---import Control.Applicative
+import Control.Applicative
 --import Data.Maybe (isNothing)
 
 -- todo: refactor out the layer check somehow
@@ -65,47 +67,81 @@ picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
                                     | otherwise = LBranches []
 picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing 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 (Line ps) 
---    = RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
---picToRenderType (LineCol vs) 
---    = RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
---  where (ps,cs) = unzip vs
---picToRenderType _ = error "Tried to make a render type from a tree picture"
---picToRenderType (Text s) = RenderText $ stringToList s
+-- 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
+
+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 (Line ps) 
+    = RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+picToRenderType (LineCol vs) 
+    = RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
+  where (ps,cs) = unzip vs
+picToRenderType (Text s) = RenderText $ stringToList s
+picToRenderType _ = error "Tried to make a render type from a tree picture"
 --
 --picToAlternative
 --    :: Alternative t