Improve item location code, including some error detection

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])
-invAdj = IM.unions . fmap (dtToLRAdj getid . ldtToDT) . invLDT
+-- this has provoked an error: hopefully it will crop up at some point and get
+-- 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") $
-        itm ^? itLocation . ilInvID
+    g = dtToLRAdjEither getid . ldtToDT
+    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
-    <>) $ map showh $ 
-    (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))
-  where
-    h itm = (_itID itm, _itLocation itm)
-    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
-    , maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
-    ]
+testStringInit _ = []
+--testStringInit u = (topTestPart u
+--    <>) $ map showh $ 
+--    (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))
+--  where
+--    h itm = (_itID itm, _itLocation itm)
+--    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
+--    , maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
+--    ]
 
 showManObj :: ManipulatedObject -> String
 showManObj (InInventory SortInventory) = "SortInventory"