Fix bugs in item locations

src/Dodge/Creature/State.hs

@@ -21,7 +21,7 @@ import Dodge.EnergyBall
 import Dodge.Euse
 import Dodge.Hammer
 import Dodge.ItEffect
-import Dodge.LightSource.Torch
+--import Dodge.LightSource.Torch
 import Dodge.Prop.Gib
 import Dodge.SoundLogic
 import Dodge.Targeting
@@ -247,24 +247,23 @@ invSideEff cr w =
             w' & maybe id (\g -> doInvEffect g it cr) (it ^? itEffect . ieInv)
 
 itemInvSideEffect :: Creature -> Item -> World -> World
-itemInvSideEffect cr it
+itemInvSideEffect _ _
+--itemInvSideEffect cr it
 --    | hastorchattach = createAttachLight cr it
     | otherwise = id
   where
 --    hastorchattach = it ^? itType . iyModules . ix ModHeldAttach == Just ATTACHTORCH && _itIsRoot it
 
-createAttachLight :: Creature -> Item -> World -> World
-createAttachLight cr it = createTorchLightOffset cr it attachoff
-  where
-    attachoff = it ^?! itDimension . dimAttachPos
+--createAttachLight :: Creature -> Item -> World -> World
+--createAttachLight cr it = createTorchLightOffset cr it attachoff
+--  where
+--    attachoff = it ^?! itDimension . dimAttachPos
 
 itemUpdate :: Creature -> Int -> Item -> Item
 itemUpdate cr i =
     updateAutoRecharge
         . (itUse %~ useUpdate)
         . (itLocation .~ InInv (_crID cr) i itmisselected itmisroot)
---        . (itIsRoot .~ itmisroot)
---        . (itIsSelected .~ itmisselected)
   where
     itmisroot = Just i == (cr ^? crManipulation . manObject . inInventory . imRootItem)
     itmisselected = Just i == (cr ^? crManipulation . manObject . inInventory . imSelectedItem)

src/Dodge/Data/Item.hs

@@ -35,8 +35,6 @@ data Item = Item
     , _itType :: ItemType
     , _itID :: Int
     , _itLocation :: ItemLocation
---    , _itIsRoot :: Bool
---    , _itIsSelected :: Bool
     , _itEffect :: ItEffect
     , _itInvSize :: Float
     , _itDimension :: ItemDimension

src/Dodge/Inventory.hs

