Work on selections when picking up/droping items

src/Dodge/Inventory/Add.hs

@@ -6,9 +6,9 @@ module Dodge.Inventory.Add (
     pickUpItemAt,
 ) where
 
+import qualified IntSetHelp as IS
 import Dodge.Data.SelectionList
 import Linear
-import qualified Data.IntSet as IS
 import Control.Lens
 import Control.Monad
 import Data.Maybe
@@ -22,8 +22,8 @@ import qualified IntMapHelp as IM
 import NewInt
 
 -- this assumes that this item is currently on the floor
-tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt, World)
-tryPutItemInInv cid itid w = do
+tryPutItemInInv :: Maybe Int -> Int -> Int -> World -> Maybe (NewInt InvInt, World)
+tryPutItemInInv mcipos cid itid w = do
     itm <- w ^? cWorld . lWorld . items . ix itid
     invid <- checkInvSlotsYou itm w
     let itloc = InInv
@@ -42,8 +42,18 @@ tryPutItemInInv cid itid w = do
                 & cWorld . lWorld . items . ix itid . itLocation .~ itloc
                 & cWorld . lWorld . floorItems . at itid .~ Nothing
                 & updateselectionextra invid
+                & updatecloseitemset
+                & maybeselect invid
                 & cWorld . highlightItems . at itid ?~ 20
   where
+    maybeselect invid = fromMaybe id $ do
+        i <- mcipos
+        is <- w ^? hud . diSections . ix 3 . ssSet
+        guard $ i `IS.member` is
+        return $ hud . diSections . ix 0 . ssSet %~ IS.insert (invid ^. unNInt)
+    updatecloseitemset = fromMaybe id $ do
+        i <- mcipos
+        return $ hud . diSections . ix 3 . ssSet %~ IS.deleteShift i
     updateselectionextra i
 --        | cid == 0 = (hud . diSelection . _Just . slSet %~ IS.map (f i))
         | cid == 0 = (hud . diSections . ix 0 . ssSet %~ IS.map (f i))
@@ -53,28 +63,32 @@ tryPutItemInInv cid itid w = do
           | 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
-    (j, w') <- tryPutItemInInv cid itid w
+tryPutItemInInvAt :: Maybe Int -> Int -> Int -> Int -> World -> Maybe World
+tryPutItemInInvAt mcipos i cid itid w = do
+    (j, w') <- tryPutItemInInv mcipos cid itid w
     guard (i <= _unNInt j)
     return $ foldr f w' [i + 1 .. _unNInt j]
   where
     f j = swapInvItems (\_ _ -> Just (j -1)) j
 
 createItemYou :: Item -> World -> World
-createItemYou itm w = maybe w' snd $ tryPutItemInInv 0 itid w'
+createItemYou itm w = maybe w' snd $ tryPutItemInInv Nothing 0 itid w'
   where
     itid = IM.newKey $ w ^. cWorld . lWorld . items
     pos = w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy
     w' = copyItemToFloor pos (itm & itID .~ NInt itid) w
 
 -- the duplication is annoying...
-pickUpItem :: Int -> Int -> World -> World
-pickUpItem cid itid w = fromMaybe w $ do
+pickUpItem :: Int -> (Int,Int) -> World -> World
+pickUpItem cid (i,itid) w = fromMaybe w $ do
     p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
-    soundStart (CrSound cid) p pickUpS Nothing . snd <$> tryPutItemInInv cid itid w
+    soundStart (CrSound cid) p pickUpS Nothing . snd <$> tryPutItemInInv (Just i) cid itid w
 
-pickUpItemAt :: Int -> Int -> Int -> World -> World
-pickUpItemAt invid cid itid w = fromMaybe w $ do
+pickUpItemAt :: Int -> Int -> (Int,Int) -> World -> World
+pickUpItemAt invid cid (i,itid) w = fromMaybe w $ do
     p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
-    soundStart (CrSound cid) p pickUpS Nothing <$> tryPutItemInInvAt invid cid itid w
+    soundStart (CrSound cid) p pickUpS Nothing <$> tryPutItemInInvAt (Just i) invid cid itid w
+        & _Just . hud . diSections . ix 0 . ssSet %~ IS.map f
+  where
+    f j | j >= invid = j +1
+        | otherwise = j