Start simplifying mouse inventory selection

2024-10-24 11:47:51 +01:00
parent 9e3d8ae6b0
commit 5ca440ca67
9 changed files with 270 additions and 227 deletions
@@ -24,8 +24,7 @@ data MouseInventorySelection
    | MouseInvSelect
        {_misSelStart :: (Int, Int), _misMaybeEnd :: Maybe (Int, Int)}
    | MouseInvChosen
-        { _misChosenStart :: (Int, Int)
-        , _misChosenEnd :: (Int, Int)
+        { _misExtra :: Int
        }

 data SubInventory
@@ -162,7 +162,7 @@ defaultDisplayInventory :: HUDElement
 defaultDisplayInventory =
    DisplayInventory
        { _subInventory = NoSubInventory 
-            {_nsSelected = MouseInvChosen (0,0) (0,2)
+            {_nsSelected = NoMouseSel
            , _nsMouseOver = Just (0,3)
            }
        , _diSections = defaultInvSections
@@ -5,6 +5,7 @@ module Dodge.Inventory (
    destroyInvItem,
    updateCloseObjects,
    changeSwapSel,
+    augInvDirectSelect,
    scrollAugInvSel,
    crNumFreeSlots,
    crInvSize,
@@ -14,9 +15,6 @@ module Dodge.Inventory (
    swapInvItems,
 ) where

-import NewInt
-import Dodge.Inventory.Location
-import Dodge.Inventory.RBList
 import Control.Applicative
 import Data.Maybe
 import Dodge.Base
@@ -26,19 +24,23 @@ import Dodge.Data.World
 import Dodge.Euse
 import Dodge.Inventory.CheckSlots
 import Dodge.Inventory.CloseObject
+import Dodge.Inventory.Location
+import Dodge.Inventory.RBList
 import Dodge.ItEffect
 import Dodge.SelectionSections
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
 import ListHelp
+import NewInt
+
 --import Padding

 -- TODO check what happens to selection index when dropping non-selected items

 -- should consider never fully destroying items, but assigning a flag saying how
 -- they were moved from play
-destroyInvItem :: 
+destroyInvItem ::
    Int ->
    -- | Inventory position
    Int ->
@@ -58,31 +60,30 @@ rmInvItem ::
    Int ->
    World ->
    World
-rmInvItem cid invid w = w
-            & doanyitemeffect
-            & dounequipfunction         --the ordering of these is
-            & pointcid . crInv %~ f     -- important
-
-            & removeAnySlotEquipment
-            & pointcid . crEquipment . each %~ g
-            & pointcid . crInvEquipped %~ IM.delete invid
-            & pointcid . crInvEquipped %~ IM.mapKeys g
-
-            & removeanyactivation
-            & pointcid . crHotkeys . each %~ g
-            & pointcid . crInvHotkeys %~ IM.delete invid
-            & pointcid . crInvHotkeys %~ IM.mapKeys g
-
-            & updateselection
-            & pointcid %~ updateRootItemID
-            & worldEventFlags . at InventoryChange ?~ ()
--            & updateCreatureItemLocations cid
+rmInvItem cid invid w =
+    w
+        & doanyitemeffect
+        & dounequipfunction --the ordering of these is
+        & pointcid . crInv %~ f -- important
+        & removeAnySlotEquipment
+        & pointcid . crEquipment . each %~ g
+        & pointcid . crInvEquipped %~ IM.delete invid
+        & pointcid . crInvEquipped %~ IM.mapKeys g
+        & removeanyactivation
+        & pointcid . crHotkeys . each %~ g
+        & pointcid . crInvHotkeys %~ IM.delete invid
+        & pointcid . crInvHotkeys %~ IM.mapKeys g
+        & updateselection
+        & pointcid %~ updateRootItemID
+        & worldEventFlags . at InventoryChange ?~ ()
  where
+    --            & updateCreatureItemLocations cid
+
    pointcid = cWorld . lWorld . creatures . ix cid

    updateselection
        | cid == 0 && cr ^? crManipulation . manObject . imSelectedItem == Just invid =
-            scrollAugInvSel (-1) . scrollAugInvSel 1-- . updateInventorySectionItems
+            scrollAugInvSel (-1) . scrollAugInvSel 1 -- . updateInventorySectionItems
        | otherwise =
            pointcid . crManipulation . manObject . imSelectedItem %~ g

@@ -131,12 +132,17 @@ updateCloseObjects w =
            . filter ((/=) BtNoLabel . _btState)
            . IM.elems
            $ w ^. cWorld . lWorld . buttons
-    currentClose = filt $ map Left (IM.elems $ w ^. cWorld . lWorld . floorItems . unNIntMap) 
-        ++ activeButtons
+    currentClose =
+        filt $
+            map Left (IM.elems $ w ^. cWorld . lWorld . floorItems . unNIntMap)
+                ++ activeButtons
    oldClose = filt $ mapMaybe updatebyid $ w ^. hud . closeObjects
    oldCloseFiltered = intersectBy closeObjEq oldClose currentClose
-    updatebyid (Left flid) = fmap Left $ w ^? cWorld . lWorld . floorItems . unNIntMap 
-        . ix (_unNInt $ _flItID flid)
+    updatebyid (Left flid) =
+        fmap Left $
+            w
+                ^? cWorld . lWorld . floorItems . unNIntMap
+                    . ix (_unNInt $ _flItID flid)
    updatebyid (Right btid) = fmap Right $ w ^? cWorld . lWorld . buttons . ix (_btID btid)

 changeSwapSel :: Int -> World -> World
@@ -173,17 +179,17 @@ 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
+            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
            & 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
+            & 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
  where
    updatecreature k =
        (crInv %~ IM.safeSwapKeys i k)
@@ -208,6 +214,14 @@ changeSwapWith f w = case w ^? hud . hudElement . diSections . sssExtra . sssSel
    Just (3, i) -> w & changeSwapClose f i
    _ -> w

+augInvDirectSelect :: (Int, Int) -> World -> World
+augInvDirectSelect (i, j) w =
+    w
+        & hud . hudElement . diSections . sssExtra . sssSelPos .~ Just (i, j)
+        & worldEventFlags . at InventoryChange ?~ ()
+        & setInvPosFromSS
+        & cWorld . lWorld %~ crUpdateItemLocations 0
+
 scrollAugInvSel :: Int -> World -> World
 scrollAugInvSel yi w
    | yi == 0 = w
@@ -217,7 +231,6 @@ scrollAugInvSel yi w
            & setInvPosFromSS
            & cWorld . lWorld %~ crUpdateItemLocations 0

-
 selectedCloseObject :: World -> Maybe (Either FloorItem Button)
 selectedCloseObject w = do
    i <-
@@ -35,8 +35,7 @@ import Dodge.SelectionSections.Draw
 import Geometry
 import qualified IntMapHelp as IM
 import Justify
--import ListHelp
--import Padding
+import Data.List (sort)
 import Picture
 import SDL (MouseButton (..))

@@ -64,6 +63,7 @@ drawInventory sss w cfig =
        <> translateScreenPos cfig (ldp ^. ldpPos)
            (drawDIMouseOver w)
        <> drawDISelections w cfig
+        <> drawDISelections' w cfig
  where
    ldp = invDisplayParams w
    iextra = fromMaybe mempty $ do
@@ -83,7 +83,13 @@ drawDIMouseOver w = fromMaybe mempty $ do
 getMouseInvSel :: World -> Maybe ((Int,Int),(Int,Int))
 getMouseInvSel w = case w ^? hud . hudElement . subInventory . nsSelected of
    Just (MouseInvSelect s (Just e)) -> Just (s,e)
-    Just (MouseInvChosen s e) -> Just (s,e)
+    _ -> Nothing
+
+getMouseInvSel' :: World -> Maybe ((Int,Int),(Int,Int))
+getMouseInvSel' w = case w ^? hud . hudElement . subInventory . nsSelected of
+    Just (MouseInvChosen x) -> do
+        (i,j) <- w ^? hud . hudElement . diSections . sssExtra . sssSelPos . _Just
+        return ((i,j),(i,j+x))
    _ -> Nothing

 drawDISelections :: World -> Configuration -> Picture
@@ -93,7 +99,16 @@ drawDISelections w cfig = fromMaybe mempty $ do
    let idp = invDisplayParams w
    tp <- selNumPosCardinal NorthWest8 cfig idp sss i j
    bp <- selNumPosCardinal SouthWest8 cfig idp sss a b
-    return . color red $ line [tp,bp]
+    return . color red . line $ sort [tp,bp]
+
+drawDISelections' :: World -> Configuration -> Picture
+drawDISelections' w cfig = fromMaybe mempty $ do
+    ((i,j),(a,b)) <- getMouseInvSel' w
+    sss <- w ^? hud . hudElement . diSections
+    let idp = invDisplayParams w
+    tp <- selNumPosCardinal NorthEast8 cfig idp sss i j
+    bp <- selNumPosCardinal SouthEast8 cfig idp sss a b
+    return . color green . line $ sort [tp,bp]


 drawSubInventory :: SubInventory -> Configuration -> World -> Picture
@@ -41,11 +41,12 @@ ssScrollUsing ::
    SelectionSections a
 ssScrollUsing g sss =
    sss & sssExtra . sssSelPos
-        .~ fmap f (ssScrollUsing' g (sss & sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable)))
+        .~ fmap f (ssScrollSelectable g 
+                (sss & sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable)))
  where
    f (i, j, _) = (i, j)

-ssScrollUsing' ::
+ssScrollSelectable ::
    ( Int ->
      Int ->
      SelectionSections a ->
@@ -53,7 +54,7 @@ ssScrollUsing' ::
    ) ->
    SelectionSections a ->
    Maybe (Int, Int, SelectionItem a)
-ssScrollUsing' f sss = l <|> ssLookupMin sss
+ssScrollSelectable f sss = l <|> ssLookupMin sss
  where
    l = do
        (i, j) <- sss ^? sssExtra . sssSelPos . _Just
@@ -188,6 +189,7 @@ inverseSelNumPos ::
 inverseSelNumPos cfig ldp sss (V2 x y) =
    inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y) sss

+
 inverseSelBoundaryUp :: 
    Configuration ->
    ListDisplayParams ->
@@ -305,21 +305,21 @@ updateMouseInventorySelection' sss cfig w
    | leftclickstart = case msel of
        Nothing -> fromMaybe w $ do
            ysel <- mysel
-            return $ w & hud . hudElement . subInventory . nsSelected .~ MouseInvSelect ysel Nothing
-        Just p -> w & hud . hudElement . subInventory . nsSelected %~ startdrag p
+            return $ w & hud . hudElement . subInventory . nsSelected 
+                .~ MouseInvSelect ysel Nothing
+        Just p -> startDrag p w
    | 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{}) -> w
+            w & hud . hudElement . subInventory . nsSelected . misMaybeEnd .~ msel
+        Just (MouseInvChosen x) -> shiftInvItems x w
+--            | 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{}) -> w
        _ ->
            w
                & hud . hudElement . subInventory . nsSelected .~ NoMouseSel
@@ -327,16 +327,13 @@ updateMouseInventorySelection' sss cfig w
        Just (MouseInvSelect ssel (Just esel)) ->
            w
                & hud . hudElement . subInventory . nsSelected
-                    .~ MouseInvChosen
-                        (min ssel esel)
-                        (max ssel esel)
+                  .~ MouseInvChosen (max (snd ssel) (snd esel) - min (snd ssel) (snd esel))
+                & augInvDirectSelect (min ssel esel)
        Just (MouseInvSelect _ Nothing) ->
            w
                & hud . hudElement . subInventory . nsSelected .~ NoMouseSel
        _ -> w
  where
-    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)
@@ -345,27 +342,41 @@ updateMouseInventorySelection' sss cfig w
    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{} w =