@@ -4,7 +4,6 @@ module Dodge.Inventory (
     rmSelectedInvItem,
     rmInvItem,
     updateCloseObjects,
-    --closeObjScrollDir,
     changeSwapSel,
     scrollAugInvSel,
     crNumFreeSlots,
@@ -14,7 +13,7 @@ module Dodge.Inventory (
     module Dodge.Inventory.RBList
 ) where
 
-import Dodge.Inventory.FindRoot
+import Dodge.Inventory.Location
 import Dodge.Inventory.RBList
 import Control.Applicative
 import Data.Maybe
@@ -62,7 +61,7 @@ rmInvItem cid invid w = w
             & updateselection
             & pointcid %~ updateRootItemID
             & worldEventFlags . at InventoryChange ?~ ()
-            & updateCreatureItemLocations cid
+--            & updateCreatureItemLocations cid
   where
     pointcid = cWorld . lWorld . creatures . ix cid
 
@@ -95,14 +94,14 @@ rmInvItem cid invid w = w
         | x > invid || Just x == maxk = max 0 $ x - 1
         | otherwise = x
 
-updateCreatureItemLocations :: Int -> World -> World
-updateCreatureItemLocations crid w = fromMaybe w $ do
-    inv <- w ^? cWorld . lWorld . creatures . ix crid . crInv
-    return $ foldl' updateItemLocation w inv
-
-updateItemLocation :: World -> Item -> World
-updateItemLocation w itm = w
-    & cWorld . lWorld . itemLocations . ix (itm ^. itID) .~ itm ^. itLocation
+--updateCreatureItemLocations :: Int -> World -> World
+--updateCreatureItemLocations crid w = fromMaybe w $ do
+--    inv <- w ^? cWorld . lWorld . creatures . ix crid . crInv
+--    return $ foldl' updateItemLocation w inv
+--
+--updateItemLocation :: World -> Item -> World
+--updateItemLocation w itm = w
+--    & cWorld . lWorld . itemLocations . ix (itm ^. itID) .~ itm ^. itLocation
 
 ---- | after this the item at the inventory position will no longer exist
 --rmInvItem ::
@@ -202,18 +201,11 @@ updateCloseObjects w =
     updatebyid (Left flid) = fmap Left $ w ^? cWorld . lWorld . floorItems . ix (_flItID flid)
     updatebyid (Right btid) = fmap Right $ w ^? cWorld . lWorld . buttons . ix (_btID btid)
 
-
---closeObjScrollDir :: Float -> World -> World
---closeObjScrollDir x
---    | x > 0 = over (hud . closeObjects) rotU
---    | x < 0 = over (hud . closeObjects) rotD
---    | otherwise = id
-
 changeSwapSel :: Int -> World -> World
 changeSwapSel yi w
     | yi == 0 = w
-    | yi > 0 = foldr ($) w $ replicate yi (changeSwapWith $ f IM.cycleLT)
-    | otherwise = foldr ($) w $ replicate (negate yi) (changeSwapWith $ f IM.cycleGT)
+    | yi > 0 = (foldr ($) w $ replicate yi (changeSwapWith $ f IM.cycleLT))
+    | otherwise = (foldr ($) w $ replicate (negate yi) (changeSwapWith $ f IM.cycleGT))
   where
     f g i m = fst <$> g i m
 
@@ -243,17 +235,16 @@ changeSwapInv f i w = fromMaybe w $ do
     k <- f i ss
     return $
         w & cWorld . lWorld . creatures . ix 0 %~ updatecreature k
-            & cWorld . lWorld . creatures . ix 0 %~ updateRootItemID
+--            & cWorld . lWorld . creatures . ix 0 %~ updateRootItemID
             & hud . hudElement . diSections . sssExtra . sssSelPos . _Just . _2 .~ k
             & worldEventFlags . at InventoryChange ?~ ()
+        & cWorld . lWorld %~ crUpdateItemLocations 0
+             & setInvPosFromSS
+        & cWorld . lWorld %~ crUpdateItemLocations 0 -- the double application is inefficient, but necessary without further changes
+    -- a rethink is maybe in order
   where
---    updateLeftInvSel k li
---        | i == li = k
---        | k == li = i
---        | otherwise = li
     updatecreature k =
         (crInv %~ IM.safeSwapKeys i k)
---            . (crLeftInvSel . lisMPos . _Just %~ updateLeftInvSel k)
             . (crManipulation . manObject . inInventory . imSelectedItem .~ k)
             . (crInvEquipped %~ IM.safeSwapKeys i k)
             . swapSite i k
@@ -282,24 +273,7 @@ scrollAugInvSel yi w
         w & hud . hudElement . diSections %~ scrollSelectionSections yi
             & worldEventFlags . at InventoryChange ?~ ()
             & setInvPosFromSS
-
-setInvPosFromSS :: World -> World
-setInvPosFromSS w =
-    w
-        & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject .~ thesel
-  where
-    thesel = fromMaybe SelNothing $ do
-        sss <- w ^? hud . hudElement . diSections
-        (i, j) <- sss ^? sssExtra . sssSelPos . _Just
-        case i of
-            (-1) -> Just $ InInventory SortInventory
-            --0 -> Just $ InInventory (SelItem j (getRootItemID i (you w)))
-            0 -> Just $ InInventory (SelectedItem j (getRootItemID j (you w)))
-            1 -> Just SelNothing
-            2 -> Just $ InNearby SortNearby
-            3 -> Just $ InNearby $ SelCloseObject j
-            _ -> error "selection out of bounds"
-
+            & cWorld . lWorld %~ crUpdateItemLocations 0
 
 
 selectedCloseObject :: World -> Maybe (Either FloorItem Button)

src/Dodge/Inventory/Add.hs

@@ -6,7 +6,7 @@ module Dodge.Inventory.Add (
 ) where
 
 import Dodge.SoundLogic
-import Dodge.Inventory.FindRoot
+import Dodge.Inventory.Location
 --import Dodge.Item.Grammar
 import Control.Lens
 import Data.Maybe
@@ -24,9 +24,9 @@ import qualified IntMapHelp as IM
 --    (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)
+--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
@@ -43,7 +43,10 @@ tryPutItemInInv cid flit w = case maybeInvSlot of
             , w
                 & updateItLocation i
                 & cWorld . lWorld . floorItems %~ IM.delete (_flItID flit)
-                & cWorld . lWorld . creatures . ix cid . crInv %~ putItemInInvSlot i it
+                -- & cWorld . lWorld . creatures . ix cid . crInv %~ IM.insert i it
+                & cWorld . lWorld . creatures . ix cid . crInv . at i ?~ it
+                & setInvPosFromSS
+                & cWorld . lWorld %~ crUpdateItemLocations cid
             )
   where
     it = _flIt flit
