Commit before separating close objects/items

ghcidOutput

@@ -1,30 +1,25 @@
-/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:124:1-15: warning: [-Wunused-top-binds]
-    Defined but not used: ‘tryDropSelected’
+/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:128:9-18: warning: [-Wunused-local-binds]
+    Defined but not used: ‘nfreeslots’
     |
-124 | tryDropSelected w = do
-    | ^^^^^^^^^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:131:1-17: warning: [-Wunused-top-binds]
-    Defined but not used: ‘tryPickupSelected’
+128 |     let nfreeslots = crNumFreeSlots cr
+    |         ^^^^^^^^^^
+/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:130:5-6: warning: [-Wunused-matches]
+    Defined but not used: ‘xs’
     |
-131 | tryPickupSelected w = do
-    | ^^^^^^^^^^^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:135:19: warning: [-Wunused-matches]
+130 |     xs <- w ^? hud . hudElement . diSelectionExtra
+    |     ^^
+/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:131:19: warning: [-Wunused-matches]
     Defined but not used: ‘x’
     |
-135 |     OverInvDrag 3 x <- w ^? input . mouseContext
+131 |     OverInvDrag 3 x <- w ^? input . mouseContext
     |                   ^
+/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:137:17: warning: [-Wunused-matches]
+    Defined but not used: ‘i’
+    |
+137 |     OverInvDrag i mpos -> 
+    |                 ^
 /home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:209:9: warning: [-Wunused-matches]
     Defined but not used: ‘j’
     |
 209 |     (i, j) <- w ^? hud . hudElement . diSelection . _Just
     |         ^
-/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:227:1-12: warning: [-Wunused-top-binds]
-    Defined but not used: ‘dragInvItems’
-    |
-227 | dragInvItems j is cfig mpos ldp sss w
-    | ^^^^^^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Update/Input/InGame.hs:297:1-13: warning: [-Wunused-top-binds]
-    Defined but not used: ‘shiftInvItems’
-    |
-297 | shiftInvItems j xs cfig mpos ldp sss w = case inverseSelBoundaryUp cfig ldp sss mpos of
-    | ^^^^^^^^^^^^^

src/Dodge/Creature/Action.hs

@@ -14,7 +14,6 @@ module Dodge.Creature.Action (
     sizeSelf,
     youDropItem,
     pickUpItem,
-    --    pickUpItemID,
 ) where
 
 import Control.Applicative

src/Dodge/Render/Picture.hs

@@ -84,8 +84,11 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
     MouseMenuClick {} -> drawMenuClick 5
     MouseMenuCursor -> drawMenuCursor 5
     MouseInGame -> drawPlus 5
+    OverInvDrag 0 (Just (3,_)) -> drawDragDrop 5
+    OverInvDrag 0 Nothing -> drawDragDrop 5
     OverInvDrag 0 (Just (0,_)) -> drawDrag 5
-    OverInvDrag 0 _ -> drawDragDrop 5
+    OverInvDrag 0 _ -> drawEmptySet 5
+--    OverInvDrag 0 _ -> drawDragDrop 5
     OverInvDrag 3 (Just (3,_)) -> drawDrag 5
     OverInvDrag 3 _ -> drawDragPickup 5
     OverInvDrag _ _ -> drawEmptySet 5

src/Dodge/Update/Input/InGame.hs

@@ -105,7 +105,7 @@ updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
         x <- mmouseover
         is <- w ^? hud . hudElement . diSelectionExtra
         return $ if concurrentIS is
-            then shiftInvItems' k x is ss w
+            then shiftInvItems k x is ss w
             else collectInvItems is w
 --        let mpos = w ^. input . mousePos
 --        return $ w & dragInvItems k xs cfig mpos ldp sss
@@ -113,34 +113,34 @@ updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
   where
     ldp = invDisplayParams w
 
-dropSelected :: World -> World
-dropSelected w = fromMaybe w $ do
+tryDropSelected :: Maybe (Int,Int) -> World -> Maybe World
+tryDropSelected mpos w = do
+    guard $ maybe True (\(i,_) -> i == 3) mpos
     cr <- w ^? cWorld . lWorld . creatures . ix 0
     (0, _) <- w ^? hud . hudElement . diSelection . _Just
     xs <- w ^? hud . hudElement . diSelectionExtra
     return $ IS.foldr (dropItem cr) w xs
 
-tryDropSelected :: World -> Maybe World
-tryDropSelected w = do
-    cr <- w ^? cWorld . lWorld . creatures . ix 0
-    (0, _) <- w ^? hud . hudElement . diSelection . _Just
-    xs <- w ^? hud . hudElement . diSelectionExtra
-    return $ IS.foldr (dropItem cr) w xs
-
-tryPickupSelected :: World -> Maybe World
-tryPickupSelected w = do
+tryPickupSelected :: Maybe (Int,Int) -> World -> Maybe World
+tryPickupSelected mpos w = do
+    guard $ maybe True (\(i,_) -> i == 0) mpos
     cr <- w ^? cWorld . lWorld . creatures . ix 0
