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

Improve item pickup by dragging

Browse Source
This commit is contained in:
justin
2024-11-25 15:01:16 +00:00
parent 951d1191cc
commit 4e4cc92939
7 changed files with 248 additions and 212 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Action.hs
+2 -2
View File
@@ -13,7 +13,7 @@ module Dodge.Creature.Action (
unsafeBlinkAction,
sizeSelf,
youDropItem,
pickUpItem,
-- pickUpItem,
) where
import Control.Applicative
@@ -31,7 +31,7 @@ import Dodge.Default
import Dodge.FloatFunction
import Dodge.FloorItem
import Dodge.Inventory
import Dodge.Inventory.Add
--import Dodge.Inventory.Add
import Dodge.Path
import Dodge.SoundLogic
import Dodge.WallCreatureCollisions
src/Dodge/Inventory.hs
+1 -85
View File
@@ -16,12 +16,10 @@ module Dodge.Inventory (
swapItemWith,
) where
import Control.Monad
import Dodge.Inventory.Swap
import Data.Function
import qualified Data.IntSet as IS
import Data.Maybe
import Dodge.Base
import Dodge.Data.DoubleTree
import Dodge.Data.SelectionList
import Dodge.Data.World
import Dodge.Euse
@@ -29,17 +27,12 @@ import Dodge.Inventory.CheckSlots
import Dodge.Inventory.Location
import Dodge.Inventory.RBList
import Dodge.ItEffect
import Dodge.Item.Grammar
import Dodge.SelectionSections
import Dodge.SoundLogic
import Geometry
import qualified IntMapHelp as IM
import LensHelp
import ListHelp
import NewInt
import Sound.Data
--import Padding
-- TODO check what happens to selection index when dropping non-selected items
@@ -176,83 +169,6 @@ changeSwapOther manlens n f i w = fromMaybe w $ do
& hud . hudElement . diSelection . _Just . _2 %~ doswap
& worldEventFlags . at InventoryChange ?~ ()
-- can be specialised for when we know that item i is selected
swapInvItems ::
(Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
Int ->
World ->
World
swapInvItems f i w = fromMaybe w $ do
ss <- w ^? hud . hudElement . diSections . ix 0 . ssItems
k <- f i ss
let updateselection = case w ^? hud . hudElement . diSelection . _Just of
Just (0, j) | j == k -> hud . hudElement . diSelection . _Just . _2 .~ i
Just (0, j) | j == i -> hud . hudElement . diSelection . _Just . _2 .~ k
_ -> id
return $
w
& swapAnyExtraSelection i k
& checkConnection InventorySound disconnectItemS i k
& cWorld . lWorld . creatures . ix 0 %~ updatecreature k
& updateselection
& worldEventFlags . at InventoryChange ?~ ()
& cWorld . lWorld %~ crUpdateItemLocations 0
& setInvPosFromSS
& cWorld . lWorld %~ crUpdateItemLocations 0 -- the double application is inefficient, but necessary without further changes
-- a rethink is maybe in order
& checkConnection InventoryConnectSound connectItemS i k
where
-- & checkconnect k InventoryConnectSound connectItemS
-- cpos = fromMaybe 0 $ w ^? cWorld . lWorld . creatures . ix 0 . crPos
-- checkconnect k stype s w'
-- | p (i+1) || p (i-1)
-- || p (k+1) || p (k-1) = soundStart stype cpos s Nothing w'
-- | otherwise = w'
-- where
-- p j = maybe False not $ w' ^? cWorld . lWorld . creatures . ix 0 . crInv . ix j . itLocation . ilIsRoot
updatecreature k =
(crInv %~ IM.safeSwapKeys i k)
. (crManipulation . manObject . imSelectedItem .~ k)
. (crInvEquipped %~ IM.safeSwapKeys i k)
. swapSite i k
. swapSite k i
. (crInvHotkeys %~ IM.safeSwapKeys i k)
. swapSite' i k
. swapSite' k i
cr = you w
swapSite a b = case cr ^? crInvEquipped . ix a of
Just epos -> crEquipment . ix epos .~ b
Nothing -> id
swapSite' a b = case cr ^? crInvHotkeys . ix a of
Just epos -> crHotkeys . ix epos .~ b
Nothing -> id
swapAnyExtraSelection :: Int -> Int -> World -> World
swapAnyExtraSelection i k w = fromMaybe w $ do
is <- w ^? hud . hudElement . diSelectionExtra
let f = if i `IS.member` is then IS.insert k else id
g = if k `IS.member` is then IS.insert i else id
return $
w & hud . hudElement . diSelectionExtra
%~ (f . g . IS.delete i . IS.delete k)
checkConnection :: SoundOrigin -> SoundID -> Int -> Int -> World -> World
checkConnection so s i j w = fromMaybe w $ do
inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
let locs = allInvLocs inv
iit <- locs ^? ix i . _2
jit <- locs ^? ix j . _2
guard $ isConnected iit || isConnected jit
return $ soundStart so cpos s Nothing w
isConnected :: LocationLDT b a -> Bool
isConnected x = case x ^. locLdtContext of
TopLDT ->
not (null $ x ^. locLDT . ldtRight)
|| not (null $ x ^. locLDT . ldtLeft)
_ -> True
swapItemWith ::
(Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
src/Dodge/Inventory/Add.hs
+19
View File
@@ -4,8 +4,11 @@ module Dodge.Inventory.Add (
--createAndSelectItem,
createItemYou,
pickUpItem,
pickUpItemAt,
) where
import Dodge.Inventory.Swap
import Control.Monad
import NewInt
import Dodge.SoundLogic
import Dodge.Inventory.Location
@@ -25,6 +28,16 @@ tryPutFloorItemIDInInv cid flitid w = do
flit <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix (_unNInt flitid)
tryPutItemInInv cid flit w
-- not sure why we have the cid here, this will probably only work for cid == 0
tryPutItemInInvAt :: Int -> Int -> FloorItem -> World -> Maybe World
tryPutItemInInvAt i cid flit w = do
(j,w') <- tryPutItemInInv cid flit w
guard (i <= j)
return $ foldr f w' [i+1..j]
where
f j = swapInvItems (\_ _ -> Just (j-1)) j
-- | Pick up a specific item.
tryPutItemInInv :: Int -> FloorItem -> World -> Maybe (Int, World)
tryPutItemInInv cid flit w = case maybeInvSlot of
@@ -93,3 +106,9 @@ pickUpItem :: Int -> FloorItem -> World -> World
pickUpItem cid flit w =
maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing . snd) $
tryPutItemInInv cid flit w
-- | Pick up a specific item.
pickUpItemAt :: Int -> Int -> FloorItem -> World -> World
pickUpItemAt invid cid flit w =
maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing) $
tryPutItemInInvAt invid cid flit w
src/Dodge/Inventory/Swap.hs
+97
View File
@@ -0,0 +1,97 @@
module Dodge.Inventory.Swap (
swapInvItems,
swapAnyExtraSelection
) where
import Dodge.SoundLogic
import Dodge.Item.Grammar
import Dodge.Base.You
import Dodge.Inventory.Location
import Dodge.Data.DoubleTree
import Sound.Data
import qualified Data.IntSet as IS
import Data.Maybe
import Control.Lens
import Dodge.Data.SelectionList
import qualified IntMapHelp as IM
import Dodge.Data.World
import Control.Monad
-- can be specialised for when we know that item i is selected
swapInvItems ::
(Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
Int ->
World ->
World
swapInvItems f i w = fromMaybe w $ do
ss <- w ^? hud . hudElement . diSections . ix 0 . ssItems
k <- f i ss
let updateselection = case w ^? hud . hudElement . diSelection . _Just of
Just (0, j) | j == k -> hud . hudElement . diSelection . _Just . _2 .~ i
Just (0, j) | j == i -> hud . hudElement . diSelection . _Just . _2 .~ k
_ -> id
return $
w
& swapAnyExtraSelection i k
& checkConnection InventorySound disconnectItemS i k
& cWorld . lWorld . creatures . ix 0 %~ updatecreature k
& updateselection
& worldEventFlags . at InventoryChange ?~ ()
& cWorld . lWorld %~ crUpdateItemLocations 0
& setInvPosFromSS
& cWorld . lWorld %~ crUpdateItemLocations 0 -- the double application is inefficient, but necessary without further changes
-- a rethink is maybe in order
& checkConnection InventoryConnectSound connectItemS i k
where
-- & checkconnect k InventoryConnectSound connectItemS
-- cpos = fromMaybe 0 $ w ^? cWorld . lWorld . creatures . ix 0 . crPos
-- checkconnect k stype s w'
-- | p (i+1) || p (i-1)
-- || p (k+1) || p (k-1) = soundStart stype cpos s Nothing w'
-- | otherwise = w'
-- where
-- p j = maybe False not $ w' ^? cWorld . lWorld . creatures . ix 0 . crInv . ix j . itLocation . ilIsRoot
updatecreature k =
(crInv %~ IM.safeSwapKeys i k)
. (crManipulation . manObject . imSelectedItem .~ k)
. (crInvEquipped %~ IM.safeSwapKeys i k)
. swapSite i k
. swapSite k i
. (crInvHotkeys %~ IM.safeSwapKeys i k)
. swapSite' i k
. swapSite' k i
cr = you w
swapSite a b = case cr ^? crInvEquipped . ix a of
Just epos -> crEquipment . ix epos .~ b
Nothing -> id
swapSite' a b = case cr ^? crInvHotkeys . ix a of
Just epos -> crHotkeys . ix epos .~ b
Nothing -> id
swapAnyExtraSelection :: Int -> Int -> World -> World
swapAnyExtraSelection i k w = fromMaybe w $ do
is <- w ^? hud . hudElement . diSelectionExtra
let f = if i `IS.member` is then IS.insert k else id
g = if k `IS.member` is then IS.insert i else id
return $
w & hud . hudElement . diSelectionExtra
%~ (f . g . IS.delete i . IS.delete k)
checkConnection :: SoundOrigin -> SoundID -> Int -> Int -> World -> World
checkConnection so s i j w = fromMaybe w $ do
inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
let locs = allInvLocs inv
iit <- locs ^? ix i . _2
jit <- locs ^? ix j . _2
guard $ isConnected iit || isConnected jit
return $ soundStart so cpos s Nothing w
isConnected :: LocationLDT b a -> Bool
isConnected x = case x ^. locLdtContext of
TopLDT ->
not (null $ x ^. locLDT . ldtRight)
|| not (null $ x ^. locLDT . ldtLeft)
_ -> True
src/Dodge/Update/Input/InGame.hs
+6 -5
View File
@@ -123,7 +123,12 @@ tryPickupSelected k mpos w = do
let itmstopickup = mapMaybe g $ IS.toList xs
let slotsneeded = alaf Sum foldMap (_itInvSize . _flIt) $ itmstopickup
guard $ nfreeslots >= slotsneeded
return $ foldl' (flip $ pickUpItem 0) w itmstopickup
return $ case mpos of
Nothing -> foldl' (flip $ pickUpItem 0) w itmstopickup
& hud . hudElement . diSelectionExtra .~ mempty
Just (_,j) -> foldr (pickUpItemAt j 0) w itmstopickup
& hud . hudElement . diSelection ?~ (0,j)
& hud . hudElement . diSelectionExtra .~ IS.fromDistinctAscList [j..j+IS.size xs-1]
where
g i = do
NInt j <- w ^? hud . closeItems . ix i
@@ -134,10 +139,6 @@ updateMouseReleaseInGame w = case w ^. input . mouseContext of
OverInvDrag k mpos _ _ ->
input . mouseContext .~ MouseInGame $
fromMaybe w $ tryDropSelected mpos w <|> tryPickupSelected k 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