Allow dragging of selected items in inventory

2024-10-20 11:32:37 +01:00
parent 8b6f5529ff
commit f6e32ff6ef
7 changed files with 259 additions and 158 deletions
@@ -19,19 +19,22 @@ data HUDElement
        }
    | DisplayCarte

-data MouseInventorySelection = NoMouseSel
-        | MouseInvSelect 
-            {_misSelStart :: (Int,Int), _misMaybeEnd :: Maybe (Int,Int)}
-        | MouseInvChosen 
-            {_misChosenStart :: (Int,Int), _misChosenEnd :: (Int,Int)}
+data MouseInventorySelection
+    = NoMouseSel
+    | MouseInvSelect
+        {_misSelStart :: (Int, Int), _misMaybeEnd :: Maybe (Int, Int)}
+    | MouseInvChosen
+        { _misChosenStart :: (Int, Int)
+        , _misChosenEnd :: (Int, Int)
+        }

 data SubInventory
    = NoSubInventory
        { _nsSelected :: MouseInventorySelection
-        , _nsMouseOver :: Maybe (Int,Int)
+        , _nsMouseOver :: Maybe (Int, Int)
        }
    | ExamineInventory
-    | CombineInventory { _ciSections :: SelectionSections CombinableItem }
+    | CombineInventory {_ciSections :: SelectionSections CombinableItem}
    | LockedInventory
    | DisplayTerminal {_termID :: Int}

@@ -10,7 +10,8 @@ module Dodge.Inventory (
    crInvSize,
    selectedCloseObject,
    setInvPosFromSS,
-    module Dodge.Inventory.RBList
+    module Dodge.Inventory.RBList,
+    swapInvItems,
 ) where

 import NewInt
@@ -162,18 +163,22 @@ changeSwapClose f i w = fromMaybe w $ do
            & hud . hudElement . diSections . sssExtra . sssSelPos . _Just . _2 .~ k
            & worldEventFlags . at InventoryChange ?~ ()

-changeSwapInv ::
+-- can be specialised for when we know that item i is selected
+swapInvItems ::
    (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
    Int ->
    World ->
    World
-changeSwapInv f i w = fromMaybe w $ do
+swapInvItems f i w = fromMaybe w $ do
    ss <- w ^? hud . hudElement . diSections . sssSections . ix 0 . ssItems
    k <- f i ss
+    let updateselection = case w ^? hud . hudElement . diSections . sssExtra . sssSelPos . _Just of
+            Just (0,j) | j == k -> hud . hudElement . diSections . sssExtra . sssSelPos . _Just . _2 .~ i
+            Just (0,j) | j == i -> hud . hudElement . diSections . sssExtra . sssSelPos . _Just . _2 .~ k
+            _ -> id
    return $
        w & cWorld . lWorld . creatures . ix 0 %~ updatecreature k
--            & cWorld . lWorld . creatures . ix 0 %~ updateRootItemID
-            & hud . hudElement . diSections . sssExtra . sssSelPos . _Just . _2 .~ k
+            & updateselection
            & worldEventFlags . at InventoryChange ?~ ()
        & cWorld . lWorld %~ crUpdateItemLocations 0
             & setInvPosFromSS
@@ -199,7 +204,7 @@ changeSwapInv f i w = fromMaybe w $ do

 changeSwapWith :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
 changeSwapWith f w = case w ^? hud . hudElement . diSections . sssExtra . sssSelPos . _Just of
-    Just (0, i) -> w & changeSwapInv f i
+    Just (0, i) -> w & swapInvItems f i
    Just (3, i) -> w & changeSwapClose f i
    _ -> w

@@ -9,6 +9,8 @@ module Dodge.SelectionSections (
    inverseSelSecYint,
    posSelSecYint,
    inverseSelNumPos,
+    inverseSelBoundaryUp,
+    inverseSelBoundaryDown,
 ) where

 import Control.Monad
@@ -186,5 +188,32 @@ inverseSelNumPos ::
 inverseSelNumPos cfig ldp sss (V2 x y) =
    inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y) sss