+    let nfreeslots = crNumFreeSlots cr
     (3, _) <- w ^? hud . hudElement . diSelection . _Just
     xs <- w ^? hud . hudElement . diSelectionExtra
     OverInvDrag 3 x <- w ^? input . mouseContext
-    return $ IS.foldr (dropItem cr) w xs
+    return w
+--    return $ IS.foldr (dropItem cr) w xs
 
 updateMouseReleaseInGame :: World -> World
 updateMouseReleaseInGame w = case w ^. input . mouseContext of
-    OverInvDrag i mpos -> fromMaybe (dropSelected w & input . mouseContext .~ MouseInGame) $ do
-        j <- mpos
-        guard $ fst j == i
-        return $ w & input . mouseContext .~ OverInvSelect j
+    OverInvDrag i mpos -> 
+        input . mouseContext .~ MouseInGame $
+        fromMaybe w $ tryDropSelected mpos w <|> tryPickupSelected mpos w
+--    OverInvDrag i mpos -> fromMaybe (dropSelected w & input . mouseContext .~ MouseInGame) $ do
+--        j <- mpos
+--        guard $ fst j == i
+--        return $ w & input . mouseContext .~ OverInvSelect j
     OverInvDragSelect _ Nothing ->
         w & input . mouseContext .~ MouseInGame
             & hud . hudElement . diSelectionExtra .~ mempty
@@ -215,21 +215,6 @@ startDrag (a, b) w = fromMaybe (augInvDirectSelect (a, b) $ setmichosen mempty w
         (input . mouseContext .~ OverInvDrag a (Just (a, b)))
             . (hud . hudElement . diSelectionExtra .~ x)
 
-dragInvItems ::
-    Int ->
-    IS.IntSet ->
-    Configuration ->
-    Point2 ->
-    ListDisplayParams ->
-    IM.IntMap (SelectionSection a) ->
-    World ->
-    World
-dragInvItems j is cfig mpos ldp sss w
-    | nonconcurrent = collectInvItems is w
-    | otherwise = shiftInvItems j is cfig mpos ldp sss w
-  where
-    nonconcurrent = not $ concurrentIS is
-
 concurrentIS :: IS.IntSet -> Bool
 concurrentIS = go . IS.minView
   where
@@ -247,14 +232,14 @@ collectInvItems is w = fromMaybe w $ do
         (k, ks) <- IS.minView js
         return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'
 
-shiftInvItems' ::
+shiftInvItems ::
     Int ->
     (Int,Int) ->
     IS.IntSet ->
     IM.IntMap (SelectionItem a) ->
     World ->
     World
-shiftInvItems' k x xs ss w = fromMaybe w $ do
+shiftInvItems k x xs ss w = fromMaybe w $ do
     (maxi,_) <- IS.maxView xs
     (mini,_) <- IS.minView xs
     if x < (k,mini)
@@ -267,50 +252,6 @@ shiftInvItems' k x xs ss w = fromMaybe w $ do
             maxss <- IM.lookupMax ss
             guard (maxi < fst maxss)
             return $ shiftInvItemsDown k xs w
---    if 
---    Just p -> fromMaybe w $ do
---        (k,_) <- IS.minView xs
---        guard $ p < (j,k)
---        ss <- sss ^? ix j . ssItems
---        minsss <- IM.lookupMin ss
---        guard (k > fst minsss)
---        return $ shiftInvItemsUp j xs w
---    _ -> case inverseSelBoundaryDown cfig ldp sss mpos of
---        Just p -> fromMaybe w $ do
---            (k,_) <- IS.maxView xs
---            guard $ p > (j,k)
---            ss <- sss ^? ix j . ssItems
---            maxsss <- IM.lookupMax ss
---            guard (k < fst maxsss)
---            return $ shiftInvItemsDown j xs w
---        _ -> w
-
-shiftInvItems ::
-    Int ->
-    IS.IntSet ->
-    Configuration ->
-    Point2 ->
-    ListDisplayParams ->
-    IM.IntMap (SelectionSection a) ->
-    World ->
-    World
-shiftInvItems j xs cfig mpos ldp sss w = case inverseSelBoundaryUp cfig ldp sss mpos of
-    Just p -> fromMaybe w $ do
-        (k,_) <- IS.minView xs
-        guard $ p < (j,k)
-        ss <- sss ^? ix j . ssItems
-        minsss <- IM.lookupMin ss
-        guard (k > fst minsss)
-        return $ shiftInvItemsUp j xs w
-    _ -> case inverseSelBoundaryDown cfig ldp sss mpos of
-        Just p -> fromMaybe w $ do
-            (k,_) <- IS.maxView xs
-            guard $ p > (j,k)
-            ss <- sss ^? ix j . ssItems
-            maxsss <- IM.lookupMax ss
-            guard (k < fst maxsss)
-            return $ shiftInvItemsDown j xs w
-        _ -> w
 
 shiftInvItemsUp :: Int -> IS.IntSet -> World -> World
 shiftInvItemsUp j is w = IS.foldl' f w is