Commit before only putting item locations in single itemLocations intmap

ghcidOutput

@@ -1 +1 @@
-All good (620 modules, at 22:36:40)
+All good (620 modules, at 09:25:41)

src/Dodge/Debug/Terminal.hs

@@ -40,7 +40,7 @@ applyTerminalCommandArguments :: String -> [String] -> Universe -> Universe
 applyTerminalCommandArguments command args u = case command of
     "IT" -> fromMaybe u $ do
         (ibt, n) <- parseItem args
-        return $ u & uvWorld %~ flip (foldr ($)) (replicate n (snd . createPutItem (itemFromBase ibt)))
+        return $ u & uvWorld %~ flip (foldr ($)) (replicate n (snd . createItemYou (itemFromBase ibt)))
     "DEX" -> fromMaybe u $ do
         x <- readMaybe =<< args ^? _head
         return $ u & ypoint . crStatistics . dexterity .~ x

src/Dodge/FloorItem.hs

@@ -23,14 +23,14 @@ copyItemToFloorID pos it w =
     (,) (NInt flid) $
         w'
             & cWorld . lWorld . floorItems . unNIntMap %~ IM.insert flid theflit
-            & cWorld . lWorld . itemLocations . ix (_itID it) .~ OnFloor (NInt flid)
+            & cWorld . lWorld . itemLocations %~ IM.insert (_itID it) (OnFloor $ NInt flid)
   where
     (p', w') = findWallFreeDropPoint (_dimRad $ _itDimension it) pos w
     rot = fst . randomR (- pi, pi) $ _randGen w
     flid = IM.newKey . _unNIntMap . _floorItems . _lWorld $ _cWorld w
     theflit =
         FlIt
