From 312f342e0931a1dcd479a0f4d28b8fecd3c641e1 Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 10 May 2023 18:01:14 +0100 Subject: [PATCH] Color scroll lines in inventory display --- src/Dodge/DisplayInventory.hs | 38 +++++++++++++++++++++------------- src/Dodge/ListDisplayParams.hs | 2 +- src/Dodge/Render/HUD.hs | 3 ++- src/Picture/Base.hs | 5 +++++ 4 files changed, 32 insertions(+), 16 deletions(-) diff --git a/src/Dodge/DisplayInventory.hs b/src/Dodge/DisplayInventory.hs index ad6cb99f7..c5ef74d70 100644 --- a/src/Dodge/DisplayInventory.hs +++ b/src/Dodge/DisplayInventory.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TupleSections #-} + --{-# OPTIONS_GHC -fno-full-laziness #-} module Dodge.DisplayInventory ( @@ -8,21 +9,21 @@ module Dodge.DisplayInventory ( updateCombinePositioning, ) where -import Dodge.ListDisplayParams -import ListHelp -import Dodge.Data.Combine import Control.Monad import qualified Data.IntMap.Strict as IM import Data.Maybe import Dodge.Base.You import Dodge.Combine +import Dodge.Data.Combine import Dodge.Data.Config import Dodge.Data.SelectionList import Dodge.Data.Universe import Dodge.Inventory.CheckSlots import Dodge.Inventory.SelectionList +import Dodge.ListDisplayParams import Dodge.SelectionList import LensHelp +import ListHelp import Picture.Base import Regex @@ -32,7 +33,8 @@ toggleCombineInv uv = case uv ^? uvWorld . hud . hudElement . subInventory of _ -> uv & uvWorld %~ enterCombineInv (uv ^. uvConfig) updateCombinePositioning :: Universe -> Universe -updateCombinePositioning u = u & uvWorld . hud . hudElement . subInventory . ciSections +updateCombinePositioning u = + u & uvWorld . hud . hudElement . subInventory . ciSections %~ updateCombineSections (_uvWorld u) (_uvConfig u) updateCombineSections :: World -> Configuration -> SelectionSections CombinableItem -> SelectionSections CombinableItem @@ -64,7 +66,7 @@ updateCombineSections w cfig sss = regexCombs :: IM.IntMap (SelectionItem ()) -> SelectionItem CombinableItem -> String -> Bool regexCombs inv ci str = case str of - '<':str' -> f str' ci + '<' : str' -> f str' ci _ -> (regexList str . _siPictures) ci where f str' si = any (g str') (_ciInvIDs $ _siPayload si) @@ -81,7 +83,8 @@ orRegex f x str = case words str of xs -> any (f x) xs updateInventoryPositioning :: Universe -> Universe -updateInventoryPositioning u = u & uvWorld . hud . hudElement . diSections +updateInventoryPositioning u = + u & uvWorld . hud . hudElement . diSections %~ updateDisplaySections (_uvWorld u) (_uvConfig u) updateDisplaySections :: World -> Configuration -> SelectionSections () -> SelectionSections () @@ -129,14 +132,14 @@ updateDisplaySections w cfig sss = return $ IM.filter (plainRegex str) itms numfiltitems = " " ++ show (length itms - length itms') ++ " FILTERED" - invDimColor :: Color invDimColor = greyN 0.7 -- it is annoying that this is necessary updateInventorySectionItems :: World -> World -updateInventorySectionItems w = w - & hud . hudElement . diSections . sssSections . ix 0 . ssItems %~ f +updateInventorySectionItems w = + w + & hud . hudElement . diSections . sssSections . ix 0 . ssItems %~ f where f olditems = fromMaybe olditems $ do cr <- w ^? cWorld . lWorld . creatures . ix 0 @@ -197,9 +200,10 @@ updateSection sis mcsel availablelines ss = csize = length $ _siPictures si ccolor = _siColor si return $ SectionCursor (cpos - offset) csize ccolor - nocursoroffset = if length allstrings - oldoffset <= availablelines - then max 0 (length allstrings - availablelines) - else oldoffset + nocursoroffset = + if length allstrings - oldoffset <= availablelines + then max 0 (length allstrings - availablelines) + else oldoffset offset = fromMaybe nocursoroffset $ do csel <- mcsel maxcsel <- fst <$> IM.lookupMax sis @@ -223,14 +227,20 @@ updateSection sis mcsel availablelines ss = length allstrings - availablelines _ -> oldoffset tweakfirst (x : xs) - | offset > 0 = xtra "<<<" : map h xs + -- -- a| offset > 0 = xtra "<<<" : map h xs + | offset > 0 = + translate 0 (-100) (color moreupcolor $ text (theindent ++ replicate 15 '^')) : + map h xs | otherwise = map h (x : xs) tweakfirst [] = [] + moreupcolor = fromMaybe white $ allstrings ^? ix offset . _1 shownitems | length shownstrings > availablelines = tweakfirst (take (availablelines - 1) shownstrings) - ++ [xtra ">>>"] + -- ++ [xtra ">>>"] + ++ [translate 0 100 . color moredowncolor . vMirrorText $ theindent ++ replicate 15 '^'] | otherwise = tweakfirst shownstrings + moredowncolor = fromMaybe white $ allstrings ^? ix (offset + availablelines - 1) . _1 allstrings :: [(Color, String)] allstrings = foldMap g sis shownstrings = drop offset allstrings diff --git a/src/Dodge/ListDisplayParams.hs b/src/Dodge/ListDisplayParams.hs index c8d9811f7..da84cba51 100644 --- a/src/Dodge/ListDisplayParams.hs +++ b/src/Dodge/ListDisplayParams.hs @@ -71,6 +71,6 @@ optionListDisplayParams = & ldpPos . spPixelOff .~ V2 11 (-70) & ldpScale .~ 2 & ldpVerticalGap .~ 0 - & ldpWidth .~ FixedSelectionWidth 25 + & ldpWidth .~ FixedSelectionWidth 50 & ldpCursorSides .~ [North, South, West] diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 5f287371e..23f1918b4 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -236,7 +236,8 @@ tweakString tp = rightPad 12 ' ' (show $ _tweakType tp) ++ " " ++ showTweak tp invHead :: Configuration -> String -> Picture invHead cfig = - translate (- halfWidth cfig + subInvX + 20) (halfHeight cfig - 40) + translateScreenPos cfig (fromTopLeft (V2 (subInvX + 20) 80)) + -- (- halfWidth cfig + subInvX + 20) (halfHeight cfig - 80) . dShadCol white . scale 0.4 0.4 . text diff --git a/src/Picture/Base.hs b/src/Picture/Base.hs index 2fe4a30b5..8e78d570d 100644 --- a/src/Picture/Base.hs +++ b/src/Picture/Base.hs @@ -45,6 +45,7 @@ module Picture.Base ( mirrorxz, overPos, picMap, + vMirrorText, ) where import Color @@ -205,6 +206,10 @@ text :: String -> Picture text = drawText 0 --text = drawText (-10) +vMirrorText :: String -> Picture +{-# INLINE vMirrorText #-} +vMirrorText = translate 0 200 . scale 1 (-1) . text + drawText :: Float -> String -> [Verx] {-# INLINE drawText #-} drawText gap = map f . stringToList gap