@@ -57,7 +60,8 @@ createAndSelectItem itm w = case createPutItem itm w of
         w'
             & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (0, i)
             & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
-                .~ InInventory (SelectedItem i (getRootItemID i (you w)))
+                .~  InInventory (SelectedItem i 
+                    $ fromMaybe (error "no root item1!") $ tryGetRootItemInvID i (you w))
     (Nothing, w') -> w'
 
 createPutItem :: Item -> World -> (Maybe Int, World)
@@ -66,8 +70,8 @@ createPutItem it w = fromMaybe (Nothing,w) $ do
         copyItemToFloorID (_crPos $ you w) (applyModules it) w
     return (Just i, w')
 
-pickUpItemID :: Int -> Int -> World -> World
-pickUpItemID cid flid w = pickUpItem cid (w ^?! cWorld . lWorld . floorItems . ix flid) w
+--pickUpItemID :: Int -> Int -> World -> World
+--pickUpItemID cid flid w = pickUpItem cid (w ^?! cWorld . lWorld . floorItems . ix flid) w
 
 -- | Pick up a specific item.
 pickUpItem :: Int -> FloorItem -> World -> World

src/Dodge/Inventory/FindRoot.hs

@@ -1,17 +0,0 @@
-module Dodge.Inventory.FindRoot where
-
-import Dodge.Item.Grammar
-import Dodge.Data.Creature
-import Data.Maybe
-import Control.Lens
-
-getRootItemID :: Int -> Creature -> Int
-getRootItemID i cr = fromMaybe i $ do
-    let adj = invAdj (_crInv cr)
-    adj ^? ix i . _1 . _Just . _1
-
-updateRootItemID :: Creature -> Creature
-updateRootItemID cr = fromMaybe cr $ do
-    i <- cr ^? crManipulation . manObject . inInventory . imSelectedItem
-    return $ cr & crManipulation . manObject . inInventory . imRootItem .~
-        getRootItemID i cr

src/Dodge/Item/Weapon/TriggerType.hs

@@ -367,7 +367,6 @@ useAmmoAmount amAmount eff item cr = fromMaybe id $ do
     leftitms <- item ^? ldtLeft
     mag <- lookup (AmmoInLink 0 atype) leftitms
     magid <- mag ^? ldtValue . itLocation . ilInvID
---    invid <- ams ^? ix 0 . itLocation . ipInvID
     return $ eff item cr
         . (cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix magid . itUse . amagLoadStatus . iaLoaded -~ amAmount)
 

src/Dodge/TestString.hs

@@ -20,8 +20,27 @@ import Dodge.Data.Universe
 import qualified IntMapHelp as IM
 
 testStringInit :: Universe -> [String]
-testStringInit u = map show $ 
-    (IM.toList . IM.filter (\itloc -> itloc ^? ilCrID == Just 0) $ (u ^. uvWorld . cWorld . lWorld . itemLocations)) <> IM.toList ( fmap _itLocation (u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv))
+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"
+showManObj (InInventory (SelectedItem x y)) = "SelItem: "++ show x++ " Root: "++show y
+showManObj (SelNothing) = "SelNothing"
+showManObj ((InNearby SortNearby)) = "SortNearby"
+showManObj (InNearby (SelCloseObject x)) = "Close " ++ show x
+
+
 --testStringInit u = fromMaybe mempty $ do
 --    inv <- fmap invLDT $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv
 --    invitm <- inv ^? ix 1