-            { _flIt = it
+            { _flIt = it & itLocation .~ OnFloor (NInt flid)
             , _flItPos = p'
             , _flItRot = rot
             , _flItID = NInt flid

src/Dodge/Inventory.hs

@@ -3,6 +3,7 @@ module Dodge.Inventory (
     checkInvSlotsYou,
     rmSelectedInvItem,
     rmInvItem,
+    destroyInvItem,
     updateCloseObjects,
     changeSwapSel,
     scrollAugInvSel,
@@ -35,6 +36,20 @@ import ListHelp
 
 -- TODO check what happens to selection index when dropping non-selected items
 
+-- should consider never fully destroying items, but assigning a flag saying how
+-- they were moved from play
+destroyInvItem :: 
+    Int ->
+    -- | Inventory position
+    Int ->
+    World ->
+    World
+destroyInvItem cid invid w = rmInvItem cid invid w & removeitloc
+  where
+    removeitloc = fromMaybe id $ do
+        itid <- w ^? cWorld . lWorld . creatures . ix cid . crInv . ix invid . itID
+        return $ cWorld . lWorld . itemLocations . at itid .~ Nothing
+
 -- | after this the item at the inventory position will no longer exist
 rmInvItem ::
     -- | Creature id

src/Dodge/Inventory/Add.hs

@@ -1,7 +1,8 @@
 module Dodge.Inventory.Add (
     tryPutItemInInv,
-    createPutItem,
+    --createPutItem,
-    createAndSelectItem,
+    --createAndSelectItem,
+    createItemYou,
     pickUpItem,
 ) where
 
@@ -11,16 +12,16 @@ import Dodge.Inventory.Location
 --import Dodge.Item.Grammar
 import Control.Lens
 import Data.Maybe
-import Dodge.Base.You
+--import Dodge.Base.You
-import Dodge.Combine.Module
+--import Dodge.Combine.Module
-import Dodge.Data.SelectionList
+--import Dodge.Data.SelectionList
 import Dodge.Data.World
 import Dodge.FloorItem
 import Dodge.Inventory.CheckSlots
 import qualified IntMapHelp as IM
 
-tryPutItemIDInInv :: Int -> NewInt FloorInt -> World -> Maybe (Int, World)
+tryPutFloorItemIDInInv :: Int -> NewInt FloorInt -> World -> Maybe (Int, World)
-tryPutItemIDInInv cid flitid w = do
+tryPutFloorItemIDInInv cid flitid w = do
     flit <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix (_unNInt flitid)
     tryPutItemInInv cid flit w
 
@@ -34,8 +35,9 @@ tryPutItemInInv cid flit w = case maybeInvSlot of
             , w
                 & updateItLocation i
                 & cWorld . lWorld . floorItems . unNIntMap %~ IM.delete (_unNInt $ _flItID flit)
-                -- & cWorld . lWorld . creatures . ix cid . crInv %~ IM.insert i it
+                & cWorld . lWorld . creatures . ix cid . crInv %~ IM.insert i it
-                & cWorld . lWorld . creatures . ix cid . crInv . at i ?~ it
+                -- I forget whether using "at" rather than "IM.insert" here caused problems
+                -- & cWorld . lWorld . creatures . ix cid . crInv . at i ?~ it
                 & setInvPosFromSS
                 & cWorld . lWorld %~ crUpdateItemLocations cid
             )
@@ -45,24 +47,33 @@ tryPutItemInInv cid flit w = case maybeInvSlot of
     updateItLocation invid w' = w' & cWorld . lWorld . itemLocations . ix (_itID it) 
         .~ InInv cid invid False False
 
-createAndSelectItem :: Item -> World -> World
+---- should select the item on the floor if no inventory space?
-createAndSelectItem itm w = case createPutItem itm w of
+--createAndSelectItem :: Item -> World -> World
-    (Just i, w') ->
+--createAndSelectItem itm w = case createPutItem itm w of
-        w'
+--    (Just i, w') ->
-            & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (0, i)
+--        w'
-            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
+--            & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (0, i)
-                .~  InInventory (SelectedItem i 
+--            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
-                    $ fromMaybe (error "no root item1!") $ tryGetRootItemInvID i (you w))
+--                .~  InInventory (SelectedItem i 
-    (Nothing, w') -> w'
+--                    $ fromMaybe (error "no root item1!") $ tryGetRootItemInvID i (you w))
+--    (Nothing, w') -> w'
 
-createPutItem :: Item -> World -> (Maybe Int, World)
+--createPutItem :: Item -> World -> (Maybe Int, World)
-createPutItem it w = fromMaybe (Nothing,w) $ do
+--createPutItem it w = fromMaybe (Nothing,w) $ do
-    (i,w') <- uncurry (tryPutItemIDInInv 0) $
+--    (i,w') <- uncurry (tryPutItemIDInInv 0) $
-        copyItemToFloorID (_crPos $ you w) (applyModules it) w
+--        copyItemToFloorID (_crPos $ you w) (applyModules it) w
-    return (Just i, w')
+--    return (Just i, w')
+
+createItemYou :: Item -> World -> (ItemLocation, World)
+createItemYou itm w = fromMaybe (OnFloor flid, w') $ do
+    (invid, w'') <- tryPutFloorItemIDInInv 0 flid w'
+    itloc <- w'' ^? cWorld . lWorld . creatures . ix 0 . crInv . ix invid . itLocation
+    return (itloc, w'')
+  where
+    itid = IM.newKey $ w ^. cWorld . lWorld . itemLocations
+    pos = w ^?! cWorld . lWorld . creatures . ix 0 . crPos
+    (flid,w') = copyItemToFloorID pos (itm & itID .~ itid) 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/Item/Grammar.hs

@@ -108,7 +108,7 @@ invAdj' im = do
   where
     g = dtToLRAdjEither getid . ldtToDT
     getid (itm, _,_,_) = maybe
-        (Left ("invAdj' item " ++ show ( _itID itm) ++ " location:" ++ show (itm ^? itLocation . ilInvID)) )
+        (Left ("invAdj' item " ++ show ( _itID itm) ++ " location: " ++ show (itm ^? itLocation)) )
         Right $ itm ^? itLocation . ilInvID
 
 invIndentIM :: IM.IntMap Item -> IM.IntMap (Item,Int, LabelDoubleTreeNodeType ComposeLinkType )

src/Dodge/Update/Input/InGame.hs

@@ -253,7 +253,7 @@ tryCombine :: SelectionSections CombinableItem -> World -> World
 tryCombine sss w = fromMaybe w $ do
     (i, j) <- sss ^? sssExtra . sssSelPos . _Just
     CombinableItem is it _ <- sss ^? sssSections . ix i . ssItems . ix j . siPayload
-    return $ createAndSelectItem it (foldr (rmInvItem 0) w (sort is))
+    return $ snd (createItemYou it (foldr (destroyInvItem 0) w (sort is)))
         & cWorld . lWorld . creatures . ix 0 . crHammerPosition .~ HammerDown
 
 maybeExitCombine :: Universe -> Universe