Fix close floor item bug

src/Dodge/Inventory/Add.hs

@@ -1,27 +1,21 @@
 module Dodge.Inventory.Add (
     tryPutItemInInv,
-    --createPutItem,
-    --createAndSelectItem,
     createItemYou,
     pickUpItem,
     pickUpItemAt,
 ) where
 
-import Dodge.Inventory.Swap
-import Control.Monad
-import NewInt
-import Dodge.SoundLogic
-import Dodge.Inventory.Location
---import Dodge.Item.Grammar
 import Control.Lens
+import Control.Monad
 import Data.Maybe
---import Dodge.Base.You
---import Dodge.Combine.Module
---import Dodge.Data.SelectionList
 import Dodge.Data.World
 import Dodge.FloorItem
 import Dodge.Inventory.CheckSlots
+import Dodge.Inventory.Location
+import Dodge.Inventory.Swap
+import Dodge.SoundLogic
 import qualified IntMapHelp as IM
+import NewInt
 
 tryPutFloorItemIDInInv :: Int -> Int -> World -> Maybe (Int, World)
 tryPutFloorItemIDInInv cid i w = do
@@ -31,49 +25,48 @@ tryPutFloorItemIDInInv cid i w = do
 -- not sure why we have the cid here, this will probably only work for cid == 0
 tryPutItemInInvAt :: Int -> Int -> FloorItem -> World -> Maybe World
 tryPutItemInInvAt i cid flit w = do
