Rewrite of item color in inventory, runs slowly

src/Dodge/Combine.hs

@@ -3,6 +3,7 @@ module Dodge.Combine (
     combineList,
 ) where
 
+import Dodge.Item.Grammar
 import Data.Bifunctor
 import Data.Foldable
 import Data.List (sort, sortOn)
@@ -24,7 +25,7 @@ combineList = map f . combineItemListYouX
             { _siPictures = basicItemDisplay itm
             , _siHeight = _itInvSize itm
             , _siIsSelectable = True
-            , _siColor = itemInvColor itm
+            , _siColor = itemInvColor . pciToCI $ basePCI itm
             , _siOffX = 0
             , _siPayload = CombinableItem is itm []
             }

src/Dodge/DisplayInventory.hs

@@ -9,6 +9,8 @@ module Dodge.DisplayInventory (
     updateCombinePositioning,
 ) where
 
+import Dodge.Data.ComposedItem
+import Dodge.Data.DoubleTree
 import Control.Lens
 import Dodge.Inventory.SelectionList
 import Control.Monad
@@ -113,11 +115,10 @@ updateDisplaySections w cfig sss =
     coitems' =
         IM.fromDistinctAscList . zip [0 ..] $
             map closeObjectToSelectionItem (w ^. hud . closeObjects)
-    invitems' = IM.mapWithKey (\k (x,y,_) -> invSelectionItem cr k x y) inv
+    invitems' = IM.mapWithKey (\k (y,x) -> invSelectionItem cr k (x ^. locLDT . ldtValue) y) 
+        invlocs
     cr = you w
-    inv = invIndentIM  $ _crInv (you w)
-    --indents = indentInv inv
-    --inv = indentInv $ _crInv (you w)
+    invlocs = invTrees''  $ _crInv (you w)
     nfreeslots = crNumFreeSlots cr
     filtpair i itms filtdescription =
         ( (i, filtsis)
@@ -147,7 +148,10 @@ updateInventorySectionItems w =
   where
     f olditems = fromMaybe olditems $ do
         cr <- w ^? cWorld . lWorld . creatures . ix 0
-        invitms <- IM.mapWithKey (invSelectionItem' cr) <$> cr ^? crInv
+        --invitms <- IM.mapWithKey (invSelectionItem' cr) <$> cr ^? crInv
+        let invitms = IM.mapWithKey (invSelectionItem' cr)
+                $ fmap (^. _2 . locLDT . ldtValue)
+                $ invTrees'' $ cr ^. crInv
         return $ case w ^? hud . hudElement . diSections . sssExtra . sssFilters . ix (-1) . _Just of
             Just str -> IM.filter (plainRegex str) invitms
             _ -> invitms

src/Dodge/Inventory/SelectionList.hs

@@ -4,6 +4,8 @@ module Dodge.Inventory.SelectionList (
     closeObjectToSelectionItem,
 ) where
 
+import Dodge.Item.Grammar
+import Dodge.Data.ComposedItem
 import Padding
 import Dodge.Equipment.Text
 import Dodge.Data.SelectionList
@@ -13,7 +15,7 @@ import Dodge.Item.InventoryColor
 import LensHelp
 import Picture.Base
 
-invSelectionItem' :: Creature -> Int -> Item -> SelectionItem ()
+invSelectionItem' :: Creature -> Int -> ComposedItem -> SelectionItem ()
 invSelectionItem' cr i it = invSelectionItem cr i it 0
 --    SelectionItem
 --        { _siPictures = pics & ix 0 %~ (++ anyequippos ++ anyhotkey)
@@ -31,21 +33,22 @@ invSelectionItem' cr i it = invSelectionItem cr i it 0
 --        UndroppableIdentified -> itemDisplay cr it
 --        _ -> itemDisplay cr it
 
-invSelectionItem :: Creature -> Int -> Item -> Int -> SelectionItem ()
-invSelectionItem cr i it indent =
+invSelectionItem :: Creature -> Int -> ComposedItem -> Int -> SelectionItem ()
+invSelectionItem cr i ci indent =
     SelectionItem
         { _siPictures = pics & ix 0 %~ (++ anyequippos ++ anyhotkey)
-        , _siHeight = _itInvSize it
+        , _siHeight = _itInvSize itm
         , _siIsSelectable = True
         , _siColor = col
         , _siOffX = indent
         , _siPayload = ()
         }
   where
+    itm = _cItem ci
     anyhotkey = maybe [] ((' ':) .hotkeyToString) (cr ^? crInvHotkeys . ix i)
     anyequippos = maybe [] (rightPad 8 ' ' . (' ':) . eqPosText) (cr ^? crInvEquipped . ix i)
-    col = itemInvColor it
-    pics = itemDisplay cr it
+    col = itemInvColor ci
+    pics = itemDisplay cr ci
 
 hotkeyToString :: Hotkey -> String
 hotkeyToString x = case x of
@@ -79,5 +82,5 @@ closeObjectToSelectionItem e =
 --
 closeObjectToTextPictures :: Either FloorItem Button -> ([String], Color)
 closeObjectToTextPictures e = case e of
-    Left flit -> let it = _flIt flit in (basicItemDisplay it, itemInvColor it)
+    Left flit -> let it = _flIt flit in (basicItemDisplay it, itemInvColor . pciToCI $ basePCI it)
     Right bt -> ([_btText bt], yellow)

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