Improve item location code, including some error detection

ghcidOutput

@@ -1 +1 @@
-All good (619 modules, at 13:12:05)
+All good (619 modules, at 14:32:19)

src/Dodge/DoubleTree.hs

@@ -47,12 +47,38 @@ dtToLRAdj f (DT x l r) = IM.insert i (Nothing,map g l , map g r)
     i = f x
     g = f . _dtValue
 
+-- returns an adjacency map with oldest ancestor and direct parent if they exist
+-- and any left and right children
+-- allows to propogate failure in the index discovery
+dtToLRAdjEither :: (a -> Either String Int) -> DoubleTree a 
+    -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
+dtToLRAdjEither f (DT x l r) = do
+    i <- f x
+    l' <- mapM g l
+    r' <- mapM g r
+    childrenasnodes <- mapM (dtToAdjRootParentEither i i f) $ l <> r
+    return $ IM.insert i (Nothing,l' , r') 
+        $ IM.unions childrenasnodes 
+  where 
+    g = f . _dtValue
+
 dtToAdjRootParent :: Int -> Int -> (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
 dtToAdjRootParent root par f (DT x l r) = IM.insert (f x) (Just (root,par),map g l , map g r) 
     . IM.unions $ map (dtToAdjRootParent root (f x) f) $ l <> r
   where 
     g = f . _dtValue
 
+dtToAdjRootParentEither :: Int -> Int 
+    -> (a -> Either String Int) -> DoubleTree a -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
+dtToAdjRootParentEither root par f (DT x l r) = do
+    i <- f x
+    l' <- mapM g l
+    r' <- mapM g r
+    childrenasnodes <- mapM (dtToAdjRootParentEither root i f) $ l <> r
+    return $ IM.insert i (Just (root,par),l' , r') $ IM.unions childrenasnodes
+  where 
+    g = f . _dtValue
+
 ldtToIM :: (a -> Int) -> LabelDoubleTree b a -> IM.IntMap (LabelDoubleTree b a)
 ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $  l <> r
 

src/Dodge/Inventory/Add.hs

@@ -18,16 +18,6 @@ import Dodge.FloorItem
 import Dodge.Inventory.CheckSlots
 import qualified IntMapHelp as IM
 
---putItemInInvID :: Int -> Int -> World -> (Maybe Int, World)
---putItemInInvID cid flid w = fromMaybe (Nothing, w) $ do
---    flit <- w ^? cWorld . lWorld . floorItems . ix flid
---    (i, w') <- tryPutItemInInv cid flit w
---    return (Just i, w')
-
---putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item
---putItemInInvSlot = IM.insert
-----putItemInInvSlot = IM.insertWith (const $ itUse . useAmount +~ 1)
-
 tryPutItemIDInInv :: Int -> Int -> World -> Maybe (Int, World)
 tryPutItemIDInInv cid flitid w = do
     flit <- w ^? cWorld . lWorld . floorItems . ix flitid

src/Dodge/Inventory/Location.hs

@@ -1,4 +1,9 @@
 module Dodge.Inventory.Location
+    (updateRootItemID
+    , crUpdateItemLocations
+    , setInvPosFromSS
+    , tryGetRootItemInvID
+    )
     where
 import Dodge.Base.You
 import Dodge.Data.SelectionList
@@ -12,7 +17,9 @@ import Control.Applicative
 
 tryGetRootItemInvID :: Int -> Creature -> Maybe Int
 tryGetRootItemInvID i cr = do
-    let adj = invAdj (_crInv cr)
+    let adj = case invAdj' (_crInv cr) of
+            Left str -> error $ "tryToGetRootItemInvID: "++ str
+            Right x -> x
     thetree <- adj ^? ix i -- to check that the index does point to SOME item in the inventory
     thetree ^? _1 . _Just . _1 <|> Just i
 

src/Dodge/Item/Grammar.hs

@@ -1,7 +1,7 @@
 module Dodge.Item.Grammar
     (invTrees
     , invIndentIM
-    , invAdj
+    , invAdj'
     )
     where
 import Control.Applicative
@@ -92,11 +92,24 @@ invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItemStructu
 invLDT = joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems .
     fmap (singleLDT . baseCIS)
 
-invAdj :: IM.IntMap Item -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
+-- this has provoked an error: hopefully it will crop up at some point and get
-invAdj = IM.unions . fmap (dtToLRAdj getid . ldtToDT) . invLDT
+-- debugged with suitable info
+--invAdj :: IM.IntMap Item -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
+--invAdj =  IM.unions . fmap (dtToLRAdj getid . ldtToDT) . invLDT
+--  where
+--    getid (itm, _,_,_) = fromMaybe 
+--        (error ("invAdj item " ++ show (_itID itm) ++ " location:" ++ show (itm ^? itLocation . ilInvID)) )
+--        $ itm ^? itLocation . ilInvID
+
+invAdj' :: IM.IntMap Item -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
+invAdj' im = do
+    l <- mapM g $ invLDT im
+    return $ IM.unions l
   where
-    getid (itm, _,_,_) = fromMaybe (error "invAdj attempt to find item not in inventory") $
+    g = dtToLRAdjEither getid . ldtToDT
-        itm ^? itLocation . ilInvID
+    getid (itm, _,_,_) = maybe
+        (Left ("invAdj' item " ++ show ( _itID itm) ++ " location:" ++ show (itm ^? itLocation . ilInvID)) )
+        Right $ itm ^? itLocation . ilInvID
 
 invIndentIM :: IM.IntMap Item -> IM.IntMap (Item,Int, LabelDoubleTreeNodeType ComposeLinkType )
 invIndentIM = IM.fromAscList . zip [0..] . reverse . map (over _1 cisToItem) . concatMap ldtToIndentList . invLDT

src/Dodge/Render/HUD.hs

@@ -62,7 +62,10 @@ drawInventory sss w cfig = drawSelectionSections sss (invDisplayParams w) cfig
   where
     iextra = fromMaybe mempty $ do
         inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
-        return $ inventoryExtra sss cfig w (invAdj inv)
+        let x = case invAdj' inv of
+                Left str -> error $ "drawInventory: " ++ str
+                Right y -> y
+        return $ inventoryExtra sss cfig w x
 
 drawSubInventory :: SubInventory -> Configuration -> World -> Picture
 drawSubInventory subinv cfig w = case subinv of

src/Dodge/TestString.hs

@@ -20,18 +20,19 @@ import Dodge.Data.Universe
 import qualified IntMapHelp as IM
 
 testStringInit :: Universe -> [String]
-testStringInit u = (topTestPart u
+testStringInit _ = []
-    <>) $ map showh $ 
+--testStringInit u = (topTestPart u
-    (IM.toList . IM.filter (\itloc -> itloc ^? ilCrID == Just 0) $ (u ^. uvWorld . cWorld . lWorld . itemLocations)) <> ( IM.elems $ fmap h (u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv))
+--    <>) $ map showh $ 
-  where
+--    (IM.toList . IM.filter (\itloc -> itloc ^? ilCrID == Just 0) $ (u ^. uvWorld . cWorld . lWorld . itemLocations)) <> ( IM.elems $ fmap h (u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv))
-    h itm = (_itID itm, _itLocation itm)
+--  where
-    showh (x,(InInv a b c d)) = show x ++ "," ++ show a ++ "," ++ show b ++"," ++ show c ++"," ++ show d 
+--    h itm = (_itID itm, _itLocation itm)
-    showh _ = ""
+--    showh (x,(InInv a b c d)) = show x ++ "," ++ show a ++ "," ++ show b ++"," ++ show c ++"," ++ show d 
-
+--    showh _ = ""
-topTestPart :: Universe -> [String]
+--
-topTestPart u = [show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos
+--topTestPart :: Universe -> [String]
-    , maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
+--topTestPart u = [show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos
-    ]
+--    , maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
+--    ]
 
 showManObj :: ManipulatedObject -> String
 showManObj (InInventory SortInventory) = "SortInventory"

tags

@@ -4868,12 +4868,14 @@ crSpring	src/Dodge/Update.hs	643;"	f
 crStratConMatches	src/Dodge/Creature/Test.hs	72;"	f
 crToBox'	src/Dodge/Creature/ShadowBox.hs	10;"	f
 crUpdateInvidLocations	src/Dodge/Inventory/FindRoot.hs	29;"	f
+crUpdateInvidLocations	src/Dodge/Inventory/Location.hs	37;"	f
 crUpdateItemLocations	src/Dodge/Inventory/FindRoot.hs	23;"	f
+crUpdateItemLocations	src/Dodge/Inventory/Location.hs	31;"	f
 crZoneOfPoint	src/Dodge/Base/Zone.hs	54;"	f
 crZoneSize	src/Dodge/Zoning/Creature.hs	39;"	f
 craftInfo	src/Dodge/Item/Info.hs	154;"	f
 crankSlowS	src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs	420;"	f
-createAndSelectItem	src/Dodge/Inventory/Add.hs	57;"	f
+createAndSelectItem	src/Dodge/Inventory/Add.hs	47;"	f
 createArc	src/Dodge/Tesla/Arc.hs	67;"	f
 createBarrelSpark	src/Dodge/Particle/Spark.hs	21;"	f
 createBarrelSpark	src/Dodge/Spark.hs	44;"	f
@@ -4886,7 +4888,7 @@ createLightMap	src/Render.hs	26;"	f
 createNewArc	src/Dodge/Tesla/Arc.hs	76;"	f
 createPathGrid	src/Dodge/Room/Path.hs	21;"	f
 createProjectile	src/Dodge/Projectile/Create.hs	14;"	f
-createPutItem	src/Dodge/Inventory/Add.hs	67;"	f
+createPutItem	src/Dodge/Inventory/Add.hs	57;"	f
 createShieldWall	src/Dodge/Euse.hs	134;"	f
 createTorchLightOffset	src/Dodge/LightSource/Torch.hs	9;"	f
 createUnusedLinkPos	src/Dodge/Tree/Shift.hs	117;"	f
@@ -5385,9 +5387,10 @@ dropItem	src/Dodge/Creature/Action.hs	183;"	f
 dropItemKey	src/Dodge/Config/KeyConfig.hs	24;"	f
 drumMag	src/Dodge/Item/Ammo.hs	36;"	f
 dtIL	src/Dodge/DoubleTree.hs	22;"	f
-dtToAdjRootParent	src/Dodge/DoubleTree.hs	50;"	f
+dtToAdjRootParent	src/Dodge/DoubleTree.hs	64;"	f
 dtToAdjacency	src/Dodge/DoubleTree.hs	29;"	f
 dtToLRAdj	src/Dodge/DoubleTree.hs	43;"	f
+dtToLRAdjEither	src/Dodge/DoubleTree.hs	53;"	f
 dtToUpDownAdj	src/Dodge/DoubleTree.hs	35;"	f
 dummyMenuOption	src/Dodge/Menu/Option.hs	81;"	f
 duplicateItem	src/Dodge/Item/Weapon/TriggerType.hs	742;"	f
@@ -5700,7 +5703,7 @@ hatCombinations	src/Dodge/Combine/Combinations.hs	33;"	f
 head	src/DoubleStack.hs	14;"	f
 headLamp	src/Dodge/Item/Equipment.hs	118;"	f
 headLampShape	src/Dodge/Item/Draw/SPic.hs	494;"	f
-headMap	src/Dodge/DoubleTree.hs	83;"	f
+headMap	src/Dodge/DoubleTree.hs	97;"	f
 heal	src/Dodge/Item/Consumable.hs	17;"	f
 heal25	src/Dodge/Item/Consumable.hs	14;"	f
 healS	src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs	354;"	f
@@ -5824,19 +5827,20 @@ intersectSegsSeg	src/Geometry/Intersect.hs	232;"	f
 intervalList	src/Geometry.hs	315;"	f
 interweave	src/Justify.hs	17;"	f
 intsToPos	src/Dodge/Room/Modify/Girder.hs	160;"	f
-invAdj	src/Dodge/Item/Grammar.hs	95;"	f
+invAdj	src/Dodge/Item/Grammar.hs	98;"	f
+invAdj'	src/Dodge/Item/Grammar.hs	109;"	f
 invDimColor	src/Dodge/DisplayInventory.hs	140;"	f
 invDimColor	src/Dodge/Inventory/Color.hs	4;"	f
 invDisplayParams	src/Dodge/ListDisplayParams.hs	29;"	f
 invHead	src/Dodge/Render/HUD.hs	293;"	f
-invIndentIM	src/Dodge/Item/Grammar.hs	101;"	f
+invIndentIM	src/Dodge/Item/Grammar.hs	121;"	f
 invLDT	src/Dodge/Item/Grammar.hs	91;"	f
 invSelectionItem	src/Dodge/Inventory/SelectionList.hs	35;"	f
 invSelectionItem'	src/Dodge/Inventory/SelectionList.hs	17;"	f
 invShiftPointBy	src/Dodge/ShiftPoint.hs	8;"	f
 invSideEff	src/Dodge/Creature/State.hs	236;"	f
 invSize	src/Dodge/Inventory/CheckSlots.hs	40;"	f
-invTrees	src/Dodge/Item/Grammar.hs	104;"	f
+invTrees	src/Dodge/Item/Grammar.hs	124;"	f
 inventoryExtra	src/Dodge/Render/HUD.hs	186;"	f
 inventoryExtraH	src/Dodge/Render/HUD.hs	190;"	f
 inventoryX	src/Dodge/Creature.hs	115;"	f
@@ -5966,7 +5970,7 @@ lasTunnel	src/Dodge/Room/LasTurret.hs	124;"	f
 lasTunnelRunPast	src/Dodge/Room/LasTurret.hs	165;"	f
 lasTurret	src/Dodge/Placement/Instance/Turret.hs	23;"	f
 lasTurret	src/Dodge/Placements/Turret.hs	29;"	f
-lastMap	src/Dodge/DoubleTree.hs	87;"	f
+lastMap	src/Dodge/DoubleTree.hs	101;"	f
 latchkey	src/Dodge/Item/Held/Utility.hs	23;"	f
 latchkey	src/Dodge/Item/PassKey.hs	14;"	f
 launcher	src/Dodge/Item/Held/Launcher.hs	12;"	f
@@ -5977,10 +5981,10 @@ launcherX	src/Dodge/Item/Held/Launcher.hs	48;"	f
 layerNum	src/Picture/Data.hs	31;"	f
 layoutLevelFromSeed	src/Dodge/LevelGen.hs	47;"	f
 ldpVerticalSelection	src/Dodge/Update/Input/ScreenLayer.hs	90;"	f
-ldtIL	src/Dodge/DoubleTree.hs	62;"	f
+ldtIL	src/Dodge/DoubleTree.hs	76;"	f
 ldtToDT	src/Dodge/DoubleTree.hs	13;"	f
-ldtToIM	src/Dodge/DoubleTree.hs	56;"	f
+ldtToIM	src/Dodge/DoubleTree.hs	70;"	f
-ldtToIndentList	src/Dodge/DoubleTree.hs	59;"	f
+ldtToIndentList	src/Dodge/DoubleTree.hs	73;"	f
 left	src/DoubleStack.hs	16;"	f
 leftInfo	src/Dodge/Item/Info.hs	109;"	f
 leftIsParentCombine	src/Dodge/Item/Grammar.hs	57;"	f
@@ -6479,7 +6483,7 @@ pesNearSeg	src/Dodge/Zoning/Pathing.hs	37;"	f
 picAtCrPos1	src/Dodge/Render/ShapePicture.hs	99;"	f
 picFormat	src/Polyhedra.hs	22;"	f
 picMap	src/Picture/Base.hs	67;"	f
-pickUpItem	src/Dodge/Inventory/Add.hs	77;"	f
+pickUpItem	src/Dodge/Inventory/Add.hs	67;"	f
 pickUpS	src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs	444;"	f
 pickUpSound	src/Dodge/SoundLogic/Synonyms.hs	4;"	f
 picsToSelectable	src/Dodge/Render/HUD.hs	346;"	f
@@ -6637,8 +6641,8 @@ prependTwo	src/Geometry.hs	165;"	f
 pressedMBEffects	src/Dodge/Update/UsingInput.hs	27;"	f
 pressedMBEffectsNoInventory	src/Dodge/Update/UsingInput.hs	40;"	f
 pressedMBEffectsTopInventory	src/Dodge/Creature/YourControl.hs	206;"	f
-prettyDT	src/Dodge/DoubleTree.hs	92;"	f
+prettyDT	src/Dodge/DoubleTree.hs	106;"	f
-prettyLDT	src/Dodge/DoubleTree.hs	96;"	f
+prettyLDT	src/Dodge/DoubleTree.hs	110;"	f
 primeS	src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs	422;"	f
 printColumnTitles	src/Dodge/Tree/Shift.hs	142;"	f
 printColumns	src/Dodge/Tree/Shift.hs	132;"	f
@@ -7047,7 +7051,7 @@ setHotkey	src/Dodge/Hotkey.hs	38;"	f
 setInLinks	src/Dodge/RoomLink.hs	51;"	f
 setInLinksByType	src/Dodge/RoomLink.hs	54;"	f
 setInLinksPD	src/Dodge/RoomLink.hs	74;"	f
-setInvPosFromSS	src/Dodge/Inventory/Location.hs	6;"	f
+setInvPosFromSS	src/Dodge/Inventory/Location.hs	48;"	f
 setItemCharge	src/Dodge/ItEffect.hs	36;"	f
 setLayer	src/Picture/Base.hs	139;"	f
 setLinkType	src/Dodge/RoomLink.hs	60;"	f
@@ -7600,11 +7604,12 @@ tryChargeBattery	src/Dodge/Euse.hs	43;"	f
 tryCombine	src/Dodge/Update/Input/InGame.hs	252;"	f
 tryGetChannel	src/Sound.hs	96;"	f
 tryGetRootItemInvID	src/Dodge/Inventory/FindRoot.hs	10;"	f
+tryGetRootItemInvID	src/Dodge/Inventory/Location.hs	18;"	f
 tryMeleeAttack	src/Dodge/Creature/ReaderUpdate.hs	36;"	f
 tryNextLoadAction	src/Dodge/Reloading.hs	36;"	f
 tryPlay	src/Sound.hs	83;"	f
-tryPutItemIDInInv	src/Dodge/Inventory/Add.hs	31;"	f
+tryPutItemIDInInv	src/Dodge/Inventory/Add.hs	21;"	f
-tryPutItemInInv	src/Dodge/Inventory/Add.hs	37;"	f
+tryPutItemInInv	src/Dodge/Inventory/Add.hs	27;"	f
 trySeedFromClipboard	src/Dodge/Menu.hs	88;"	f
 trySiphonFuel	src/Dodge/Euse.hs	46;"	f
 trySpinByCID	src/Dodge/Projectile/Update.hs	123;"	f
@@ -7731,6 +7736,7 @@ updateRadarSweeps	src/Dodge/Update.hs	445;"	f
 updateRandNode	src/TreeHelp.hs	108;"	f
 updateRenderSplit	appDodge/Main.hs	105;"	f
 updateRootItemID	src/Dodge/Inventory/FindRoot.hs	16;"	f
+updateRootItemID	src/Dodge/Inventory/Location.hs	24;"	f
 updateScopeZoom	src/Dodge/Update/Camera.hs	129;"	f
 updateScopeZoom'	src/Dodge/Update/Camera.hs	134;"	f
 updateScrollTestValue	src/Dodge/ScrollValue.hs	6;"	f