-    (j,w') <- tryPutItemInInv cid flit w
+    (j, w') <- tryPutItemInInv cid flit w
     guard (i <= j)
-    return $ foldr f w' [i+1..j]
+    return $ foldr f w' [i + 1 .. j]
   where
-    f j = swapInvItems (\_ _ -> Just (j-1)) j
-    
+    f j = swapInvItems (\_ _ -> Just (j -1)) j
 
 -- | Pick up a specific item.
 tryPutItemInInv :: Int -> FloorItem -> World -> Maybe (Int, World)
-tryPutItemInInv cid flit w = case maybeInvSlot of
-    Nothing -> Nothing
-    Just i ->
-        Just
-            ( i
-            , w
-                & cWorld . lWorld . floorItems %~ IM.delete (flit ^. flIt . itID . unNInt)
-                & cWorld . lWorld . creatures . ix cid . crInv %~ IM.insert i it
-                & updateItLocation i
-                -- I forget whether using "at" rather than "IM.insert" here caused problems
-                -- & cWorld . lWorld . creatures . ix cid . crInv . at i ?~ it
-                -- note item locations are updated twice: first for the ilInvID,
-                -- second for the root/selected item bools
-                & cWorld . lWorld %~ crUpdateItemLocations cid
-                & setInvPosFromSS
-                & updateselectionextra
-                & cWorld . lWorld %~ crUpdateItemLocations cid
-            )
+tryPutItemInInv cid flit w = do
+    i <- checkInvSlotsYou it w
+    Just
+        ( i
+        , w
+            & cWorld . lWorld . floorItems %~ IM.delete (flit ^. flIt . itID . unNInt)
+            & cWorld . lWorld . creatures . ix cid . crInv %~ IM.insert i it
+            & updateItLocation i
+            -- I forget whether using "at" rather than "IM.insert" here caused problems
+            -- & cWorld . lWorld . creatures . ix cid . crInv . at i ?~ it
+            -- note item locations are updated twice: first for the ilInvID,
+            -- second for the root/selected item bools
+            & cWorld . lWorld %~ crUpdateItemLocations cid
+            & setInvPosFromSS
+            & updateselectionextra
+            & cWorld . lWorld %~ crUpdateItemLocations cid
+        )
   where
-    updateselectionextra | cid == 0 
-            = hud . hudElement . diSelection . _Just . _3 %~ const mempty
+    updateselectionextra
+        | cid == 0 =
+            hud . hudElement . diSelection . _Just . _3 %~ const mempty
         | otherwise = id
     it = _flIt flit
-    maybeInvSlot = checkInvSlotsYou it w
     -- not sure if the following is necessary
-    updateItLocation invid w' = w' & cWorld . lWorld . itemLocations . ix (_unNInt $ _itID it) 
-        .~ InInv 
-            {_ilCrID = cid
-            , _ilInvID = invid
-            , _ilIsRoot = False
-            , _ilIsSelected = False
-            , _ilIsAttached = False
-            , _ilEquipSite = Nothing
-            }
+    updateItLocation invid w' =
+        w' & cWorld . lWorld . itemLocations . ix (_unNInt $ _itID it)
+            .~ InInv
+                { _ilCrID = cid
+                , _ilInvID = invid
+                , _ilIsRoot = False
+                , _ilIsSelected = False
+                , _ilIsAttached = False
+                , _ilEquipSite = Nothing
+                }
 
 ---- should select the item on the floor if no inventory space?
 --createAndSelectItem :: Item -> World -> World
@@ -82,7 +75,7 @@ tryPutItemInInv cid flit w = case maybeInvSlot of
 --        w'
 --            & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (0, i)
 --            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
---                .~  InInventory (SelectedItem i 
+--                .~  InInventory (SelectedItem i
 --                    $ fromMaybe (error "no root item1!") $ tryGetRootItemInvID i (you w))
 --    (Nothing, w') -> w'
 
@@ -101,7 +94,6 @@ createItemYou itm w = fromMaybe (OnFloor, w') $ do
     itid = IM.newKey $ w ^. cWorld . lWorld . itemLocations
     pos = w ^?! cWorld . lWorld . creatures . ix 0 . crPos
     w' = copyItemToFloorID pos (itm & itID .~ NInt itid) w
-    
 
 -- | Pick up a specific item.
 pickUpItem :: Int -> FloorItem -> World -> World

src/Dodge/Placement/PlaceSpot.hs

@@ -4,6 +4,7 @@
 -}
 module Dodge.Placement.PlaceSpot (placeSpot) where
 
+import NewInt
 import Color
 import LensHelp
 import Control.Monad.State
@@ -110,7 +111,8 @@ placeSpotID' ps pt w = case pt of
     PutTerminal tm -> plNewUpID (cWorld . lWorld . terminals) tmID tm w
     PutFlIt itm -> let i = IM.newKey (w ^. cWorld . lWorld . itemLocations)
         in (i, w & cWorld . lWorld . itemLocations . at i ?~ OnFloor
-            & cWorld . lWorld . floorItems . at i ?~ createFlIt p rot itm
+            & cWorld . lWorld . floorItems . at i ?~ createFlIt p rot 
+                (itm & itID .~ NInt i)
             )
 --        plNewUpID
 --            (cWorld . lWorld . floorItems . unNIntMap)

src/Dodge/Room/Tutorial.hs

@@ -45,7 +45,7 @@ tutAnoTree =
     OnwardList $
         [ AnTree $ return $ tToBTree "teststart" $ return $ cleatOnward corridor
         , AnTree $ tutDrop
-        , AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
+--        , AnTree $ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , AnTree corDoor
         , AnTree $ tutRooms
         , AnTree $ tutDrop
@@ -57,7 +57,7 @@ tutDrop :: State LayoutVars (MetaTree Room String)
 tutDrop = do
     x <- shuffleLinks $ roomNgon 6 100
     y <- decontamRoom
-    return $ tToBTree "TutDrop" $ treePost [x,y,roomRectAutoLinks 40 100]
+    return $ tToBTree "TutDrop" $ treePost [x,y,cleatOnward $ roomRectAutoLinks 40 100]
 
 tutRooms :: State LayoutVars (MetaTree Room String)
 tutRooms = do

src/Dodge/TestString.hs

@@ -26,9 +26,12 @@ import Control.Lens
 import Dodge.Data.Universe
 import qualified IntMapHelp as IM
 import qualified Data.Map.Strict as M
+import NewInt
 
 testStringInit :: Universe -> [String]
-testStringInit _ = []
+testStringInit u = map show (IM.keys $ u ^. uvWorld . cWorld . lWorld . itemLocations)
+    <> map show (IM.keys $ u ^. uvWorld . cWorld . lWorld . floorItems)
+    <> map show (u ^. uvWorld . hud . closeItems)
 -- map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g)
 --  where
 --    g db = (pz,z,norm v)