Major item refactor, still broken

src/Dodge/Inventory/Location.hs

@@ -4,9 +4,12 @@ module Dodge.Inventory.Location (
     setInvPosFromSS,
 ) where
 
+import Dodge.Data.ComposedItem
+import Dodge.Data.DoubleTree
+import Data.Foldable
 import Control.Applicative
 import Control.Lens
-import Data.IntMap.Merge.Strict
+--import Data.IntMap.Merge.Strict
 import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Base.You
@@ -26,43 +29,43 @@ tryGetRootAttachedFromInvID invid im = do
 
 -- this assumes the creature inventory is well formed, specifically the
 -- location ids
-tryGetRootItemInvID :: Int -> Creature -> Maybe Int
-tryGetRootItemInvID i cr = do
-    let adj = invAdj (_crInv cr)
+tryGetRootItemInvID :: IM.IntMap Item -> Int -> Creature -> Maybe Int
+tryGetRootItemInvID m i cr = do
+    let adj = invAdj $ fmap (\k -> m ^?! ix k) (_crInv cr)
     theroot <- adj ^? ix i
     theroot ^? _1 . _Just . _1 <|> Just i
 
-updateRootItemID :: Creature -> Creature
-updateRootItemID cr = fromMaybe cr $ do
+updateRootItemID :: IM.IntMap Item -> Creature -> Creature
+updateRootItemID m cr = fromMaybe cr $ do
     i <- cr ^? crManipulation . manObject . imSelectedItem
-    j <- tryGetRootItemInvID i cr
+    j <- tryGetRootItemInvID m i cr
     return $ cr & crManipulation . manObject . imRootSelectedItem .~ j
 
 -- the following assumes that the crManipulation is correct
 crUpdateItemLocations :: Int -> LWorld -> LWorld
 crUpdateItemLocations crid lw = fromMaybe lw $ do
     mo <- lw ^? creatures . ix crid . crManipulation . manObject
-    crinv <- lw ^? creatures . ix crid . crInv
+    itids <- lw ^? creatures . ix crid . crInv
+    let crinv = IM.restrictKeys  (lw ^. items) (IS.fromList $ IM.elems itids)
     return $ crSetRoots crid $ IM.foldlWithKey' (crUpdateInvidLocations mo crid) lw crinv
 
 crSetRoots :: Int -> LWorld -> LWorld
 crSetRoots cid w = fromMaybe w $ do
     inv <- w ^? creatures . ix cid . crInv
-    return $
-        w & creatures . ix cid . crInv
-            %~ merge
-                dropMissing
-                preserveMissing
-                (zipWithMatched f)
-                (invIMDT inv)
+    let cinv = invIMDT $ fmap (\i -> w ^?! items . ix i) inv
+    return $ foldl' f (foldl' g w inv) cinv
   where
-    f _ _ = itLocation . ilIsRoot .~ True
+    g w' i = w' & items . ix i . itLocation . ilIsRoot .~ False
+    f :: LWorld -> DTree OItem -> LWorld
+    f w' x = w'
+        & items . ix (x ^. dtValue . _1 . itID . unNInt) . itLocation . ilIsRoot .~ True
 
 crUpdateInvidLocations :: ManipulatedObject -> Int -> LWorld -> Int -> Item -> LWorld
 crUpdateInvidLocations mo crid lw invid itm =
     lw
-        & creatures . ix crid . crInv . ix invid . itLocation .~ newloc
-        & itemLocations %~ IM.insert itid newloc
+        & creatures . ix crid . crInv . ix invid .~ itid -- . itLocation .~ newloc
+        & items . ix invid .~ (itm & itLocation .~ newloc)
+--        & itemLocations %~ IM.insert itid newloc
   where
     itid = itm ^. itID . unNInt
     newloc =
@@ -72,8 +75,8 @@ crUpdateInvidLocations mo crid lw invid itm =
             , _ilIsRoot = Just invid == mo ^? imRootSelectedItem
             , _ilIsSelected = Just invid == mo ^? imSelectedItem
             , _ilIsAttached = invid `IS.member` (mo ^. imAttachedItems)
-            , _ilEquipSite = lw ^? creatures . ix crid . crInv . ix invid 
-                . itLocation . ilEquipSite . _Just
+            , _ilEquipSite = do
+                lw ^? items . ix itid . itLocation . ilEquipSite . _Just
             }
 
 -- this should be looked at, as it is sometimes used in functions that need not
@@ -89,7 +92,8 @@ setInvPosFromSS w =
         case i of
             (-1) -> Just SortInventory
             0 -> do
-                (rootid, aset) <- tryGetRootAttachedFromInvID j (you w ^. crInv)
+                (rootid, aset) <- tryGetRootAttachedFromInvID j (fmap (\k -> w ^?! cWorld . lWorld . items . ix k ) 
+                    $ you w ^. crInv)
                 return
                     SelectedItem
                         { _imSelectedItem = j