+inverseSelBoundaryUp :: 
+    Configuration ->
+    ListDisplayParams ->
+    SelectionSections a ->
+    Point2 ->
+    Maybe (Int,Int)
+inverseSelBoundaryUp cfig ldp sss (V2 _ y)  = do
+    sel <- inverseSelSecYint (posSelSecYint cfig ldp y) sss
+    let mselup = inverseSelSecYint (posSelSecYint cfig ldp y - 1) sss
+    if Just sel == mselup
+        then return $ sel & _2 +~ 1
+        else return $ sel
+
+inverseSelBoundaryDown :: 
+    Configuration ->
+    ListDisplayParams ->
+    SelectionSections a ->
+    Point2 ->
+    Maybe (Int,Int)
+inverseSelBoundaryDown cfig ldp sss (V2 _ y)  = do
+    sel <- inverseSelSecYint (posSelSecYint cfig ldp y) sss
+    let mseldown = inverseSelSecYint (posSelSecYint cfig ldp y + 1) sss
+    if Just sel == mseldown
+        then return $ sel & _2 -~ 1
+        else return sel
+
+
 --getIthPos :: Int -> IM.IntMap (SelectionItem a) -> Int
 --getIthPos i sm = sum . fmap _siHeight . fst $ IM.split i sm
@@ -21,11 +21,10 @@ import Dodge.Data.Universe
 import qualified IntMapHelp as IM

 testStringInit :: Universe -> [String]
-testStringInit u = [
-    show $ u ^? uvWorld . hud . hudElement . subInventory . nsMouseOver . _Just]
-    <> map show (IM.elems (L.postscan (L.premap _siHeight L.sum)
-        $ fromMaybe mempty $ u ^? uvWorld . hud . hudElement . diSections . sssSections . ix 0 . ssItems)
-        )
+testStringInit u = [show $ u ^? uvWorld . hud . hudElement . subInventory . nsMouseOver . _Just]
+--    <> map show (IM.elems (L.postscan (L.premap _siHeight L.sum)
+--        $ fromMaybe mempty $ u ^? uvWorld . hud . hudElement . diSections . sssSections . ix 0 . ssItems)
+--        )
 --testStringInit u = [maybe mempty show $ u ^? uvWorld . cWorld . lWorld . projectiles . ix 0 . prjUpdates . ix 3 . pjuControllerID]
 --testStringInit u = (topTestPart u
 --    <>) $ map showh $ 
@@ -6,6 +6,7 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where

+import Dodge.Inventory
 import Dodge.ListDisplayParams
 import Dodge.SelectionSections
 import Data.Monoid
@@ -32,7 +33,6 @@ import Dodge.Distortion
 import Dodge.DrWdWd
 import Dodge.EnergyBall
 import Dodge.Flame
-import Dodge.Inventory
 import Dodge.Item.Location
 import Dodge.Laser.Update
 import Dodge.LightSource.Update
@@ -295,27 +295,67 @@ checkTermDist w = fromMaybe w $ do
    return (w & hud . hudElement . subInventory .~ NoSubInventory NoMouseSel Nothing)

 updateMouseInventorySelection :: Configuration -> World -> World
-updateMouseInventorySelection cfig w
+updateMouseInventorySelection cfig w = fromMaybe w $ do
+    sss <- w ^? hud . hudElement . diSections
+    return $ updateMouseInventorySelection' sss cfig w
+
+-- check whether leftclickstart evaluates to True on very short left clicks
+updateMouseInventorySelection' :: SelectionSections a -> Configuration -> World -> World
+updateMouseInventorySelection' sss cfig w
    | leftclickstart = case msel of
        Nothing -> fromMaybe w $ do
            ysel <- mysel
            return $ w & hud . hudElement . subInventory . nsSelected .~ MouseInvSelect ysel Nothing
