From a8e00ac025be717eef63431ef81fbf651afb9aa8 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 10 Feb 2023 10:57:00 +0000 Subject: [PATCH] Implement telescoping inventory selection --- src/Dodge/Data/SelectionList.hs | 3 + src/Dodge/DisplayInventory.hs | 138 ++++++++++++++++++++++----- src/Dodge/HeldScroll.hs | 2 +- src/Dodge/Inventory/SelectionList.hs | 15 --- src/Dodge/Item/Display.hs | 2 +- src/Dodge/Render/HUD.hs | 28 ++++-- src/Dodge/Render/InfoBox.hs | 2 +- src/Dodge/Render/List.hs | 37 +++++-- src/Dodge/Update.hs | 5 +- src/SelectionIntMap.hs | 4 +- 10 files changed, 172 insertions(+), 64 deletions(-) diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index ccee798d7..a2cf8a5bc 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/src/Dodge/Data/SelectionList.hs @@ -45,11 +45,14 @@ data SSRestriction = NoSSRestriction data SelectionSection a = SelectionSection { _ssItems :: [SelectionItem a] , _ssSelPos :: Maybe Int + , _ssSelSize :: Maybe Int + , _ssSelColor :: Maybe Color , _ssMinSize :: Int , _ssPriority :: Int , _ssOffset :: Int , _ssRestriction :: SSRestriction , _ssShownItems :: [Picture] + , _ssIndent :: Int } diff --git a/src/Dodge/DisplayInventory.hs b/src/Dodge/DisplayInventory.hs index 2d9f5e562..c50ab7933 100644 --- a/src/Dodge/DisplayInventory.hs +++ b/src/Dodge/DisplayInventory.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE TupleSections #-} module Dodge.DisplayInventory where +import Data.Maybe +import Picture.Text +import Dodge.Inventory.ItemSpace import Picture.Base import Dodge.Render.HUD import Dodge.SelectionList @@ -14,60 +18,128 @@ import Dodge.Default.World import Dodge.Data.SelectionList import Dodge.Data.World -makeDisplayInventory :: World -> Configuration -> SelectionSections () -makeDisplayInventory w cfig = defaultDisplaySections +updateDisplayInventory :: World -> Configuration -> SelectionSections () -> SelectionSections () +updateDisplayInventory w cfig sss = sss { _sssSections = restrictsections - , _sssSelPos = Just 0 + , _sssSelPos = mspos , _sssMaxSize = availablelines } where - initialsections = IM.fromList - [ (0, inventorysection) - , (1, makeYouSection w) - , (2, closesection) - ] - inventorysection = makeInventorySection w - closesection = makeCloseObjectsSection w - itotallength = length . foldMap _siPictures $ _ssItems inventorysection - ctotallength = length . foldMap _siPictures $ _ssItems closesection + mspos = do + cr <- w ^? cWorld . lWorld . creatures . ix 0 + mo <- cr ^? crInvSel . isel + case mo of + SelItem {} -> Just 0 + SelNothing -> Just 1 + SelCloseObject {} -> Just 2 availablelines = getAvailableListLines (invDisplayParams w) cfig iavailablelines = availablelines - 6 - minlengths = sum $ fmap _ssMinSize initialsections - sections | itotallength + 1 + ctotallength > availablelines = restrictsections - | otherwise = initialsections - ioffset = 1 + oldoffset = sss ^? sssSections . ix 0 . ssOffset restrictsections = IM.fromList - [ (0, makeInventorySection w & ssShownItems %~ (take iavailablelines . drop ioffset)) + [ (0, makeInventorySection iavailablelines oldoffset w ) , (1, makeYouSection w) , (2, makeCloseObjectsSection w) ] +makeDisplayInventory :: World -> Configuration -> SelectionSections () +makeDisplayInventory w cfig = defaultDisplaySections + { _sssSections = restrictsections + , _sssSelPos = mspos + , _sssMaxSize = availablelines + } + where + mspos = do + cr <- w ^? cWorld . lWorld . creatures . ix 0 + mo <- cr ^? crInvSel . isel + case mo of + SelItem {} -> Just 0 + SelNothing -> Just 1 + SelCloseObject {} -> Just 2 + availablelines = getAvailableListLines (invDisplayParams w) cfig + iavailablelines = availablelines - 6 + restrictsections = IM.fromList + [ (0, makeInventorySection iavailablelines (Just 0) w ) + , (1, makeYouSection w) + , (2, makeCloseObjectsSection w) + ] -makeInventorySection :: World -> SelectionSection () -makeInventorySection w = SelectionSection +makeInventorySection :: Int -> Maybe Int -> World -> SelectionSection () +makeInventorySection iavailablelines moldoffset w = SelectionSection { _ssItems = map (invSelectionItem cr ) (IM.toList inv) - , _ssSelPos = Just 0 + , _ssSelPos = fmap (subtract offset) selpos + , _ssSelSize = selsize + , _ssSelColor = selcolor , _ssRestriction = NoSSRestriction , _ssPriority = 0 - , _ssOffset = 0 + , _ssOffset = offset + , _ssIndent = 0 -- , _ssRegex = "" -- , _ssRegexInput = False , _ssMinSize = 5 -- , _ssOffset = 0 - , _ssShownItems = foldMap (f . invSelectionItem cr ) (IM.toList inv) + , _ssShownItems = shownitems } where + jselpos = fromMaybe 0 selpos + oldoffset = fromMaybe 0 moldoffset + xselsize = fromMaybe 1 selsize + offset + | jselpos == 0 || not mustrestrict = 0 + | jselpos - 1 < oldoffset = jselpos - 1 + | islastitm = jselpos - iavailablelines + xselsize + | jselpos + 1 + xselsize - iavailablelines > oldoffset = jselpos - iavailablelines + 1 + xselsize + | length allstrings - oldoffset < iavailablelines = length allstrings - iavailablelines + | otherwise = oldoffset + tweakfirst (x:xs) + | offset > 0 = hup x : map h xs + | otherwise = map h (x:xs) + tweakfirst [] = [] + shownitems + | length shownstrings > iavailablelines + = tweakfirst (take (iavailablelines - 1) shownstrings) + ++ [hdown $ shownstrings !! (iavailablelines -1)] + | otherwise = tweakfirst shownstrings + allstrings :: [(Color,String)] + allstrings = foldMap (g . invSelectionItem cr ) (IM.toList inv) + mustrestrict = length allstrings > iavailablelines + shownstrings :: [(Color,String)] + shownstrings = drop offset allstrings cr = you w inv = _crInv cr + h (col,str) = color col . text $ str + --hdown (col,str) = textGrad col (withAlpha 0 col) str + --hup (col,str) = textGrad (withAlpha 0 col) col str + hdown (col,str) = color white $ text ">>> MORE INV ITEMS" + hup (col,str) = color white $ text "<<< MORE INV ITEMS" f si = map (color (_siColor si) . text) $ _siPictures si + g si = map (_siColor si ,) $ _siPictures si + islastitm = fromMaybe False $ do + i <- cr ^? crInvSel . isel . ispItem + k <- fmap fst $ IM.lookupMax (_crInv cr) + return $ k == i + selpos = do + i <- cr ^? crInvSel . isel . ispItem + return . sum . fmap itSlotsTaken . fst . IM.split i $ inv + selsize = do + i <- cr ^? crInvSel . isel . ispItem + itm <- inv ^? ix i + return $ itSlotsTaken itm + selcolor = do + i <- cr ^? crInvSel . isel . ispItem + itm <- inv ^? ix i + return $ _itInvColor itm + makeYouSection :: World -> SelectionSection () makeYouSection w = SelectionSection { _ssItems = [SelectionItem [thetext] 1 True (length thetext) invDimColor 2 ()] - , _ssSelPos = Nothing + , _ssSelPos = Just 0 + , _ssSelSize = Just 1 + , _ssSelColor = Just invDimColor , _ssOffset = 0 , _ssPriority = 1 , _ssRestriction = NoSSRestriction + , _ssIndent = 2 -- , _ssRegex = "" -- , _ssRegexInput = False , _ssMinSize = 1 @@ -85,9 +157,12 @@ makeYouSection w = SelectionSection makeCloseObjectsSection :: World -> SelectionSection () makeCloseObjectsSection w = SelectionSection { _ssItems = map (closeObjectToSelectionItem nfreeslots) (w ^. hud . closeObjects) - , _ssSelPos = Just 0 + , _ssSelPos = selpos + , _ssSelSize = selsize + , _ssSelColor = selcolor , _ssPriority = 1 , _ssOffset = 0 + , _ssIndent = 2 , _ssRestriction = NoSSRestriction -- , _ssRegex = "" -- , _ssRegexInput = False @@ -99,4 +174,19 @@ makeCloseObjectsSection w = SelectionSection f si = map (color (_siColor si) . text) $ _siPictures si cr = you w nfreeslots = crNumFreeSlots cr + selpos = do + i <- cr ^? crInvSel . isel . ispCloseObject + return . sum . map closeobjectsize . take i $ w ^. hud . closeObjects + selsize = do + i <- cr ^? crInvSel . isel . ispCloseObject + obj <- w ^? hud . closeObjects . ix i + return $ closeobjectsize obj + closeobjectsize co = maybe 1 itSlotsTaken (co ^? _Left . flIt) + selcolor = do + i <- cr ^? crInvSel . isel . ispCloseObject + obj <- w ^? hud . closeObjects . ix i + Just $ case obj of + Left flit -> _itInvColor $ _flIt flit + Right bt -> _btColor bt + diff --git a/src/Dodge/HeldScroll.hs b/src/Dodge/HeldScroll.hs index d6ab155ae..ea6e1e354 100644 --- a/src/Dodge/HeldScroll.hs +++ b/src/Dodge/HeldScroll.hs @@ -2,7 +2,7 @@ module Dodge.HeldScroll ( doHeldScroll, ) where -import Dodge.Base.You +--import Dodge.Base.You import Control.Lens hiding ((<|), (|>)) import Data.Sequence import Dodge.Data.Creature diff --git a/src/Dodge/Inventory/SelectionList.hs b/src/Dodge/Inventory/SelectionList.hs index 2601467c1..284d34e27 100644 --- a/src/Dodge/Inventory/SelectionList.hs +++ b/src/Dodge/Inventory/SelectionList.hs @@ -9,11 +9,8 @@ import Dodge.Inventory.Color import Dodge.Item.Display import Dodge.Inventory.ItemSpace import Picture.Base -import Dodge.Inventory.CheckSlots -import Dodge.Base.You import Dodge.Data.SelectionList import Dodge.Data.World -import qualified Data.IntMap.Strict as IM import LensHelp --makeInventorySelectionList :: World -> SelectionList () @@ -21,18 +18,6 @@ import LensHelp -- & slItems .~ inventorySelectionList w -- & slSelPos .~ inventoryCursorPos w -- -inventorySelectionList :: World -> [SelectionItem ()] -inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv) - ++ [SelectionItem [thetext] 1 True (length thetext) invDimColor 2 ()] - ++ map (closeObjectToSelectionItem nfreeslots) (w ^. hud . closeObjects) - where - cr = you w - inv = _crInv cr - nfreeslots = crNumFreeSlots cr - thetext = case nfreeslots of - 0 -> " INVENTORY FULL" - 1 -> " +1 FREE SLOT" - x -> " +" ++ show x ++ " FREE SLOTS" -- --inventoryCursorPos :: World -> Maybe Int --inventoryCursorPos w = case w ^? hud . hudElement . subInventory of diff --git a/src/Dodge/Item/Display.hs b/src/Dodge/Item/Display.hs index f95781073..841639591 100644 --- a/src/Dodge/Item/Display.hs +++ b/src/Dodge/Item/Display.hs @@ -21,7 +21,7 @@ itemDisplayWithNumber numberstr it = (midPadL 15 ' ' thename (' ' : numberstr) ++ theparam) : catMaybes [maybeWarmupStatus it, maybeRateStatus it] ++ moduleStrings it - ++ repeat "*" + ++ repeat "\\" where thename = itemBaseName it theparam = diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 7a69cc189..1027315da 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -21,7 +21,6 @@ import Dodge.Data.SelectionList import Dodge.Data.World import Dodge.Inventory --import Dodge.Inventory.ItemSpace -import Dodge.Inventory.SelectionList --import Dodge.Item.Display import Dodge.Item.Info import Dodge.Render.Connectors @@ -79,13 +78,26 @@ inventoryDisplay sss w cfig = listPicturesAtScaleOff (_ldpPosX ldps) (_ldpPosY ldps) cfig - 0 -- offset - --undefined + 0 pics + <> color thecolor thecursor where + thecolor = fromMaybe white $ do + spos <- _sssSelPos sss + sss ^? sssSections . ix spos . ssSelColor . _Just + thecursor = fromMaybe mempty $ do + sectype <- you w ^? crInvSel . isel + let secnum = case sectype of + SelItem{} -> 0 + SelNothing{} -> 1 + SelCloseObject{} -> 2 + xint <- sss ^? sssSections . ix secnum . ssIndent + spos <- _sssSelPos sss + let y = sum . fmap (length . _ssShownItems) . fst . IM.split spos $ _sssSections sss + yint <- sss ^? sssSections . ix spos . ssSelPos . _Just + csize <- sss ^? sssSections . ix spos . ssSelSize . _Just + return $ listCursorDisplayParams ldps [North,South,West] cfig (yint + y) xint white 15 csize ldps = invDisplayParams w --- pics' = take (_sssMaxSize sss) pics --- totallength = length pics' pics = foldMap (_ssShownItems) (_sssSections sss) drawSubInventory :: SubInventory -> Configuration -> World -> Picture @@ -187,7 +199,7 @@ examineInventoryExtra mtweaki mitm cfig = tweaki <- mtweaki -- consider moving this functionality out into a tweaks module tparam <- mitm ^? _Just . itTweaks . tweakParams . ix tweaki - return $ listCursorNSW subInvX 60 cfig tweaki white (length $ showTweak tparam) 15 + return $ listCursorNSW subInvX 60 cfig tweaki 0 white (length $ showTweak tparam) 15 -- , drawSelectionList thirdColumnParams cfig (thirdColumnPara (itmInfo mitm)) ] @@ -327,14 +339,14 @@ lnkMidPosInvSelsCol cfig w i col = hw = halfWidth cfig topCursorTypeWidth :: - (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture) -> + (Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture) -> Int -> Configuration -> World -> Int -> Picture topCursorTypeWidth ctype width cfig w i = - ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (invSelSize i w) + ctype 0 0 cfig (selNumPos i w) 0 (selNumCol i w) width (invSelSize i w) determineInvSelCursorWidth :: World -> Int determineInvSelCursorWidth w = case _rbOptions w of diff --git a/src/Dodge/Render/InfoBox.hs b/src/Dodge/Render/InfoBox.hs index f3448d5f3..647320f89 100644 --- a/src/Dodge/Render/InfoBox.hs +++ b/src/Dodge/Render/InfoBox.hs @@ -15,7 +15,7 @@ renderInfoListAt :: Float -> Float -> Configuration -> CamPos -> (Point2, [Strin renderInfoListAt x y cfig cam (p, ss) = renderListAt x y cfig (zip ss (repeat white)) <> winScale cfig (color white $ lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p)) - <> listCursorNSW x y cfig 0 white 19 (length ss) + <> listCursorNSW x y cfig 0 0 white 19 (length ss) where hw = halfWidth cfig hh = halfHeight cfig diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 3b3af3b9d..0a9f38bbe 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -60,7 +60,7 @@ drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do NoCursor -> Nothing let j = sum . map _siHeight $ take i lis col = _siColor selit - return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j col wdth (_siHeight selit) + return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j 0 col wdth (_siHeight selit) where wdth = case _ldpWidth ldps of FixedSelectionWidth x -> x @@ -74,7 +74,7 @@ drawCursorAt' ldps cfig i lis = fromMaybe mempty $ do NoCursor -> Nothing let j = getIthPos i lis col = _siColor selit - return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j col wdth (_siHeight selit) + return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j 0 col wdth (_siHeight selit) where wdth = case _ldpWidth ldps of FixedSelectionWidth x -> x @@ -109,6 +109,24 @@ 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 ..] +listCursorDisplayParams :: + ListDisplayParams -> + [CardinalPoint] -> + Configuration -> + Int -> + Int -> + Color -> + Int -> + Int -> + Picture +listCursorDisplayParams ldp borders cfig yint xint col cursxsize cursysize = + listCursorChooseBorderScale ygap s borders xoff yoff cfig yint xint col cursxsize cursysize + where + ygap = _ldpVerticalGap ldp + s = _ldpScale ldp + xoff = _ldpPosX ldp + yoff = _ldpPosY ldp + -- displays a cursor that should match up to list text pictures -- the width of a character appears to be 9(?!) -- this is probably because it is 8 pixels plus one for the border @@ -120,14 +138,15 @@ listCursorChooseBorderScale :: Float -> Configuration -> Int -> + Int -> Color -> Int -> Int -> Picture -listCursorChooseBorderScale ygap s borders xoff yoff cfig yint col cursxsize cursysize = +listCursorChooseBorderScale ygap s borders xoff yoff cfig yint xint col cursxsize cursysize = winScale cfig . translate - (15 - (9 * s) + xoff - halfWidth cfig) + (15 + (9 * s * (fromIntegral xint - 1)) + xoff - halfWidth cfig) (halfHeight cfig + s * 12.5 - (yoff + (s * 10 + ygap) * (fromIntegral yint + 1))) . color col $ chooseCursorBorders (s * wth) (s * hgt) borders @@ -140,7 +159,7 @@ listCursorChooseBorderScale ygap s borders xoff yoff cfig yint col cursxsize cur -- the width of a character appears to be 9(?!) -- this is probably because it is 8 pixels plus one for the border listCursorChooseBorder :: - [CardinalPoint] -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture + [CardinalPoint] -> Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture listCursorChooseBorder = listCursorChooseBorderScale 10 1 -- note we cannot simply scale lines because they are drawn as solid rectangles @@ -155,16 +174,16 @@ chooseCursorBorders wth hgt = foldMap (line . toLine) toLine South = [V2 wth bot, V2 lef bot] toLine West = [V2 lef bot, V2 lef top] -listCursorNS :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture +listCursorNS :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture listCursorNS = listCursorChooseBorder [North, South] -listCursorNES :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture +listCursorNES :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture listCursorNES = listCursorChooseBorder [North, South, East] -listCursorNESW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture +listCursorNESW :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture listCursorNESW = listCursorChooseBorder [North, South, East, West] -listCursorNSW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture +listCursorNSW :: Float -> Float -> Configuration -> Int -> Int -> Color -> Int -> Int -> Picture listCursorNSW = listCursorChooseBorder [North, South, West] fillScreenText :: Configuration -> String -> Picture diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 55f4413d5..16b9777f3 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -82,9 +82,8 @@ updateUniverse u = cfig = u ^. uvConfig updateInventoryDisplay :: Universe -> Universe -updateInventoryDisplay u = u & uvWorld . hud . hudElement . diSections %~ const di - where - di = makeDisplayInventory (_uvWorld u) (_uvConfig u) +updateInventoryDisplay u = u & uvWorld . hud . hudElement . diSections + %~ updateDisplayInventory (_uvWorld u) (_uvConfig u) maybeOpenTerminal :: Universe -> Universe maybeOpenTerminal u = case u ^. uvWorld . input . pressedKeys . at ScancodeSemicolon of diff --git a/src/SelectionIntMap.hs b/src/SelectionIntMap.hs index 96581599a..701337dbc 100644 --- a/src/SelectionIntMap.hs +++ b/src/SelectionIntMap.hs @@ -56,5 +56,5 @@ getIthYOffset ygap scale sm i = (scale * 10 + ygap) * (fromIntegral yint + 1) where yint = getIthPos i (sm ^. smShownItems) -selectionSectionsToIntMap :: SelectionSections a -> SelectionIntMap a -selectionSectionsToIntMap ss = undefined +--selectionSectionsToIntMap :: SelectionSections a -> SelectionIntMap a +--selectionSectionsToIntMap ss = undefined