Partial fix of inventory rendering

src/Picture/Data.hs

@@ -37,22 +37,27 @@ data FTree a
     = FBranch (a -> a) (FTree a)
     | FBranches [FTree a]
     | FLeaf a
-
 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 #-}
-
+instance Functor FTree where
+    fmap g (FBranch f t) = fmap (g . f) t
+    fmap f (FBranches ts) = FBranches $ fmap (fmap f) ts
+    fmap f (FLeaf x) = FLeaf (f x)
+    {-# INLINE fmap #-}
+    
 {- Tree with values at and only at the leaves. -}
 data LTree a
     = LBranches [LTree a]
-    | LLeaf !a
+    | LLeaf a
 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 x t `seq` foldr g (foldr g x t) (LBranches ts)
     foldr g x (LBranches (t:ts)) = foldr g (foldr g x t) (LBranches ts)
     --foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t
     foldr g x (LLeaf y) = g y x

src/Picture/Tree.hs

@@ -1,8 +1,10 @@
 {- Transform a picture into renderable objects. -}
 module Picture.Tree
     ( picToLTree
+    , picToFTree
     , picToRenderList
     , picToAlt
+    , picToRList
     )
     where
 import Picture.Data
@@ -11,6 +13,7 @@ import Geometry.Data
 
 import Data.Bifunctor
 import Data.List
+import qualified Data.DList as DL
 import Control.Applicative
 --import Data.Maybe (isNothing)
 
@@ -58,10 +61,54 @@ picToLTree j (Pictures pics) = LBranches $ 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 (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))
@@ -80,6 +127,12 @@ picToAlt (Just j) (OnLayer i pic)
 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