Make dragging items instantaneous (up to 30 items away, at least)

src/Dodge/TestString.hs

@@ -24,8 +24,12 @@ import Dodge.Data.Universe
 import qualified IntMapHelp as IM
 
 testStringInit :: Universe -> [String]
-testStringInit u = [show $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . 
-    crManipulation . manObject . imRootSelectedItem]
+testStringInit u = 
+    [show $ u ^? uvWorld . input . mouseContext . mcoDragSection
+    ,show $ u ^? uvWorld . input . mouseContext . mcoMaybeSelect
+    ,show $ u ^? uvWorld . input . mouseContext . mcoAboveSelect
+    ,show $ u ^? uvWorld . input . mouseContext . mcoBelowSelect
+    ]
 --  fromMaybe mempty $ do
 --        cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0
 --        let itms = IM.elems $ cr ^. crInv

src/Dodge/Update/Input/InGame.hs

@@ -90,16 +90,34 @@ updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
         let msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
         guard $ Just (fst sstart) == fmap fst msel || isNothing msel
         return $ w & input . mouseContext . mcoSelEnd .~ fmap snd msel
-    OverInvDrag k mmouseover ab bn -> fromMaybe w $ do
+    OverInvDrag k mmouseover ab bn -> doDrag 30 k mmouseover ab bn w
+--    OverInvDrag k mmouseover ab bn -> fromMaybe w $ do
+--        ss <- w ^? hud . hudElement . diSections . ix k . ssItems
+--        x <- mmouseover
+--        is <- w ^? hud . hudElement . diSelection . _Just . _3
+--        return $ if concurrentIS is
+--            then shiftInvItems k x ab bn is ss w
+--            else collectInvItems k is w
+    _ -> w
+  where
+    ldp = invDisplayParams w
+
+
+doDrag :: Int
+          -> Int
+          -> Maybe (Int, Int)
+          -> Maybe (Int, Int)
+          -> Maybe (Int, Int)
+          -> World
+          -> World
+doDrag 0 _ _ _ _ w = w
+doDrag n k mmouseover ab bn w = fromMaybe w $ do
         ss <- w ^? hud . hudElement . diSections . ix k . ssItems
         x <- mmouseover
         is <- w ^? hud . hudElement . diSelection . _Just . _3
         return $ if concurrentIS is
-            then shiftInvItems k x ab bn is ss w
+            then shiftInvItems' n k x ab bn is ss w
             else collectInvItems k is w
-    _ -> w
-  where
-    ldp = invDisplayParams w
 
 tryDropSelected :: Maybe (Int,Int) -> World -> Maybe World
 tryDropSelected mpos w = do
@@ -303,6 +321,32 @@ shiftInvItems k x ab bn xs ss w = setSelWhileDragging . fromMaybe w $ do
             return $ shiftInvItemsDown k xs w
         _ -> Nothing
 
+shiftInvItems' ::
+    Int -> -- recurse limit
+    Int -> -- section where drag started
+    (Int,Int) -> -- selection item mouse is over
+    Maybe (Int,Int) -> -- selection item "above" mouse position (can be same as over)
+    Maybe (Int,Int) -> -- selection item "below" mouse position (can be same as over)
+    IS.IntSet ->
+    IM.IntMap (SelectionItem a) ->
+    World ->
+    World
+shiftInvItems' n k x ab bn xs ss w = setSelWhileDragging . fromMaybe w $ do
+    let xk = fst x
+    guard $ xk == k || xk + 1 == k || xk -1 == k
+    (maxi,_) <- IS.maxView xs
+    (mini,_) <- IS.minView xs
+    case True of
+        _ | x < (k,mini) -> do
+            guard $ not . null . fst $ IM.split mini ss
+            guard $ Just (k,mini-1) /= ab
+            return . doDrag (n-1) k (Just x) ab bn $ shiftInvItemsUp k xs w
+        _ | x > (k,maxi) -> do
+            guard $ not . null . snd $ IM.split maxi ss
+            guard $ Just (k,maxi+1) /= bn
+            return . doDrag (n-1) k (Just x) ab bn $ shiftInvItemsDown k xs w
+        _ -> Nothing
+
 setSelWhileDragging :: World -> World
 setSelWhileDragging w = fromMaybe w $ do
     (i,_,xs) <- w ^? hud . hudElement . diSelection . _Just