Fix bugs in drag pickup when releasing mouse outside of inventory list

src/Dodge/Inventory/Add.hs

@@ -1,11 +1,12 @@
 {-# LANGUAGE TupleSections #-}
+
 module Dodge.Inventory.Add (
-    tryPutItemInInv,
     createItemYou,
     pickUpItem,
     pickUpItemAt,
 ) where
 
+import qualified Data.IntSet as IS
 import Control.Lens
 import Control.Monad
 import Data.Maybe
@@ -19,34 +20,34 @@ import qualified IntMapHelp as IM
 import NewInt
 
 -- should check that the item is not already in your inventory
--- this assumes that this is a floor item
-tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt,World)
+-- this assumes that this item is currently on the floor
+tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt, World)
 tryPutItemInInv cid itid w = do
     itm <- w ^? cWorld . lWorld . items . ix itid
     invid <- checkInvSlotsYou itm w
-    let itloc = InInv  
-                { _ilCrID = cid
-                , _ilInvID = invid
-                , _ilIsRoot = False
-                , _ilIsSelected = False
-                , _ilIsAttached = False
-                , _ilEquipSite = Nothing
-                }
-        newitm = itm & itLocation .~ itloc
-    return $ (invid,) $ w
-            & cWorld . lWorld %~ crUpdateItemLocations cid
--- not sure about the order of these...
-        & cWorld . lWorld . creatures . ix cid . crInv . at invid ?~ itid 
-        & cWorld . lWorld . items . at itid ?~ newitm
---        & cWorld . lWorld . itemLocations . at itid ?~ itloc
-        & cWorld . lWorld . floorItems . at itid .~ Nothing
-        & updateselectionextra
+    let itloc = InInv
+            { _ilCrID = cid
+            , _ilInvID = invid
+            , _ilIsRoot = False
+            , _ilIsSelected = False
+            , _ilIsAttached = False
+            , _ilEquipSite = Nothing
+            }
+    return $ (invid,) $
+            w
+                & cWorld . lWorld %~ crUpdateItemLocations cid
+                -- not sure about the order of these...
+                & cWorld . lWorld . creatures . ix cid . crInv . at invid ?~ itid
+                & cWorld . lWorld . items . ix itid . itLocation .~ itloc
+                & cWorld . lWorld . floorItems . at itid .~ Nothing
+                & updateselectionextra invid
   where
-    updateselectionextra
-        | cid == 0 =
-            hud . hudElement . diSelection . _Just . _3 %~ const mempty
+    updateselectionextra i
+        | cid == 0 = hud . hudElement . diSelection . _Just . _3 %~ IS.map (f i)
         | otherwise = id
-    
+    f j i | i >= _unNInt j = i + 1
+          | otherwise = i
+
 -- not sure why we have the cid here, this will probably only work for cid == 0
 tryPutItemInInvAt :: Int -> Int -> Int -> World -> Maybe World
 tryPutItemInInvAt i cid itid w = do
@@ -56,77 +57,20 @@ tryPutItemInInvAt i cid itid w = do
   where
     f j = swapInvItems (\_ _ -> Just (j -1)) j
 
----- | Pick up a specific item.
---tryPutItemInInv :: Int -> Item -> Int -> World -> Maybe (Int, World)
---tryPutItemInInv cid flit itid w = do
---    i <- checkInvSlotsYou it w
---    Just
---        ( i
---        , w
---            & cWorld . lWorld . floorItems %~ IM.delete itid
---            & cWorld . lWorld . creatures . ix cid . crInv . at 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
---        | otherwise = id
---    it = _flIt flit
---    -- 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
---                }
-
----- should select the item on the floor if no inventory space?
---createAndSelectItem :: Item -> World -> World
---createAndSelectItem itm w = case createPutItem itm w of
---    (Just i, w') ->
---        w'
---            & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (0, i)
---            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
---                .~  InInventory (SelectedItem i
---                    $ fromMaybe (error "no root item1!") $ tryGetRootItemInvID i (you w))
---    (Nothing, w') -> w'
-
---createPutItem :: Item -> World -> (Maybe Int, World)
---createPutItem it w = fromMaybe (Nothing,w) $ do
---    (i,w') <- uncurry (tryPutItemIDInInv 0) $
---        copyItemToFloorID (_crPos $ you w) (applyModules it) w
---    return (Just i, w')
-
 createItemYou :: Item -> World -> World
-createItemYou itm w = fromMaybe w' $ fmap snd $ tryPutItemInInv 0 itid w'
+createItemYou itm w = maybe w' snd $ tryPutItemInInv 0 itid w'
   where
     itid = IM.newKey $ w ^. cWorld . lWorld . items
     pos = w ^?! cWorld . lWorld . creatures . ix 0 . crPos
     w' = copyItemToFloor pos (itm & itID .~ NInt itid) w
 
--- | Pick up a specific item.
+-- the duplication is annoying...
 pickUpItem :: Int -> Int -> World -> World
 pickUpItem cid itid w = fromMaybe w $ do
-    (_,w') <- tryPutItemInInv cid itid w
     p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
-    return $ soundStart (CrSound cid) p pickUpS Nothing w'
+    soundStart (CrSound cid) p pickUpS Nothing . snd <$> tryPutItemInInv cid itid w
 
--- | Pick up a specific item.
 pickUpItemAt :: Int -> Int -> Int -> World -> World
 pickUpItemAt invid cid itid w = fromMaybe w $ do
-    w' <- tryPutItemInInvAt invid cid itid w
     p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
-    return $ soundStart (CrSound cid) p pickUpS Nothing w'
+    soundStart (CrSound cid) p pickUpS Nothing <$> tryPutItemInInvAt invid cid itid w