Improve item pickup by dragging

src/Dodge/Inventory/Add.hs

@@ -4,8 +4,11 @@ module Dodge.Inventory.Add (
     --createAndSelectItem,
     createItemYou,
     pickUpItem,
+    pickUpItemAt,
 ) where
 
+import Dodge.Inventory.Swap
+import Control.Monad
 import NewInt
 import Dodge.SoundLogic
 import Dodge.Inventory.Location
@@ -25,6 +28,16 @@ tryPutFloorItemIDInInv cid flitid w = do
     flit <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix (_unNInt flitid)
     tryPutItemInInv cid flit w
 
+-- 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
+    guard (i <= j)
+    return $ foldr f w' [i+1..j]
+  where
+    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
@@ -93,3 +106,9 @@ pickUpItem :: Int -> FloorItem -> World -> World
 pickUpItem cid flit w =
     maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing . snd) $
         tryPutItemInInv cid flit w
+
+-- | Pick up a specific item.
+pickUpItemAt :: Int -> Int -> FloorItem -> World -> World
+pickUpItemAt invid cid flit w =
+    maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing) $
+        tryPutItemInInvAt invid cid flit w

src/Dodge/Inventory/Swap.hs

@@ -0,0 +1,97 @@
+module Dodge.Inventory.Swap (
+    swapInvItems,
+    swapAnyExtraSelection
+) where
+
+import Dodge.SoundLogic
+import Dodge.Item.Grammar
+import Dodge.Base.You
+import Dodge.Inventory.Location
+import Dodge.Data.DoubleTree
+import Sound.Data
+import qualified Data.IntSet as IS
+import Data.Maybe
+import Control.Lens
+import Dodge.Data.SelectionList
+import qualified IntMapHelp as IM
+import Dodge.Data.World
+import Control.Monad
+
+-- can be specialised for when we know that item i is selected
+swapInvItems ::
+    (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
+    Int ->
+    World ->
+    World
+swapInvItems f i w = fromMaybe w $ do
+    ss <- w ^? hud . hudElement . diSections . ix 0 . ssItems
+    k <- f i ss
+    let updateselection = case w ^? hud . hudElement . diSelection . _Just of
+            Just (0, j) | j == k -> hud . hudElement . diSelection . _Just . _2 .~ i
+            Just (0, j) | j == i -> hud . hudElement . diSelection . _Just . _2 .~ k
+            _ -> id
+    return $
+        w
+            & swapAnyExtraSelection i k
+            & checkConnection InventorySound disconnectItemS i k
+            & cWorld . lWorld . creatures . ix 0 %~ updatecreature k
+            & updateselection
+            & 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
+            & checkConnection InventoryConnectSound connectItemS i k
+  where
+    -- & checkconnect k InventoryConnectSound connectItemS
+
+    --    cpos = fromMaybe 0 $ w ^? cWorld . lWorld . creatures . ix 0 . crPos
+    --    checkconnect k stype s w'
+    --        | p (i+1) || p (i-1)
+    --            || p (k+1) || p (k-1) = soundStart stype cpos s Nothing w'
+    --        | otherwise = w'
+    --      where
+    --        p j = maybe False not $ w' ^? cWorld . lWorld . creatures . ix 0 . crInv . ix j . itLocation . ilIsRoot
+    updatecreature k =
+        (crInv %~ IM.safeSwapKeys i k)
+            . (crManipulation . manObject . imSelectedItem .~ k)
+            . (crInvEquipped %~ IM.safeSwapKeys i k)
+            . swapSite i k
+            . swapSite k i
+            . (crInvHotkeys %~ IM.safeSwapKeys i k)
+            . swapSite' i k
+            . swapSite' k i
+    cr = you w
+    swapSite a b = case cr ^? crInvEquipped . ix a of
+        Just epos -> crEquipment . ix epos .~ b
+        Nothing -> id
+    swapSite' a b = case cr ^? crInvHotkeys . ix a of
+        Just epos -> crHotkeys . ix epos .~ b
+        Nothing -> id
+
+swapAnyExtraSelection :: Int -> Int -> World -> World
+swapAnyExtraSelection i k w = fromMaybe w $ do
+    is <- w ^? hud . hudElement . diSelectionExtra
+    let f = if i `IS.member` is then IS.insert k else id
+        g = if k `IS.member` is then IS.insert i else id
+    return $
+        w & hud . hudElement . diSelectionExtra
+            %~ (f . g . IS.delete i . IS.delete k)
+
+checkConnection :: SoundOrigin -> SoundID -> Int -> Int -> World -> World
+checkConnection so s i j w = fromMaybe w $ do
+    inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
+    cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
+    let locs = allInvLocs inv
+    iit <- locs ^? ix i . _2
+    jit <- locs ^? ix j . _2
+    guard $ isConnected iit || isConnected jit
+    return $ soundStart so cpos s Nothing w
+
+isConnected :: LocationLDT b a -> Bool
+isConnected x = case x ^. locLdtContext of
+    TopLDT ->
+        not (null $ x ^. locLDT . ldtRight)
+            || not (null $ x ^. locLDT . ldtLeft)
+    _ -> True
+