-        Just (i,j) -> w & hud . hudElement . subInventory . nsSelected .~
-            MouseInvChosen (i,j) (i,j)
-    | leftclickheld = w
-    | otherwise = w
+        Just p -> w & hud . hudElement . subInventory . nsSelected %~ startdrag p
+    | leftclickheld = case w ^? hud . hudElement . subInventory . nsSelected of
+        Just MouseInvSelect{} -> w 
+            & hud . hudElement . subInventory . nsSelected . misMaybeEnd .~ msel
+        Just (MouseInvChosen ssel esel)
+            | maybe False (<ssel) $ inverseSelBoundaryUp cfig ldp sss mpos -> w
+                & shiftInvItemsUp ssel esel (inverseSelBoundaryUp cfig ldp sss mpos)
+        Just (MouseInvChosen ssel esel)
+            | maybe False (>esel) $ inverseSelBoundaryDown cfig ldp sss mpos -> w
+                & shiftInvItemsDown ssel esel (inverseSelBoundaryDown cfig ldp sss mpos)
+        Just (MouseInvChosen ssel esel) -> w
+        _ -> w
+            & hud . hudElement . subInventory . nsSelected .~ NoMouseSel
+    | otherwise = case w ^? hud . hudElement . subInventory . nsSelected of
+        Just (MouseInvSelect ssel (Just esel)) -> w
+            & hud . hudElement . subInventory . nsSelected .~ MouseInvChosen (min ssel esel)
+                (max ssel esel)
+        Just (MouseInvSelect _ Nothing) -> w
+            & hud . hudElement . subInventory . nsSelected .~ NoMouseSel
+        _ -> w
  where
-    leftclickstart = w ^? input . mouseButtons . ix ButtonLeft == Just 0
-    leftclickheld = ButtonLeft `M.member` (w ^. input . mouseButtons)
+    startdrag p (MouseInvChosen s e) | s <= p && p <= e =  MouseInvChosen s e
+    startdrag p _ = MouseInvChosen p p
+    leftclickstart = w ^? input . mouseButtons . ix ButtonLeft == Just 0 && nobuttonright
+    leftclickheld = ButtonLeft `M.member` (w ^. input . mouseButtons) && nobuttonright
+    nobuttonright = not $ ButtonRight `M.member` (w ^. input . mouseButtons)
    mpos = w ^. input . mousePos
    ldp = invDisplayParams w
-    msel = do
-        sss <- msss
-        inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
-    mysel = do
-        sss <- msss
-        inverseSelSecYint (posSelSecYint cfig ldp (mpos ^. _y)) sss
-    msss = w ^? hud . hudElement . diSections
+    msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
+    mysel = inverseSelSecYint (posSelSecYint cfig ldp (mpos ^. _y)) sss
+
+shiftInvItemsUp :: (Int,Int) -> (Int,Int) -> Maybe (Int,Int) -> World -> World
+shiftInvItemsUp (_,i) (_,j) (Just (_,k)) w = w
+    & flip (foldl' f) [i..j]
+    & hud . hudElement . subInventory . nsSelected . misChosenStart . _2 -~ 1
+    & hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 -~ 1
+  where
+    f w' i' = swapInvItems g i' w'
+    g i' m = fmap fst $ IM.cycleLT i' m
+shiftInvItemsUp _ _ Nothing w = w
+
+shiftInvItemsDown :: (Int,Int) -> (Int,Int) -> Maybe (Int,Int) -> World -> World
+shiftInvItemsDown (_,i) (_,j) (Just (_,k)) w = w
+    & flip (foldl' f) (reverse [i..j])
+    & hud . hudElement . subInventory . nsSelected . misChosenStart . _2 +~ 1
+    & hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 +~ 1
+  where
+    f w' i' = swapInvItems g i' w'
+    g i' m = fmap fst $ IM.cycleGT i' m
+shiftInvItemsDown _ _ Nothing w = w

 updateMouseOverInventory :: Configuration -> World -> World
 updateMouseOverInventory cfig w = fromMaybe w $ do