From 90133fb54b2a9249240a1d33f19cba7e5b100498 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 17 Feb 2023 18:00:40 +0000 Subject: [PATCH] Work on combine cursors --- src/Dodge/Creature/Action.hs | 4 +- src/Dodge/Data/SelectionList.hs | 4 -- src/Dodge/Inventory.hs | 73 ++++++++++++++++++++++++--------- src/Dodge/Render/HUD.hs | 43 ++++++++++++------- src/Dodge/Render/List.hs | 10 ++++- 5 files changed, 91 insertions(+), 43 deletions(-) diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index ef7f23808..2c0e1de8f 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -178,9 +178,7 @@ dropExcept cr invid w = invid `IM.delete` _crInv cr dropItem :: Creature -> Int -> World -> World -dropItem cr invid = rmInvItem cid invid . copyInvItemToFloor cr invid -- . mayberemoveequip - where - cid = _crID cr +dropItem cr invid = rmInvItem (_crID cr) invid . copyInvItemToFloor cr invid -- . mayberemoveequip -- the following should be done in rmInvItem -- mayberemoveequip = case _crLeftInvSel cr of diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index ab344517f..210e713f4 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/src/Dodge/Data/SelectionList.hs @@ -45,11 +45,7 @@ data SectionCursor = SectionCursor data SelectionSection a = SelectionSection { _ssItems :: IntMap (SelectionItem a) , _ssCursor :: Maybe SectionCursor --- , _ssSelPos :: Maybe Int --- , _ssSelSize :: Maybe Int --- , _ssSelColor :: Maybe Color , _ssMinSize :: Int - --, _ssPriority :: Int , _ssOffset :: Int , _ssShownItems :: [Picture] , _ssIndent :: Int diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index 259856581..0bb2cd9f3 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TupleSections #-} module Dodge.Inventory ( + selSecSelPos, ssLookupDown, ssLookupGT, ssSetCursor, @@ -9,9 +10,9 @@ module Dodge.Inventory ( rmSelectedInvItem, invSelSize, selNumPos, - selNumTextPos, + selNumTextEndPos, selNumCol, - selNumMidHeight, + selNumEndMidHeight, augmentedInvSizes, rmInvItem, updateCloseObjects, @@ -63,9 +64,6 @@ rmInvItem cid invid w = case w ^? getcid . crInv . ix invid . itUse . useAmount w & pointcid . crInv %~ f & pointcid %~ crCancelReloading - -- & pointcid . crInvSel . iselPos %~ g THIS NEEDS CHECKING - -- & pointcid . crManipulation . manObject . inInventory . ispItem %~ g - -- & pointcid . crManipulation . manObject %~ h & pointcid . crLeftInvSel . lisMPos %~ g' & removeAnySlotEquipment & dounequipfunction @@ -74,7 +72,6 @@ rmInvItem cid invid w = case w ^? getcid . crInv . ix invid . itUse . useAmount & pointcid . crInvEquipped %~ IM.mapKeys g & updatemanipulation where - -- TODO check whether this can be mapKeysMonotonic getcid = cWorld . lWorld . creatures . ix cid pointcid = cWorld . lWorld . creatures . ix cid @@ -96,10 +93,10 @@ rmInvItem cid invid w = case w ^? getcid . crInv . ix invid . itUse . useAmount removeAnySlotEquipment = case w ^? cWorld . lWorld . creatures . ix cid . crInvEquipped . ix invid of Just epos -> pointcid . crEquipment . at epos .~ Nothing Nothing -> id - maxk = fmap fst $ IM.lookupMax $ cr ^?! crInv + maxk = fmap fst $ IM.lookupMax $ cr ^. crInv f inv = let (xs, ys) = IM.split invid inv - in xs `IM.union` IM.mapKeys (subtract 1) ys + in xs `IM.union` IM.mapKeysMonotonic (subtract 1) ys -- the following might not work if a non-player creature drops their last item g x | x > invid || Just x == maxk = max 0 $ x - 1 @@ -128,8 +125,18 @@ trimapAugmentInv f x g w = where n = length $ yourInv w -invSelSize :: Int -> World -> Int -invSelSize i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i +selSecSelSize :: Int -> Int -> SelectionSections a -> Maybe Int +selSecSelSize i j sss = fmap length $ sss ^? sssSections . ix i . ssItems . ix j . siPictures + +invSelSize :: ManipulatedObject -> World -> Int +invSelSize mo w = case mo of + InInventory (SelItem i _) -> fromMaybe 1 $ fmap itSlotsTaken + $ w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix i + InNearby (SelCloseObject i) -> fromMaybe 1 $ fmap closeObjectSize + $ w ^? hud . closeObjects . ix i + InInventory SortInventory -> 1 + InNearby SortNearby -> 1 + SelNothing -> 1 closeObjectSize :: Either FloorItem Button -> Int closeObjectSize e = case e of @@ -141,23 +148,49 @@ closeObjectCol e = case e of Left flit -> _itInvColor $ _flIt flit Right _ -> yellow -selNumPos :: Int -> World -> Int -selNumPos i w = sum . fst $ IM.split i (augmentedInvSizes w) - -selNumTextPos :: Configuration -> World -> Int -> Point2 -selNumTextPos cfig w i = V2 (150 - hw) (hh - (20 * fromIntegral ipos + 20)) +selSecSelPos :: Int -> Int -> SelectionSections a -> Maybe Int +selSecSelPos i j sss = do + ss <- sss ^? sssSections . ix i + return . (secpos +) + . subtract (ss ^. ssOffset) + . sum + . fmap (length . _siPictures) + . fst $ IM.split j (ss ^. ssItems) where + secpos = sum . fmap (length . _ssItems) . fst $ IM.split i $ sss ^. sssSections + +selNumPos :: ManipulatedObject -> World -> Maybe Int +selNumPos mo w = w ^? hud . hudElement . diSections >>= + case mo of + InInventory SortInventory -> selSecSelPos (-1) 0 + InInventory (SelItem i _) -> selSecSelPos 0 i + SelNothing -> selSecSelPos 1 0 + InNearby SortNearby -> selSecSelPos 2 0 + InNearby (SelCloseObject i) -> selSecSelPos 3 i + +-- there are still more ListDisplayParams to integrate here +selNumTextEndPos :: Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Maybe Point2 +selNumTextEndPos cfig ldp sss i j = do + ipos <- selSecSelPos i j sss + return $ V2 (150 - hw) (hh - ((s * 10 + ygap) * (fromIntegral ipos + 1))) + where + s = _ldpScale ldp + ygap = _ldpVerticalGap ldp hh = halfHeight cfig hw = halfWidth cfig - ipos = selNumPos i w -selNumMidHeight :: Configuration -> World -> Int -> Point2 -selNumMidHeight cfig w i = V2 (150 - hw) (hh + bump - (20 * fromIntegral ipos + 7.5)) +selNumEndMidHeight :: Configuration -> ListDisplayParams -> SelectionSections a -> Int + -> Int -> Maybe Point2 +selNumEndMidHeight cfig ldp sss i j = do + ipos <- selSecSelPos i j sss + size <- selSecSelSize i j sss + --let bump = negate $ (10 * s + ygap) * fromIntegral size + return $ V2 (150 - hw) (hh - ((10 * s + ygap) * (fromIntegral ipos + fromIntegral size * 0.5))) where + s = _ldpScale ldp + ygap = _ldpVerticalGap ldp hh = halfHeight cfig hw = halfWidth cfig - ipos = selNumPos i w - bump = negate $ 10 * fromIntegral (invSelSize i w) selNumCol :: Int -> World -> Color selNumCol i w = fromMaybe white $ trimapAugmentInv _itInvColor invDimColor closeObjectCol w IM.!? i diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index eec3dfb2c..c4c7f0bf8 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -4,6 +4,7 @@ module Dodge.Render.HUD ( invDisplayParams, ) where +import Dodge.Inventory import SelectionIntMap import Dodge.Data.Combine import Dodge.Default.SelectionList @@ -19,9 +20,6 @@ import Dodge.Data.CardinalPoint import Dodge.Data.Config import Dodge.Data.SelectionList import Dodge.Data.World -import Dodge.Inventory ---import Dodge.Inventory.ItemSpace ---import Dodge.Item.Display import Dodge.Item.Info import Dodge.Render.Connectors import Dodge.Render.List @@ -167,15 +165,20 @@ drawNoSubInventory cfig w = , rboptions ] where - equipcursor = case cr ^. crLeftInvSel . lisMPos of - Just invid -> f cyan invid (_crInvEquipped cr IM.! invid) - _ -> mempty + equipcursor = fromMaybe mempty $ do + invid <- cr ^. crLeftInvSel . lisMPos + sss <- w ^? hud . hudElement . diSections + pos <- selSecSelPos 0 invid sss + return $ listTextPictureAt 144 0 cfig pos . color cyan . text . eqPosText $_crInvEquipped cr IM.! invid + f col invid epos = fromMaybe mempty $ do + sss <- w ^? hud . hudElement . diSections + pos <- selSecSelPos 0 invid sss + return $ listTextPictureAt 144 0 cfig pos . color col $ text $ eqPosText epos equipcursors = IM.foldMapWithKey (f yellow) (_crInvEquipped cr) cr = you w rboptions | ButtonRight `M.member` _mouseButtons (_input w) = drawRBOptions cfig w (_rbOptions w) | otherwise = mempty - f col invid epos = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos examineInventoryExtra :: Maybe Int -> Maybe Item -> Configuration -> Picture examineInventoryExtra mtweaki mitm cfig = fromMaybe mempty $ do @@ -199,9 +202,14 @@ combineInventoryExtra sm mi cfig w = fromMaybe mempty $ do lnks <- sm ^? smShownItems . ix i . siPayload . ciInvIDs return $ lnkMidPosInvSelsCol cfig w cpos col lnks - <> foldMap (topCursorTypeWidth listCursorNESW (topInvW + 2) cfig w) lnks + -- <> foldMap (topCursorTypeWidth listCursorNESW (topInvW + 2) cfig w) lnks + <> foldMap invcursor lnks <> combineCounts cfig w lnks ] + where + invcursor i = fromMaybe mempty $ do + sss <- w ^? hud . hudElement . diSections + return $ selSecDrawCursor 17 [North,South,East] cfig (invDisplayParams w) sss 0 i secondColumnParams :: ListDisplayParams secondColumnParams = @@ -304,16 +312,21 @@ subInvX = 9 * fromIntegral topInvW + 50 combineCounts :: Configuration -> World -> [Int] -> Picture combineCounts cfig w = winScale cfig . foldMap f . group where - f (i : is) = case yourInv w ^? ix i . itUse . useAmount of - Just _ -> color (selNumCol i w) $ uncurryV translate (selNumTextPos cfig w i) . scale 0.1 0.1 . text $ ('-' : show (length is + 1)) - _ -> mempty + f (i : is) = fromMaybe mempty $ do + _ <- yourInv w ^? ix i . itUse . useAmount + sss <- w ^? hud . hudElement . diSections + p <- selNumTextEndPos cfig (invDisplayParams w) sss 0 i + return $ color (selNumCol i w) $ uncurryV translate p . scale 0.1 0.1 . text $ ('-' : show (length is + 1)) f _ = mempty lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture -lnkMidPosInvSelsCol cfig w i col = - winScale cfig - . foldMap (\j -> zConnectCol rp (V2 18 0 + selNumMidHeight cfig w j) col white white (selNumCol j w)) +lnkMidPosInvSelsCol cfig w i col = winScale cfig + . foldMap f where + f j = fromMaybe mempty $ do + sss <- w ^? hud . hudElement . diSections + h <- selNumEndMidHeight cfig (invDisplayParams w) sss 0 j + return $ zConnectCol rp (V2 18 0 + h) col white white (selNumCol j w) rp = V2 (190 - hw) (hh - (20 * fromIntegral i + 77.5)) hh = halfHeight cfig hw = halfWidth cfig @@ -326,7 +339,7 @@ topCursorTypeWidth :: Int -> Picture topCursorTypeWidth ctype width cfig w i = - ctype 0 0 cfig (selNumPos i w) 0 (selNumCol i w) width (invSelSize i w) + ctype 0 0 cfig (fromMaybe 0 (selNumPos (InInventory (SelItem i NoInvSelAction)) w)) 0 (selNumCol i w) width (invSelSize (InInventory (SelItem i NoInvSelAction)) w) determineInvSelCursorWidth :: World -> Int determineInvSelCursorWidth w = case _rbOptions w of diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 35bc761a1..c97d157eb 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -1,6 +1,7 @@ module Dodge.Render.List where --import Picture.Text +import Dodge.Inventory import SelectionIntMap import qualified Data.IntMap.Strict as IM --import Data.Foldable @@ -109,6 +110,13 @@ stackPicturesAt tx ty cfig = stackPicturesAtOff tx ty cfig 0 stackPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture stackPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i, i -1 ..] +selSecDrawCursor :: Int -> [CardinalPoint] -> Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Picture +selSecDrawCursor xsize borders cfig ldp sss i j = fromMaybe mempty $ do + yint <- selSecSelPos i j sss + xint <- sss ^? sssSections . ix i . ssIndent + si <- sss ^? sssSections . ix i . ssItems . ix j + return $ listCursorDisplayParams ldp borders cfig yint xint (_siColor si) xsize (length $ _siPictures si) + listCursorDisplayParams :: ListDisplayParams -> [CardinalPoint] -> @@ -153,7 +161,7 @@ listCursorChooseBorderScale ygap s borders xoff yoff cfig yint xint col cursxsiz where x = 9 wth = x * fromIntegral cursxsize + 9 - hgt = 20 * fromIntegral cursysize + hgt = 20 * fromIntegral cursysize -- TODO this should be changed! -- displays a cursor that should match up to list text pictures -- the width of a character appears to be 9(?!)