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

Work on selections when picking up/droping items

Browse Source
This commit is contained in:
justin
2026-05-14 11:40:58 +01:00
parent 44ecaf409e
commit ab393febcb
7 changed files with 155 additions and 112 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Action.hs
+20 -7
View File
@@ -10,6 +10,9 @@ module Dodge.Creature.Action (
youDropItem,
) where
import qualified IntSetHelp as IS
import Dodge.DisplayInventory
import Dodge.Data.SelectionList
import RandomHelp
import Dodge.WorldEvent.ThingsHit
import Control.Applicative
@@ -174,22 +177,32 @@ performTurnToA cr p
-- why not a cid (Int)?
dropItem :: Creature -> Int -> World -> World
dropItem cr invid w' =
doanyitemdropeffect
dropItem cr invid w =
itEffectOnDrop itm cr
. maybesetdropped
. (hud . diSections . ix 3 . ssSet %~ IS.map (+ 1))
. (hud . diSections . ix 0 . ssSet %~ IS.deleteShift invid)
. maybeshiftseldown
. copyItemToFloor (cr ^. crPos . _xy) itm -- . mayberemoveequip
. rmInvItem (_crID cr) (NInt invid) -- it is important
-- to do this before copying the item to the floor!
. soundStart (CrSound (_crID cr)) (cr ^. crPos . _xy) whiteNoiseFadeOutS Nothing
$ w'
$ w
where
doanyitemdropeffect = itEffectOnDrop itm cr
itm = fromMaybe (error "dropItem cannot find item") $ do
itid <- cr ^? crInv . ix (NInt invid)
w' ^? cWorld . lWorld . items . ix itid
maybeshiftseldown w = fromMaybe w $ do
w ^? cWorld . lWorld . items . ix itid
t = fromMaybe True $ do
s <- w ^? hud . diCloseFilter . _Just
si <- w ^? hud . diSections . ix 0 . ssItems . ix invid
return $ plainRegex s si
maybesetdropped = fromMaybe id $ do
guard $ t && (invid `IS.member` (w ^?! hud . diSections . ix 0 . ssSet))
return $ hud . diSections . ix 3 . ssSet %~ IS.insert 0
maybeshiftseldown = fromMaybe id $ do
guard t
3 <- w ^? hud . diSelection . _Just . slSec
return $ w & hud . diSelection . _Just . slInt +~ 1
return $ hud . diSelection . _Just . slInt +~ 1
-- | Get your creature to drop the item under the cursor.
youDropItem :: World -> World
src/Dodge/DisplayInventory.hs
+1
View File
@@ -8,6 +8,7 @@ module Dodge.DisplayInventory (
updateInventoryPositioning,
updateCombinePositioning,
toggleCombineInv,
plainRegex,
) where
import qualified Data.IntSet as IS
src/Dodge/Inventory/Add.hs
+27 -13
View File
@@ -6,9 +6,9 @@ module Dodge.Inventory.Add (
pickUpItemAt,
) where
import qualified IntSetHelp as IS
import Dodge.Data.SelectionList
import Linear
import qualified Data.IntSet as IS
import Control.Lens
import Control.Monad
import Data.Maybe
@@ -22,8 +22,8 @@ import qualified IntMapHelp as IM
import NewInt
-- this assumes that this item is currently on the floor
tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt, World)
tryPutItemInInv cid itid w = do
tryPutItemInInv :: Maybe Int -> Int -> Int -> World -> Maybe (NewInt InvInt, World)
tryPutItemInInv mcipos cid itid w = do
itm <- w ^? cWorld . lWorld . items . ix itid
invid <- checkInvSlotsYou itm w
let itloc = InInv
@@ -42,8 +42,18 @@ tryPutItemInInv cid itid w = do
& cWorld . lWorld . items . ix itid . itLocation .~ itloc
& cWorld . lWorld . floorItems . at itid .~ Nothing
& updateselectionextra invid
& updatecloseitemset
& maybeselect invid
& cWorld . highlightItems . at itid ?~ 20
where
maybeselect invid = fromMaybe id $ do
i <- mcipos
is <- w ^? hud . diSections . ix 3 . ssSet
guard $ i `IS.member` is
return $ hud . diSections . ix 0 . ssSet %~ IS.insert (invid ^. unNInt)
updatecloseitemset = fromMaybe id $ do
i <- mcipos
return $ hud . diSections . ix 3 . ssSet %~ IS.deleteShift i
updateselectionextra i
-- | cid == 0 = (hud . diSelection . _Just . slSet %~ IS.map (f i))
| cid == 0 = (hud . diSections . ix 0 . ssSet %~ IS.map (f i))
@@ -53,28 +63,32 @@ tryPutItemInInv cid itid w = do
| 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
(j, w') <- tryPutItemInInv cid itid w
tryPutItemInInvAt :: Maybe Int -> Int -> Int -> Int -> World -> Maybe World
tryPutItemInInvAt mcipos i cid itid w = do
(j, w') <- tryPutItemInInv mcipos cid itid w
guard (i <= _unNInt j)
return $ foldr f w' [i + 1 .. _unNInt j]
where
f j = swapInvItems (\_ _ -> Just (j -1)) j
createItemYou :: Item -> World -> World
createItemYou itm w = maybe w' snd $ tryPutItemInInv 0 itid w'
createItemYou itm w = maybe w' snd $ tryPutItemInInv Nothing 0 itid w'
where
itid = IM.newKey $ w ^. cWorld . lWorld . items
pos = w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy
w' = copyItemToFloor pos (itm & itID .~ NInt itid) w
-- the duplication is annoying...
pickUpItem :: Int -> Int -> World -> World
pickUpItem cid itid w = fromMaybe w $ do
pickUpItem :: Int -> (Int,Int) -> World -> World
pickUpItem cid (i,itid) w = fromMaybe w $ do
p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
soundStart (CrSound cid) p pickUpS Nothing . snd <$> tryPutItemInInv cid itid w
soundStart (CrSound cid) p pickUpS Nothing . snd <$> tryPutItemInInv (Just i) cid itid w
pickUpItemAt :: Int -> Int -> Int -> World -> World
pickUpItemAt invid cid itid w = fromMaybe w $ do
pickUpItemAt :: Int -> Int -> (Int,Int) -> World -> World
pickUpItemAt invid cid (i,itid) w = fromMaybe w $ do
p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
soundStart (CrSound cid) p pickUpS Nothing <$> tryPutItemInInvAt invid cid itid w
soundStart (CrSound cid) p pickUpS Nothing <$> tryPutItemInInvAt (Just i) invid cid itid w
& _Just . hud . diSections . ix 0 . ssSet %~ IS.map f
where
f j | j >= invid = j +1
| otherwise = j
src/Dodge/SelectedClose.hs
+5 -1
View File
@@ -5,10 +5,14 @@ import Dodge.Button.Event
import Dodge.Data.World
import Dodge.Inventory.Add
import NewInt
import Data.Maybe
-- assumes that, for picking up, you are selecting the item
interactWithCloseObj :: Either (NewInt ItmInt) Button -> World -> World
interactWithCloseObj e w = worldEventFlags . at InventoryChange ?~ () $ case e of
(Left flit) -> pickUpItem 0 (_unNInt flit) w
(Left flit) -> fromMaybe w $ do
i <- w ^? hud . diSelection . _Just . slInt
return $ pickUpItem 0 (i,_unNInt flit) w
(Right but) -> doButtonEvent (but ^. btEvent) but w
getSelectedCloseObj :: World -> Maybe (Either (NewInt ItmInt) Button)
src/Dodge/Update/Input/InGame.hs
+7 -13
View File
@@ -154,7 +154,6 @@ tryDropSelected mpos w = do
let xmin = IS.findMin xs
return
. (hud . diSelection ?~ Sel 3 (j - xmin))
. (hud . diSections . ix 3 . ssSet .~ IS.fromDistinctAscList [0 .. IS.size xs - 1])
. foldl' (flip $ dropItem cr) w
. IS.toDescList
$ xs
@@ -181,18 +180,17 @@ tryPickupSelected k mpos w = do
let xmin = IS.findMin xs
joff = sli - xmin
let nfreeslots = crNumFreeSlots (w ^. cWorld . lWorld . items) cr
itmstopickup = mapMaybe g $ IS.toList xs
is = IS.toList xs
itmstopickup = mapMaybe g is
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 ispickup & newdisel j joff xs
_ -> foldl' (flip $ pickUpItem 0) w ispickup & newdisel (length (cr ^. crInv)) joff xs
Just (0, j) -> foldr (pickUpItemAt j 0) w (zip is ispickup) & newdisel j joff
_ -> foldl' (flip $ pickUpItem 0) w (zip is ispickup) & newdisel (length (cr ^. crInv)) joff
where
newdisel j joff xs =
-- hud . diSelection ?~ Sel 0 (j+joff) (IS.fromDistinctAscList [j .. j + IS.size xs -1])
newdisel j joff =
(hud . diSelection ?~ Sel 0 (j + joff))
. (hud . diSections . ix 0 . ssSet .~ IS.fromDistinctAscList [j .. j + IS.size xs - 1])
g i = do
NInt j <- w ^? hud . closeItems . ix i
w ^? cWorld . lWorld . items . ix j
@@ -549,12 +547,8 @@ updateEnterRegex w = case w ^? hud . subInventory of
| secfocus [2, 3] ->
-- w & hud . diSelection ?~ Sel 2 0 mempty
w
& hud
. diSelection
?~ Sel 2 0
& hud
. diCloseFilter
%~ enterregex
& hud . diSelection ?~ Sel 2 0
& hud . diCloseFilter %~ enterregex
Just CombineInventory{} ->
w
& hud
src/IntSetHelp.hs
+16
View File
@@ -0,0 +1,16 @@
module IntSetHelp
(
module Data.IntSet,
deleteShift
)
where
--import qualified Prelude
import Prelude hiding (map)
import Data.IntSet
deleteShift :: Int -> IntSet -> IntSet
deleteShift i x = y <> map (subtract 1) z
where
(y,z) = split i x