From db2ce72076635143aef39ee470f27f901a54b0b9 Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 16 May 2026 10:04:28 +0100 Subject: [PATCH] Highlight dropped items, work towards fixing pickup selection change --- src/Dodge/Data/HUD.hs | 2 +- src/Dodge/Data/Item/Location.hs | 2 +- src/Dodge/FloorItem.hs | 3 ++- src/Dodge/Inventory.hs | 2 +- src/Dodge/Inventory/Add.hs | 38 +++++++++++++--------------- src/Dodge/Inventory/SelectionList.hs | 6 ++++- src/Dodge/Placement/PlaceSpot.hs | 2 +- src/Dodge/SelectedClose.hs | 2 +- src/Dodge/TestString.hs | 6 ++--- src/Dodge/Update.hs | 3 ++- src/Dodge/Update/Input/InGame.hs | 8 +++--- 11 files changed, 39 insertions(+), 35 deletions(-) diff --git a/src/Dodge/Data/HUD.hs b/src/Dodge/Data/HUD.hs index 819fdf2f0..348e1a09a 100644 --- a/src/Dodge/Data/HUD.hs +++ b/src/Dodge/Data/HUD.hs @@ -38,7 +38,7 @@ data HUD = HUD } data Selection = Sel {_slSec :: Int, _slInt :: Int} - deriving (Eq) + deriving (Eq,Show) makeLenses ''HUD makeLenses ''Selection diff --git a/src/Dodge/Data/Item/Location.hs b/src/Dodge/Data/Item/Location.hs index dffd0ebbc..0920be54c 100644 --- a/src/Dodge/Data/Item/Location.hs +++ b/src/Dodge/Data/Item/Location.hs @@ -35,7 +35,7 @@ data ItemLocation , _ilEquipSite :: Maybe EquipSite } | OnTurret {_ilTuID :: Int} - | OnFloor -- {_ilFlID :: NewInt FloorInt} + | OnFloor {_ilCloseSel :: Bool} -- {_ilFlID :: NewInt FloorInt} | InVoid deriving (Eq, Show, Ord, Read) --Generic, Flat) diff --git a/src/Dodge/FloorItem.hs b/src/Dodge/FloorItem.hs index 9d89e253e..61edea9bc 100644 --- a/src/Dodge/FloorItem.hs +++ b/src/Dodge/FloorItem.hs @@ -15,8 +15,9 @@ copyItemToFloor :: Point2 -> Item -> World -> World copyItemToFloor p it w = w' & cWorld . lWorld . floorItems . at (it ^. itID . unNInt) ?~ FlIt q r - & cWorld . lWorld . items . at (it ^. itID . unNInt) ?~ (it & itLocation .~ OnFloor) + & cWorld . lWorld . items . at (it ^. itID . unNInt) ?~ (it & itLocation .~ OnFloor False) & hud . closeItems .:~ _itID it -- puts item at top of close items + & cWorld . highlightItems . at (it ^. itID . unNInt) ?~ 20 where (q, w') = findWallFreeDropPoint (_dimRad $ itDim it) p w r = fst . randomR (- pi, pi) $ _randGen w diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index dd56ab34f..7125d3117 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -73,7 +73,7 @@ destroyItem itid w = case w ^? cWorld . lWorld . items . ix itid . itLocation of Nothing -> error $ "Tried to destroy item that does not exist; item id: " ++ show itid Just InInv{_ilCrID = cid, _ilInvID = invid} -> destroyInvItem cid invid w Just OnTurret{} -> error "need to write code for destroying items on turrets" - Just OnFloor -> + Just OnFloor{} -> w & cWorld . lWorld . items . at itid .~ Nothing & cWorld . lWorld . floorItems . at itid .~ Nothing diff --git a/src/Dodge/Inventory/Add.hs b/src/Dodge/Inventory/Add.hs index 2f4a5ae47..dea7455f3 100644 --- a/src/Dodge/Inventory/Add.hs +++ b/src/Dodge/Inventory/Add.hs @@ -22,12 +22,12 @@ import qualified IntMapHelp as IM import NewInt -- this assumes that this item is currently on the floor -tryPutItemInInv :: Maybe Int -> Int -> Int -> World -> Maybe (NewInt InvInt, World) -tryPutItemInInv mcipos cid itid w = do +tryPutItemInInv :: Maybe Int -> Int -> World -> Maybe (NewInt InvInt, World) +tryPutItemInInv mcipos itid w = do itm <- w ^? cWorld . lWorld . items . ix itid invid <- checkInvSlotsYou itm w let itloc = InInv - { _ilCrID = cid + { _ilCrID = 0 , _ilInvID = invid , _ilIsRoot = False , _ilIsSelected = False @@ -36,17 +36,18 @@ tryPutItemInInv mcipos cid itid w = do } return $ (invid,) $ w - & crUpdateItemLocations - & setInvPosFromSS & crUpdateItemLocations -- not sure about the order of these... - & cWorld . lWorld . creatures . ix cid . crInv . at invid ?~ itid + & cWorld . lWorld . creatures . ix 0 . crInv . at invid ?~ itid & cWorld . lWorld . items . ix itid . itLocation .~ itloc & cWorld . lWorld . floorItems . at itid .~ Nothing & updateselectionextra invid & updatecloseitemset & maybeselect invid & cWorld . highlightItems . at itid ?~ 20 + & setInvPosFromSS + & crUpdateItemLocations + & setInvPosFromSS where maybeselect invid = fromMaybe id $ do i <- mcipos @@ -56,39 +57,36 @@ tryPutItemInInv mcipos cid itid w = do updatecloseitemset = fromMaybe id $ do i <- mcipos return $ hud . diSections . ix 3 . ssSet %~ IS.deleteShift i - updateselectionextra i - | cid == 0 = (hud . diSections . ix 0 . ssSet %~ IS.map (f i)) + updateselectionextra i = (hud . diSections . ix 0 . ssSet %~ IS.map (f i)) . (hud . diSelection . _Just . slInt %~ 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 :: Maybe Int -> Int -> Int -> Int -> World -> Maybe World -tryPutItemInInvAt mcipos i cid itid w = do - (j, w') <- tryPutItemInInv mcipos cid itid w +tryPutItemInInvAt :: Maybe Int -> Int -> Int -> World -> Maybe World +tryPutItemInInvAt mcipos i itid w = do + (j, w') <- tryPutItemInInv mcipos 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 Nothing 0 itid w' +createItemYou itm w = maybe w' snd $ tryPutItemInInv Nothing 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,Int) -> World -> World -pickUpItem cid (i,itid) w = fromMaybe w $ do +pickUpItem :: (Int,Int) -> World -> World +pickUpItem (i,itid) w = fromMaybe w $ do p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos - soundStart (CrSound cid) p pickUpS Nothing . snd <$> tryPutItemInInv (Just i) cid itid w + soundStart (CrSound 0) p pickUpS Nothing . snd <$> tryPutItemInInv (Just i) itid w -pickUpItemAt :: Int -> Int -> (Int,Int) -> World -> World -pickUpItemAt invid cid (i,itid) w = fromMaybe w $ do +pickUpItemAt :: Int -> (Int,Int) -> World -> World +pickUpItemAt invid (i,itid) w = fromMaybe w $ do p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos - soundStart (CrSound cid) p pickUpS Nothing <$> tryPutItemInInvAt (Just i) invid cid itid w + soundStart (CrSound 0) p pickUpS Nothing <$> tryPutItemInInvAt (Just i) invid itid w & _Just . hud . diSections . ix 0 . ssSet %~ IS.map f where f j | j >= invid = j +1 diff --git a/src/Dodge/Inventory/SelectionList.hs b/src/Dodge/Inventory/SelectionList.hs index 0d455946b..67e2e4d3b 100644 --- a/src/Dodge/Inventory/SelectionList.hs +++ b/src/Dodge/Inventory/SelectionList.hs @@ -231,8 +231,12 @@ closeItemToSelectionItem w i = do , _siColor = col , _siOffX = 0 , _siPayload = Nothing - , _siDisplayMod = DropShadowSI + , _siDisplayMod = dmod } + where + dmod = maybe DropShadowSI (const HighlightSI) + $ w ^? cWorld . highlightItems . ix i + closeButtonToSelectionItem :: World -> Int -> Maybe (SelectionItem ()) closeButtonToSelectionItem w i = do diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 9ba0607ba..67fc8e36a 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -111,7 +111,7 @@ placeSpotID rid ps pt w = case pt of in ( i , w & gwWorld . cWorld . lWorld . floorItems . at i ?~ FlIt p rot - & gwWorld . cWorld . lWorld . items . at i ?~ (itm & itID .~ NInt i & itLocation .~ OnFloor) + & gwWorld . cWorld . lWorld . items . at i ?~ (itm & itID .~ NInt i & itLocation .~ OnFloor False) ) PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w PutForeground fs -> diff --git a/src/Dodge/SelectedClose.hs b/src/Dodge/SelectedClose.hs index 873cbc447..879d60f56 100644 --- a/src/Dodge/SelectedClose.hs +++ b/src/Dodge/SelectedClose.hs @@ -12,7 +12,7 @@ interactWithCloseObj :: Either (NewInt ItmInt) Button -> World -> World interactWithCloseObj e w = worldEventFlags . at InventoryChange ?~ () $ case e of (Left flit) -> fromMaybe w $ do i <- w ^? hud . diSelection . _Just . slInt - return $ pickUpItem 0 (i,_unNInt flit) w + return $ pickUpItem (i,_unNInt flit) w (Right but) -> doButtonEvent (but ^. btEvent) but w getSelectedCloseObj :: World -> Maybe (Either (NewInt ItmInt) Button) diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index 9b155ef7a..604c7ca37 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -58,10 +58,10 @@ crs :: Universe -> [Creature] crs u = u ^.. uvWorld . cWorld . lWorld . creatures . each testStringInit :: Universe -> [String] -testStringInit u = [u ^. uvWorld . input . mouseContext . to show] +testStringInit u = [u ^. uvWorld . input . mouseContext . to show + , u ^. uvWorld . hud . diSelection . to show + ] <> u ^.. uvWorld . hud . diSections . each . ssSet . to show -- u ^. uvWorld . hud . manObject . to prettyShort --- <> --- u ^.. uvWorld . hud . diSections . each . ssSet . to show --testStringInit u = u ^. uvWorld . cWorld . lWorld . creatures . ix 5 . crActionPlan . to prettyShort --[show . getSum $ foldMap (Sum . crslime) (crs u)] -- u ^.. tocrs . each . crType . slimeSplitTimer . to show diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 4a28a22a6..4bee8c71b 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -426,7 +426,8 @@ updateMouseContext cfig u = case u ^? uvScreenLayers . ix 0 of updateMouseContextGame :: Config -> Universe -> MouseContext -> MouseContext updateMouseContextGame cfig u = \case - OverInvDrag i -> OverInvDrag i -- (inverseSelNumPos cfig invDP mpos disss ^? _Just . nonInf) + --OverInvDrag i -> OverInvDrag i -- (inverseSelNumPos cfig invDP mpos disss ^? _Just . nonInf) + x@OverInvDrag{} -> x x@OverInvDragSelect{} -> x MouseGameRotate x | ButtonRight `M.member` (w ^. input . mouseButtons) -> MouseGameRotate x diff --git a/src/Dodge/Update/Input/InGame.hs b/src/Dodge/Update/Input/InGame.hs index 16e2fe759..f38954dd9 100644 --- a/src/Dodge/Update/Input/InGame.hs +++ b/src/Dodge/Update/Input/InGame.hs @@ -194,11 +194,11 @@ tryPickupSelected k mpos w = do ispickup = map (_unNInt . _itID) itmstopickup guard $ nfreeslots >= slotsneeded return $ case mpos of - 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 + Just (0, j) -> foldr (pickUpItemAt j) w (zip is ispickup) & newdisel j joff + _ -> foldl' (flip $ pickUpItem) w (zip is ispickup) & newdisel (length (cr ^. crInv)) joff +-- _ -> foldr (pickUpItem 0) w (zip is ispickup) & newdisel (length (cr ^. crInv)) joff where - newdisel j joff = - (hud . diSelection ?~ Sel 0 (j + joff)) + newdisel j joff = hud . diSelection ?~ Sel 0 (j + joff) g i = do NInt j <- w ^? hud . closeItems . ix i w ^? cWorld . lWorld . items . ix j