Rewrite of item color in inventory, runs slowly

src/Dodge/Item/Display.hs

@@ -5,15 +5,18 @@ module Dodge.Item.Display (
     basicItemDisplay,
 ) where
 
+import Dodge.Data.ComposedItem
 import ShortShow
 import Data.Maybe
 import Dodge.Data.Creature
 import LensHelp
 import Padding
 
-itemDisplay :: Creature -> Item -> [String]
-itemDisplay cr itm =
+itemDisplay :: Creature -> ComposedItem -> [String]
+itemDisplay cr ci =
     zipWithDefaults id (leftPad 15 ' ') itemDisplayPad (basicItemDisplay itm) (itemNumberDisplay cr itm)
+  where
+    itm = _cItem ci
 
 zipWithDefaults :: (a -> c) -> (b -> c) -> (a -> b -> c) -> [a] -> [b] -> [c]
 zipWithDefaults f g h = go

src/Dodge/Item/Grammar.hs

@@ -5,6 +5,9 @@ module Dodge.Item.Grammar (
     invAdj,
     invRootMap,
     invRootTrees,
+    pciToCI,
+    basePCI,
+    invTrees'',
 ) where
 
 import Control.Applicative
@@ -80,8 +83,11 @@ itemToFunction itm = case itm ^. itType of
     TARGETING{} -> WeaponTargetingSF
     _ -> UncomposableIsolateSF
 
-simplePCI :: Item -> PartiallyComposedItem
-simplePCI itm = case _itType itm of
+pciToCI :: PartiallyComposedItem -> ComposedItem
+pciToCI (x,y,_) = CItem x y
+
+basePCI :: Item -> PartiallyComposedItem
+basePCI itm = case _itType itm of
     HELD LASGUN -> (itm, WeaponScopeSF, laserLinkTest itm)
     _ -> (itm, itemToFunction itm, uncurry useBreakL $ itemToBreakLists itm)
 
@@ -149,7 +155,7 @@ joinItemsInList f xs = snd $ h (xs, [])
 invLDT :: IM.IntMap Item -> [LabelDoubleTree ItemLink PartiallyComposedItem]
 invLDT =
     joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems
-        . fmap (singleLDT . simplePCI)
+        . fmap (singleLDT . basePCI)
 
 -- this assumes the creature inventory is well formed, specifically the
 -- location ids
@@ -193,6 +199,16 @@ invTrees' = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (fmap (\(x,
         fromMaybe (error "in invTrees try to get non-inventory item tree") $
             i ^? itLocation . ilInvID
 
+-- returns an intmap with trees for all items
+--invTrees'' :: IM.IntMap Item -> [LocationLDT ItemLink ComposedItem]
+invTrees'' :: IM.IntMap Item -> IM.IntMap (Int,LocationLDT ItemLink ComposedItem)
+invTrees'' = IM.unions . map (f . LocLDT TopLDT) . IM.elems . invRootTrees
+--invTrees'' = map (LocLDT TopLDT) . IM.elems . invRootTrees
+  where
+    f t = cldtPropagateFold h h g 0 t mempty
+    h x _ _ _ = x + 1
+    g x ldt = IM.insert (ldt ^?! locLDT . ldtValue . cItem . itLocation . ilInvID) (x,ldt)
+
 -- returns an intmap with trees for root items, indexed by inventory position
 invRootTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink ComposedItem)
 invRootTrees = IM.fromAscList . reverse . map (getid . fmap (\(x, y, _) ->  CItem x y)) . invLDT

src/Dodge/Item/InventoryColor.hs

@@ -2,18 +2,21 @@ module Dodge.Item.InventoryColor
     ( itemInvColor
     ) where
 
+import Dodge.Data.ComposedItem
 import Color
 import Dodge.Data.Item
 import Control.Lens
 
-itemInvColor :: Item -> Color
-itemInvColor itm = case itm ^. itType of
-    HELD {} -> white
-    LEFT {} -> cyan
-    EQUIP {} -> yellow
-    CONSUMABLE {} -> blue
-    CRAFT {} -> green
-    ATTACH {} -> orange
-    TARGETING {} -> chartreuse
-    AMMOMAG {} -> greyN 0.8
-    BULLETMOD {} -> rose
+itemInvColor :: ComposedItem -> Color
+itemInvColor ci = case ci ^. cItemFunction of
+    WeaponPlatformSF -> white
+    _ -> greyN 0.8
+--    HELD {} -> white
+--    LEFT {} -> cyan
+--    EQUIP {} -> yellow
+--    CONSUMABLE {} -> blue
+--    CRAFT {} -> green
+--    ATTACH {} -> orange
+--    TARGETING {} -> chartreuse
+--    AMMOMAG {} -> greyN 0.8
+--    BULLETMOD {} -> rose