Tweak mouse over display

src/Dodge/Update/Input/InGame.hs

@@ -3,6 +3,7 @@ module Dodge.Update.Input.InGame (
     updateMouseInGame,
 ) where
 
+import Data.Foldable
 import Dodge.ListDisplayParams
 import Control.Applicative
 import Control.Monad
@@ -91,11 +92,35 @@ updateUseInputInGame u = updateFunctionKeys $ case u ^. uvWorld . hud . hudEleme
 updateMouseInGame :: Configuration -> World -> World
 updateMouseInGame cfig w = case w ^? input . mouseButtons . ix ButtonLeft of
     Just 0 -> updateMouseClickInGame cfig w
-    Just _ -> updateMouseHeldInGame w
-    Nothing -> w
+    Just _ -> updateMouseHeldInGame cfig w
+    Nothing -> case w ^? input . mouseButtonsReleased . ix ButtonLeft of
+        Just 0 -> updateMouseReleaseInGame w
+        _ -> w
 
-updateMouseHeldInGame :: World -> World
-updateMouseHeldInGame w = w
+updateMouseHeldInGame :: Configuration -> World -> World
+updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
+    OverInvDragSelect{} -> fromMaybe w $ do
+        sss <- w ^? hud . hudElement . diSections
+        let msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
+        return $ w & input . mouseContext . mcoSelEnd .~ msel
+    OverInvDrag -> fromMaybe w $ do
+        sss <- w ^? hud . hudElement . diSections
+        let mpos = w ^. input . mousePos
+        sel <- w ^? hud . hudElement . diSelection . _Just
+        x <- w ^? hud . hudElement . diSelectionExtra
+        return $ w & shiftInvItems sel x cfig mpos ldp sss
+    _ -> w
+  where
+    ldp = invDisplayParams w
+
+updateMouseReleaseInGame :: World -> World
+updateMouseReleaseInGame w = case w ^. input . mouseContext of 
+    OverInvDragSelect ssel (Just esel) ->
+            w & input . mouseContext .~ MouseInGame
+                & hud . hudElement . diSelectionExtra
+                    .~ (max (snd ssel) (snd esel) - min (snd ssel) (snd esel))
+                & augInvDirectSelect (min ssel esel)
+    _ -> w
 
 updateMouseClickInGame :: Configuration -> World -> World
 updateMouseClickInGame cfig w = case w ^. input . mouseContext of
@@ -152,6 +177,37 @@ startDrag (a, b) w = fromMaybe (augInvDirectSelect (a, b) $ setmichosen 0 w) $ d
         (input . mouseContext .~ OverInvDrag)
             . (hud . hudElement . diSelectionExtra .~ x)
 
+shiftInvItems ::
+    (Int, Int) ->
+    Int ->
+    Configuration ->
+    Point2 ->
+    ListDisplayParams ->
+    IM.IntMap (SelectionSection a) ->
+    World ->
+    World
+shiftInvItems topsel x cfig mpos ldp sss w = case inverseSelBoundaryUp cfig ldp sss mpos of
+    Just p | p < topsel -> shiftInvItemsUp topsel x w
+    _ -> case inverseSelBoundaryDown cfig ldp sss mpos of
+        Just p | p > (topsel & _2 +~ x) -> shiftInvItemsDown topsel x w
+        _ -> w
+
+shiftInvItemsUp :: (Int, Int) -> Int -> World -> World
+shiftInvItemsUp (_, i) x w = foldl' f w [i .. i + x]
+  where
+    f w' i' = swapInvItems g i' w'
+    g i' m = fst <$> IM.lookupLT i' m
+
+shiftInvItemsDown :: (Int, Int) -> Int -> World -> World
+shiftInvItemsDown (_, i) x w = fromMaybe w $ do
+    guard . isJust $
+        w ^? hud . hudElement . diSections . ix 0 . ssItems . ix (i + x + 1)
+    return $ foldl' f w $ reverse [i .. i + x]
+  where
+    f w' i' = swapInvItems g i' w'
+    g i' m = fst <$> IM.lookupGT i' m
+
+
 updateFunctionKeys :: Universe -> Universe
 updateFunctionKeys u =
     M.foldlWithKey'