justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
justin
2025-08-25 12:59:12 +01:00
parent 65803c11c9
commit a2c32907f0
9 changed files with 312 additions and 365 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/LWorld.hs
-1
View File
@@ -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
+6 -10
View File
@@ -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 . items . at (_unNInt $ _itID it) ?~ (it & itLocation .~ OnFloor)
& hud . closeItems .:~ _itID it
& cWorld . lWorld . floorItems . at (it ^. itID . unNInt) ?~ FlIt q r
& cWorld . lWorld . items . at (it ^. itID . unNInt) ?~ (it & itLocation .~ OnFloor)
& hud . closeItems .:~ _itID it -- puts item at top of close items
where
-- & hud . hudElement . diSections . ix 3 . ssOffset .~ 0
-- ensures dropped item is at the top of the close item selection list
(p', w') = findWallFreeDropPoint (_dimRad $ itDim it) pos w
rot = fst . randomR (- pi, pi) $ _randGen w
theflit = FlIt{_flItPos = p', _flItRot = rot}
(q, w') = findWallFreeDropPoint (_dimRad $ itDim it) p w
r = fst . randomR (- pi, pi) $ _randGen w
cardinalVectors :: [Point2]
cardinalVectors = [ V2 1 0 , V2 0 1 , V2 (-1) 0 , V2 0 (-1) ]
src/Dodge/Inventory/Add.hs
+29 -85
View File
@@ -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,34 +20,34 @@ 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
tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt,World)
-- this assumes that this item is currently on the floor
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
, _ilInvID = invid
, _ilIsRoot = False
, _ilIsSelected = False
, _ilIsAttached = False
, _ilEquipSite = Nothing
}
newitm = itm & itLocation .~ itloc
return $ (invid,) $ w
& cWorld . lWorld %~ crUpdateItemLocations cid
-- not sure about the order of these...
& cWorld . lWorld . creatures . ix cid . crInv . at invid ?~ itid
& cWorld . lWorld . items . at itid ?~ newitm
-- & cWorld . lWorld . itemLocations . at itid ?~ itloc
& cWorld . lWorld . floorItems . at itid .~ Nothing
& updateselectionextra
let itloc = InInv
{ _ilCrID = cid
, _ilInvID = invid
, _ilIsRoot = False
, _ilIsSelected = False
, _ilIsAttached = False
, _ilEquipSite = Nothing
}
return $ (invid,) $
w
& cWorld . lWorld %~ crUpdateItemLocations cid
-- not sure about the order of these...
& cWorld . lWorld . creatures . ix cid . crInv . at invid ?~ itid
& cWorld . lWorld . items . ix itid . itLocation .~ itloc
& cWorld . lWorld . floorItems . at itid .~ Nothing
& updateselectionextra invid
where
updateselectionextra
| cid == 0 =
hud . hudElement . diSelection . _Just . _3 %~ const mempty
updateselectionextra i
| cid == 0 = hud . hudElement . diSelection . _Just . _3 %~ IS.map (f i)
| 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
tryPutItemInInvAt i cid itid w = do
@@ -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
+1
View File
@@ -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
+23 -11
View File
@@ -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
-> NewIntMap InvInt Item -> Maybe (Int, IS.IntSet)
tryGetRootAttachedFromInvID ::
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'
& items . ix (x ^. dtValue . _1 . itID . unNInt) . itLocation . ilIsRoot .~ True
f w' x =
w'
& items . ix (x ^. dtValue . _1 . itID . unNInt) . itLocation . ilIsRoot .~ True
crUpdateInvidLocations :: ManipulatedObject -> Int -> LWorld -> Int
-> Item -> LWorld
crUpdateInvidLocations ::
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 )
$ you w ^. crInv)
(rootid, aset) <-
tryGetRootAttachedFromInvID
(NInt j)
( fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $
you w ^. crInv
)
return
SelectedItem
{ _imSelectedItem = NInt j
src/Dodge/Item/Grammar.hs
-4
View File
@@ -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
+9 -8
View File
@@ -31,14 +31,15 @@ import NewInt
import Data.Foldable
testStringInit :: Universe -> [String]
testStringInit u = 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.keys $ u ^. uvWorld . cWorld . lWorld . floorItems)
where
f (i,itm) = show i <> ":" <> show (itm ^. itID . unNInt) <> ":"<> shortShow (itm ^. itLocation)
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.keys $ u ^. uvWorld . cWorld . lWorld . floorItems)
--
-- 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
+10 -11
View File
@@ -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 slotsneeded = alaf Sum foldMap itInvHeight itmstopickup
let nfreeslots = crNumFreeSlots (w ^. cWorld . lWorld . items) cr
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)
& hud . hudElement . diSelection
?~ ( 0
, j
, IS.fromDistinctAscList [j .. j + IS.size xs -1]
)
foldr (pickUpItemAt j 0) w ispickup
& newdisel j xs
_ ->
foldl' (flip $ pickUpItem 0) w (IS.toList xs)
& hud . hudElement . diSelection . _Just . _3 %~ const mempty
foldl' (flip $ pickUpItem 0) w ispickup
& 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
tags
+234 -235
View File
File diff suppressed because it is too large Load Diff