Rewrite of item color in inventory, runs slowly

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