Fix bugs in drag pickup when releasing mouse outside of inventory list

src/Dodge/Data/LWorld.hs

@@ -99,7 +99,6 @@ import Picture.Data
 data LWorld = LWorld
     { _creatures :: IM.IntMap Creature
     , _creatureGroups :: IM.IntMap CrGroupParams
---    , _itemLocations :: IM.IntMap ItemLocation
     , _items :: IM.IntMap Item
     , _clouds :: [Cloud]
     , _dusts :: [Dust]

src/Dodge/FloorItem.hs

@@ -7,23 +7,19 @@ import Dodge.Data.World
 import Dodge.Item.InvSize
 import Geometry
 import LensHelp
---import qualified IntMapHelp as IM
 import NewInt
 import System.Random
 
 -- | Copy an item to the floor
 copyItemToFloor :: Point2 -> Item -> World -> World
-copyItemToFloor pos it w =
+copyItemToFloor p it w =
     w'
-        & cWorld . lWorld . floorItems . at (_unNInt $ _itID it) ?~ theflit
+        & cWorld . lWorld . floorItems . at (it ^. itID . unNInt) ?~ FlIt q r
-        & cWorld . lWorld . items . at (_unNInt $ _itID it) ?~ (it & itLocation .~ OnFloor)
+        & cWorld . lWorld . items . at (it ^. itID . unNInt) ?~ (it & itLocation .~ OnFloor)
-        & hud . closeItems .:~ _itID it
+        & hud . closeItems .:~ _itID it -- puts item at top of close items
   where
-    --            & hud . hudElement . diSections . ix 3 . ssOffset .~ 0
+    (q, w') = findWallFreeDropPoint (_dimRad $ itDim it) p w
-    -- ensures dropped item is at the top of the close item selection list
+    r = fst . randomR (- pi, pi) $ _randGen w
-    (p', w') = findWallFreeDropPoint (_dimRad $ itDim it) pos w
-    rot = fst . randomR (- pi, pi) $ _randGen w
-    theflit = FlIt{_flItPos = p', _flItRot = rot}
 
 cardinalVectors :: [Point2]
 cardinalVectors = [ V2 1 0 , V2 0 1 , V2 (-1) 0 , V2 0 (-1) ]

src/Dodge/Inventory/Add.hs

@@ -1,11 +1,12 @@
 {-# LANGUAGE TupleSections #-}
+
 module Dodge.Inventory.Add (
-    tryPutItemInInv,
     createItemYou,
     pickUpItem,
     pickUpItemAt,
 ) where
 
+import qualified Data.IntSet as IS
 import Control.Lens
 import Control.Monad
 import Data.Maybe
@@ -19,33 +20,33 @@ import qualified IntMapHelp as IM
 import NewInt
 
 -- should check that the item is not already in your inventory
--- this assumes that this is a floor item
+-- this assumes that this item is currently on the floor
-tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt,World)
+tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt, World)
 tryPutItemInInv cid itid w = do
     itm <- w ^? cWorld . lWorld . items . ix itid
     invid <- checkInvSlotsYou itm w
     let itloc = InInv
-                { _ilCrID = cid
+            { _ilCrID = cid
-                , _ilInvID = invid
+            , _ilInvID = invid
-                , _ilIsRoot = False
+            , _ilIsRoot = False
-                , _ilIsSelected = False
+            , _ilIsSelected = False
-                , _ilIsAttached = False
+            , _ilIsAttached = False
-                , _ilEquipSite = Nothing
+            , _ilEquipSite = Nothing
-                }
+            }
-        newitm = itm & itLocation .~ itloc
+    return $ (invid,) $
-    return $ (invid,) $ w
+            w
-            & cWorld . lWorld %~ crUpdateItemLocations cid
+                & cWorld . lWorld %~ crUpdateItemLocations cid
--- not sure about the order of these...
+                -- not sure about the order of these...
-        & cWorld . lWorld . creatures . ix cid . crInv . at invid ?~ itid 
+                & cWorld . lWorld . creatures . ix cid . crInv . at invid ?~ itid
-        & cWorld . lWorld . items . at itid ?~ newitm
+                & cWorld . lWorld . items . ix itid . itLocation .~ itloc
---        & cWorld . lWorld . itemLocations . at itid ?~ itloc
+                & cWorld . lWorld . floorItems . at itid .~ Nothing
-        & cWorld . lWorld . floorItems . at itid .~ Nothing
+                & updateselectionextra invid
-        & updateselectionextra
   where
-    updateselectionextra
+    updateselectionextra i
-        | cid == 0 =
+        | cid == 0 = hud . hudElement . diSelection . _Just . _3 %~ IS.map (f i)
-            hud . hudElement . diSelection . _Just . _3 %~ const mempty
         | otherwise = id
+    f j i | i >= _unNInt j = i + 1
+          | otherwise = i
 
 -- not sure why we have the cid here, this will probably only work for cid == 0
 tryPutItemInInvAt :: Int -> Int -> Int -> World -> Maybe World
@@ -56,77 +57,20 @@ tryPutItemInInvAt i cid itid w = do
   where
     f j = swapInvItems (\_ _ -> Just (j -1)) j
 
----- | Pick up a specific item.
---tryPutItemInInv :: Int -> Item -> Int -> World -> Maybe (Int, World)
---tryPutItemInInv cid flit itid w = do
---    i <- checkInvSlotsYou it w
---    Just
---        ( i
---        , w
---            & cWorld . lWorld . floorItems %~ IM.delete itid
---            & cWorld . lWorld . creatures . ix cid . crInv . at i ?~ it
---            & updateItLocation i
---            -- I forget whether using "at" rather than "IM.insert" here caused problems
---            -- & cWorld . lWorld . creatures . ix cid . crInv . at i ?~ it
---            -- note item locations are updated twice: first for the ilInvID,
---            -- second for the root/selected item bools
---            & cWorld . lWorld %~ crUpdateItemLocations cid
---            & setInvPosFromSS
---            & updateselectionextra
---            & cWorld . lWorld %~ crUpdateItemLocations cid
---        )
---  where
---    updateselectionextra
---        | cid == 0 =
---            hud . hudElement . diSelection . _Just . _3 %~ const mempty
---        | otherwise = id
---    it = _flIt flit
---    -- not sure if the following is necessary
---    updateItLocation invid w' =
---        w' & cWorld . lWorld . itemLocations . ix (_unNInt $ _itID it)
---            .~ InInv
---                { _ilCrID = cid
---                , _ilInvID = invid
---                , _ilIsRoot = False
---                , _ilIsSelected = False
---                , _ilIsAttached = False
---                , _ilEquipSite = Nothing
---                }
-
----- should select the item on the floor if no inventory space?
---createAndSelectItem :: Item -> World -> World
---createAndSelectItem itm w = case createPutItem itm w of
---    (Just i, w') ->
---        w'
---            & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (0, i)
---            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
---                .~  InInventory (SelectedItem i
---                    $ fromMaybe (error "no root item1!") $ tryGetRootItemInvID i (you w))
---    (Nothing, w') -> w'
-
---createPutItem :: Item -> World -> (Maybe Int, World)
---createPutItem it w = fromMaybe (Nothing,w) $ do
---    (i,w') <- uncurry (tryPutItemIDInInv 0) $
---        copyItemToFloorID (_crPos $ you w) (applyModules it) w
---    return (Just i, w')
-
 createItemYou :: Item -> World -> World
-createItemYou itm w = fromMaybe w' $ fmap snd $ tryPutItemInInv 0 itid w'
+createItemYou itm w = maybe w' snd $ tryPutItemInInv 0 itid w'
   where
     itid = IM.newKey $ w ^. cWorld . lWorld . items
     pos = w ^?! cWorld . lWorld . creatures . ix 0 . crPos
     w' = copyItemToFloor pos (itm & itID .~ NInt itid) w
 
--- | Pick up a specific item.
+-- the duplication is annoying...
 pickUpItem :: Int -> Int -> World -> World
 pickUpItem cid itid w = fromMaybe w $ do
-    (_,w') <- tryPutItemInInv cid itid w
     p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
-    return $ soundStart (CrSound cid) p pickUpS Nothing w'
+    soundStart (CrSound cid) p pickUpS Nothing . snd <$> tryPutItemInInv cid itid w
 
--- | Pick up a specific item.
 pickUpItemAt :: Int -> Int -> Int -> World -> World
 pickUpItemAt invid cid itid w = fromMaybe w $ do
-    w' <- tryPutItemInInvAt invid cid itid w
     p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
-    return $ soundStart (CrSound cid) p pickUpS Nothing w'
+    soundStart (CrSound cid) p pickUpS Nothing <$> tryPutItemInInvAt invid cid itid w

src/Dodge/Inventory/CheckSlots.hs

@@ -21,6 +21,7 @@ checkInvSlotsYou it w = do
     guard $ crNumFreeSlots (w ^. cWorld . lWorld . items) ycr >= itInvHeight it
     Just . NInt . IM.newKey . _unNIntMap $ _crInv ycr
 
+-- the intmap should be _items
 crNumFreeSlots :: IM.IntMap Item -> Creature -> Int
 crNumFreeSlots m cr = maxInvSlots - invSize (fmap f (_crInv cr))
   where

src/Dodge/Inventory/Location.hs

@@ -4,15 +4,15 @@ module Dodge.Inventory.Location (
     setInvPosFromSS,
 ) where
 
-import Dodge.Data.ComposedItem
-import Dodge.Data.DoubleTree
-import Data.Foldable
 import Control.Applicative
 import Control.Lens
+import Data.Foldable
 --import Data.IntMap.Merge.Strict
 import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Base.You
+import Dodge.Data.ComposedItem
+import Dodge.Data.DoubleTree
 import Dodge.Data.Item.Use.Consumption.LoadAction
 import Dodge.Data.World
 import Dodge.Item.Grammar
@@ -20,8 +20,10 @@ import qualified IntMapHelp as IM
 import NewInt
 
 -- assumes all item locations inside the items are correct
-tryGetRootAttachedFromInvID :: NewInt InvInt 
+tryGetRootAttachedFromInvID ::
-    -> NewIntMap InvInt Item -> Maybe (Int, IS.IntSet)
+    NewInt InvInt ->
+    NewIntMap InvInt Item ->
+    Maybe (Int, IS.IntSet)
 tryGetRootAttachedFromInvID (NInt invid) im = do
     let imroots = invRootMap im
         theroot = fromMaybe invid $ imroots ^? ix invid . _1 . _Just
@@ -59,11 +61,17 @@ crSetRoots cid w = fromMaybe w $ do
   where
     g w' i = w' & items . ix i . itLocation . ilIsRoot .~ False
     f :: LWorld -> DTree OItem -> LWorld
-    f w' x = w'
+    f w' x =
-        & items . ix (x ^. dtValue . _1 . itID . unNInt) . itLocation . ilIsRoot .~ True
+        w'
+            & items . ix (x ^. dtValue . _1 . itID . unNInt) . itLocation . ilIsRoot .~ True
 
-crUpdateInvidLocations :: ManipulatedObject -> Int -> LWorld -> Int
+crUpdateInvidLocations ::
-    -> Item -> LWorld
+    ManipulatedObject ->
+    Int ->
+    LWorld ->
+    Int ->
+    Item ->
+    LWorld
 crUpdateInvidLocations mo crid lw invid itm =
     lw
         & creatures . ix crid . crInv . ix (NInt invid) .~ itid -- . itLocation .~ newloc
@@ -93,8 +101,12 @@ setInvPosFromSS w = w
         case i of
             (-1) -> Just SortInventory
             0 -> do
-                (rootid, aset) <- tryGetRootAttachedFromInvID (NInt j) (fmap (\k -> w ^?! cWorld . lWorld . items . ix k ) 
+                (rootid, aset) <-
-                    $ you w ^. crInv)
+                    tryGetRootAttachedFromInvID
+                        (NInt j)
+                        ( fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $
+                            you w ^. crInv
+                        )
                 return
                     SelectedItem
                         { _imSelectedItem = NInt j

src/Dodge/Item/Grammar.hs

@@ -223,8 +223,6 @@ invDT' = fmap propagateOrientation' . invDT
 
 -- this assumes the creature inventory is well formed, specifically the
 -- location ids
--- consider explicitly reseting the inventory ids (but this probably really
--- should be done upstream anyway in the actually creature inventory)
 invRootMap :: NewIntMap InvInt Item -> IM.IntMap (Maybe Int, DTree Item)
 invRootMap =
     foldMap
@@ -233,8 +231,6 @@ invRootMap =
 
 -- this assumes the creature inventory is well formed, specifically the
 -- location ids
--- consider explicitly reseting the inventory ids (but this probably really
--- should be done upstream anyway in the actually creature inventory)
 -- The first Int in the maybe is the root, the second the parent
 invAdj :: NewIntMap InvInt Item -> IM.IntMap (Maybe (Int, Int), [Int], [Int])
 invAdj = IM.unions . map g . invDT

src/Dodge/TestString.hs

@@ -31,14 +31,15 @@ import NewInt
 import Data.Foldable
 
 testStringInit :: Universe -> [String]
-testStringInit u = map f (IM.toList $ u ^. uvWorld . cWorld . lWorld . items)
+testStringInit _ = mempty
-    <> ["---"]
+ --   map f (IM.toList $ u ^. uvWorld . cWorld . lWorld . items)
-    <> map show (IM.toList . fold $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv . unNIntMap)
+ --   <> ["---"]
-    <> ["---"]
+ --   <> map show (IM.toList . fold $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv . unNIntMap)
-    <> map show (IM.keys $ u ^. uvWorld . cWorld . lWorld . floorItems)
+ --   <> ["---"]
-    
+ --   <> map show (IM.keys $ u ^. uvWorld . cWorld . lWorld . floorItems)
-  where
+ --   
-    f (i,itm) = show i <> ":" <> show (itm ^. itID . unNInt) <> ":"<> shortShow (itm ^. itLocation)
+ -- where
+ --   f (i,itm) = show i <> ":" <> show (itm ^. itID . unNInt) <> ":"<> shortShow (itm ^. itLocation)
 -- map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g)
 --  where
 --    g db = (pz,z,norm v)

src/Dodge/Update/Input/InGame.hs

@@ -132,23 +132,22 @@ tryPickupSelected k mpos w = do
     guard $ k == 3
     guard $ maybe True (\(i, _) -> i == 0 || i == 1) mpos
     cr <- w ^? cWorld . lWorld . creatures . ix 0
-    let nfreeslots = crNumFreeSlots (w ^. cWorld . lWorld . items) cr
     xs <- w ^? hud . hudElement . diSelection . _Just . _3
-    let itmstopickup = mapMaybe g $ IS.toList xs
+    let nfreeslots = crNumFreeSlots (w ^. cWorld . lWorld . items) cr
-    let slotsneeded = alaf Sum foldMap itInvHeight itmstopickup
+        itmstopickup = mapMaybe g $ IS.toList xs
+        slotsneeded = alaf Sum foldMap itInvHeight itmstopickup
+        ispickup = map (_unNInt . _itID) itmstopickup
     guard $ nfreeslots >= slotsneeded
     return $ case mpos of
         Just (0, j) ->
-            foldr (pickUpItemAt j 0) w (map (_unNInt . _itID) itmstopickup)
+            foldr (pickUpItemAt j 0) w ispickup
-                & hud . hudElement . diSelection
+                & newdisel j xs
-                    ?~ ( 0
-                       , j
-                       , IS.fromDistinctAscList [j .. j + IS.size xs -1]
-                       )
         _ ->
-            foldl' (flip $ pickUpItem 0) w (IS.toList xs)
+            foldl' (flip $ pickUpItem 0) w ispickup
-                & hud . hudElement . diSelection . _Just . _3 %~ const mempty
+                & newdisel (length (cr ^. crInv)) xs
   where
+    newdisel j xs = hud . hudElement . diSelection ?~ 
+        (0 , j , IS.fromDistinctAscList [j .. j + IS.size xs -1])
     g i = do
         NInt j <- w ^? hud . closeItems . ix i
         w ^? cWorld . lWorld . items . ix j