-    w
-        & flip (foldl' f) [i .. j]
-        & hud . hudElement . subInventory . nsSelected . misChosenStart . _2 -~ 1
-        & hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 -~ 1
+startDrag :: (Int,Int) -> World -> World
+startDrag (a,b) w = fromMaybe (augInvDirectSelect (a,b) $ setmichosen 0 w) $ do
+    (i,j) <- w ^? hud . hudElement . diSections . sssExtra . sssSelPos . _Just
+    x <- w ^? hud . hudElement . subInventory . nsSelected . misExtra
+    guard $ i == a && b >= j && b <= j + x
+    return w
  where
-    f w' i' = swapInvItems g i' w'
-    g i' m = fmap fst $ IM.cycleLT i' m
-shiftInvItemsUp _ _ Nothing w = w
+    setmichosen x = hud . hudElement . subInventory . nsSelected .~ MouseInvChosen x
+    
+--     & hud . hudElement . subInventory . nsSelected %~ startdrag p

-shiftInvItemsDown :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> World -> World
-shiftInvItemsDown (_, i) (_, j) Just{} 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
+shiftInvItems :: Int -> World -> World
+shiftInvItems x w = w
+
+--shiftInvItemsUp :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> World -> World
+--shiftInvItemsUp (_, i) (_, j) Just{} 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{} 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