From 0872a2dd402b71e25a62d055546fefbf6a4cd53d Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 2 Nov 2022 21:47:15 +0000 Subject: [PATCH] Work on a selection list datatype --- src/Dodge/Data/SelectionList.hs | 10 +++ src/Dodge/Render/HUD.hs | 151 ++++++++++++++++++-------------- src/Dodge/Render/List.hs | 20 +++++ src/ListHelp.hs | 23 +++++ 4 files changed, 139 insertions(+), 65 deletions(-) diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index 7b2f9e780..c43dbd0dd 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/src/Dodge/Data/SelectionList.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} module Dodge.Data.SelectionList where +import Color import Picture.Data import Control.Lens @@ -12,14 +13,23 @@ data SelectionList = SelectionList , _slItems :: [SelectionItem] , _slSelPos :: Maybe Int , _slCursorType :: CursorType + , _slWidth :: SelectionWidth } +data SelectionWidth = FixedSelectionWidth Int + | VariableSelectionWidth [Int] + data CursorType = NoCursor + | NSEWCursor + | NSWCursor + | NSCursor data SelectionItem = SelectionItem { _siPictures :: [Picture] , _siHeight :: Int , _siIsSelectable :: Bool + , _siColor :: Color + , _siOffX :: Int } makeLenses ''SelectionList diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 9ac52c754..78fe0eada 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -31,18 +31,18 @@ hudDrawings :: Universe -> Picture hudDrawings uv = case w ^. cWorld . lWorld . hud . hudElement of DisplayCarte -> drawCarte cfig w DisplayInventory subinv -> - drawInGameHUD uv + drawInGameHUD subinv uv <> subInventoryDisplay subinv cfig w where w = _uvWorld uv cfig = _uvConfig uv -drawInGameHUD :: Universe -> Picture -drawInGameHUD uv = +drawInGameHUD :: SubInventory -> Universe -> Picture +drawInGameHUD subinv uv = pictures [ winScale cfig . dShadCol white $ displayHP 0 cfig w , listPicturesAt (halfWidth cfig) 0 cfig $ map text (_uvTestString uv uv) - , inventoryDisplay cfig w + , inventoryDisplay subinv cfig w ] where w = _uvWorld uv @@ -58,11 +58,25 @@ defaultSelectionList = SelectionList , _slItems = [] , _slSelPos = Nothing , _slCursorType = NoCursor + , _slWidth = FixedSelectionWidth 15 + } + +subInvSelectionList :: SelectionList +subInvSelectionList = SelectionList + { _slVerticalGap = 10 + , _slScale = 1 + , _slPosX = subInvX + , _slPosY = 60 + , _slOffset = 0 + , _slItems = [] + , _slSelPos = Nothing + , _slCursorType = NoCursor + , _slWidth = FixedSelectionWidth 15 } inventorySelectionList :: World -> [SelectionItem] inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv) - ++ [SelectionItem displayFreeSlots 1 False] + ++ [SelectionItem displayFreeSlots 1 False white 0] ++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects) where cr = you w @@ -73,58 +87,48 @@ inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv) 1 -> [color invDimColor . text $ " +1 FREE SLOT"] x -> [color invDimColor . text $ " +" ++ show x ++ " FREE SLOTS"] -inventoryDisplay :: Configuration -> World -> Picture -inventoryDisplay cfig w = drawSelectionList cfig (defaultSelectionList & slItems .~ inventorySelectionList w) ---inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist +inventoryCursorPos :: SubInventory -> World -> Maybe Int +inventoryCursorPos subinv w = case subinv of + CombineInventory {} -> Nothing + _ -> Just $ yourInvSel w + +inventoryDisplay :: SubInventory -> Configuration -> World -> Picture +inventoryDisplay subinv cfig w = drawSelectionList cfig $ + defaultSelectionList & slItems .~ inventorySelectionList w + & slWidth .~ FixedSelectionWidth topInvW + & slCursorType .~ selcursortype + & slSelPos .~ inventoryCursorPos subinv w + & slWidth .~ FixedSelectionWidth (determineInvSelCursorWidth w) where - cr = you w - inv = _crInv cr - invlist = - concatMap (itemText' cr) (IM.toList inv) - ++ displayFreeSlots - ++ concatMap (closeObjectToTextPictures nfreeslots) (w ^. cWorld . lWorld . closeObjects) - -- ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w)) - -- floorItemsColor = case _hudElement (_hud w) of - -- DisplayInventory NoSubInventory -> id - -- _ -> color invDimColor - nfreeslots = crNumFreeSlots cr - displayFreeSlots = case nfreeslots of - 0 -> [color invDimColor . text $ " INVENTORY FULL"] - 1 -> [color invDimColor . text $ " +1 FREE SLOT"] - x -> [color invDimColor . text $ " +" ++ show x ++ " FREE SLOTS"] + selcursortype + | ButtonRight `M.member` _mouseButtons (_input w) = NSEWCursor + | otherwise = NSWCursor subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture subInventoryDisplay subinv cfig w = case subinv of LockedInventory -> mempty -- topInvCursor col cursPos cfig w NoSubInventory -> pictures - [ selcursor - , closeobjectcursor + [ closeobjectcursor , equipcursors , equipcursor -- the order is important, this should go on top of the other equipcursors , rboptions ] TweakInventory mtweaki -> - pictures - --[ mCurs it cfig w + titledSub "TWEAK" (subInvSelectionList & slItems .~ ammoTweakSelectionItems it) [ selcursor' listCursorNESW - , -- , cursorsZ cfig curpos it - fromMaybe mempty $ do + , fromMaybe mempty $ do tweaki <- mtweaki -- consider moving this functionality out into a tweaks module tparam <- it ^? _Just . itTweaks . tweakParams . ix tweaki return $ lnkMidInvSel cfig w curpos tweaki <> listCursorNSW subInvX 60 cfig tweaki white (length $ showTweak tparam) 1 - , invHead cfig "TWEAK" - , listPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it) ] DisplayTerminal tid -> displayTerminal tid cfig (w ^. cWorld . lWorld) CombineInventory mi -> - pictures - [ invHead cfig "COMBINE" - , listPicturesAt subInvX 60 cfig $ combineListStringPictures w - , fromMaybe mempty $ do + titledSub "COMBINE" (combineListSelection w) + [ fromMaybe mempty $ do i <- mi cpos <- combinePoss w !? i col <- (combineItemListYou w !? i) <&> _itInvColor . snd @@ -145,12 +149,13 @@ subInventoryDisplay subinv cfig w = case subinv of ] ] InspectInventory -> - mconcat + titledSub "INSPECT" (subInvSelectionList & slItems .~ textSelItems (itmInfo it)) [ selcursor' listCursorNESW - , invHead cfig "INSPECT" - , listPicturesAt subInvX 60 cfig $ map text (itmInfo it) ] where + titledSub subtitle subitems extrapics = pictures $ [invHead cfig subtitle + ,drawSelectionList cfig subitems] <> + extrapics closeobjectcursor = case selectedCloseObject w of Nothing -> mempty Just (i, co) -> @@ -166,10 +171,6 @@ subInventoryDisplay subinv cfig w = case subinv of cr = you w it = yourItem w selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol (determineInvSelCursorWidth w) cury <$ it - selcursor = selcursor' selcursortype - selcursortype - | ButtonRight `M.member` _mouseButtons (_input w) = listCursorNESW - | otherwise = listCursorNSW curpos = invSelPos w cury = fromMaybe 1 $ augmentedInvSizes w IM.!? crSel (you w) equipcursor = case _crLeftInvSel cr of @@ -308,14 +309,20 @@ determineInvSelCursorWidth w = case _rbOptions w of then 47 else topInvW ---listSelHeight :: Configuration -> World -> Int -> Float ---listSelHeight +combineListSelection :: World -> SelectionList +combineListSelection w = subInvSelectionList & slItems .~ combineListSelectionItems w -combineListStringPictures :: World -> [Picture] -combineListStringPictures w = case concatMap (itemText . snd) . combineItemListYou $ w of - [] -> [text "NO POSSIBLE COMBINATIONS"] +combineListSelectionItems :: World -> [SelectionItem] +combineListSelectionItems w = case combineListSelectionItems' w of + [] -> [SelectionItem [text "NO POSSIBLE COMBINATIONS"] 1 False white 0] xs -> xs +combineListSelectionItems' :: World -> [SelectionItem] +combineListSelectionItems' w = map (picsToSelectable . itemText . snd) $ combineItemListYou w + +ammoTweakSelectionItems :: Maybe Item -> [SelectionItem] +ammoTweakSelectionItems = textSelItems . ammoTweakStrings + ammoTweakStrings :: Maybe Item -> [String] ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of Just l -> map tweakString $ IM.elems l @@ -340,19 +347,25 @@ closeObjectToSelectionItem n e = SelectionItem { _siPictures = pics , _siHeight = length pics , _siIsSelectable = True + , _siColor = col + , _siOffX = 2 } where - pics = closeObjectToTextPictures n e + (pics,col) = closeObjectToTextPictures' n e -closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture] -closeObjectToTextPictures nfreeslots e = case e of - Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ itemDisplay it - Right bt -> [color yellow $ textindent $ _btText bt] +closeObjectToTextPictures' :: Int -> Either FloorItem Button -> ([Picture],Color) +closeObjectToTextPictures' nfreeslots e = case e of + Left flit -> let it = _flIt flit + in (map (applycolor it . textindent) $ itemDisplay it, thecol it) + Right bt -> ([color yellow $ textindent $ _btText bt], yellow) where textindent = text . (replicate clObjIntIn ' ' ++) applycolor it | nfreeslots >= itSlotsTaken it = color $ _itInvColor it | otherwise = color invDimColor + thecol it + | nfreeslots >= itSlotsTaken it = _itInvColor it + | otherwise = invDimColor clObjIntIn :: Int clObjIntIn = 2 @@ -432,24 +445,32 @@ mapWall cfig thehud wl = mainListCursor :: Color -> Int -> Configuration -> Picture mainListCursor c = openCursorAt 120 c 5 0 -invSelectionItem :: Creature -> (Int,Item) -> SelectionItem -invSelectionItem cr x = SelectionItem +picsToSelectable :: [Picture] -> SelectionItem +picsToSelectable pics = SelectionItem { _siPictures = pics , _siHeight = length pics , _siIsSelectable = True + , _siColor = white + , _siOffX = 0 + } + +textSelItems :: [String] -> [SelectionItem] +textSelItems = map (picsToSelectable . (:[]) . text) + +invSelectionItem :: Creature -> (Int,Item) -> SelectionItem +invSelectionItem cr (i,it) = SelectionItem + { _siPictures = pics + , _siHeight = length pics + , _siIsSelectable = True + , _siColor = col + , _siOffX = 0 } where - pics = itemText' cr x - -itemText' :: Creature -> (Int, Item) -> [Picture] -{-# INLINE itemText' #-} -itemText' cr (i, it) = f $ case _itCurseStatus it of - UndroppableIdentified -> map (color yellow . text) (itemDisplay it) - _ | crSel cr == i -> map (color thecolor . text) (selectedItemDisplay cr it) - _ -> map (color thecolor . text) (itemDisplay it) - where - thecolor = _itInvColor it - f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*")) + col = _itInvColor it + pics = take (itSlotsTaken it) . (++ replicate 10 (color col $ text "*")) $ case _itCurseStatus it of + UndroppableIdentified -> map (color yellow . text) (itemDisplay it) + _ | crSel cr == i -> map (color col . text) (selectedItemDisplay cr it) + _ -> map (color col . text) (itemDisplay it) itemText :: Item -> [Picture] {-# INLINE itemText #-} diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index fa737b24e..9b3bfd738 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -1,5 +1,6 @@ module Dodge.Render.List where +import ListHelp import Dodge.Data.SelectionList import Data.Foldable import Data.Maybe @@ -18,6 +19,25 @@ drawSelectionList cfig sl = listPicturesAtScaleOff cfig (_slOffset sl) (concatMap _siPictures (_slItems sl)) + <> drawSelectionCursor cfig sl + +drawSelectionCursor :: Configuration -> SelectionList -> Picture +drawSelectionCursor cfig sl = fromMaybe mempty $ do + i <- _slSelPos sl + selit <- (filter _siIsSelectable lis) !? i + f <- case _slCursorType sl of + NSEWCursor -> Just listCursorNESW + NSWCursor -> Just listCursorNSW + NSCursor -> Just listCursorNS + NoCursor -> Nothing + let j = sum . map _siHeight $ takeWhileArb (<= i) (\x itsel -> x + if _siIsSelectable itsel then 1 else 0) 0 lis + col = _siColor selit + return $ f (_slPosX sl + (9 * fromIntegral (_siOffX selit))) (_slPosY sl) cfig j col wdth (_siHeight selit) + where + lis = _slItems sl + wdth = case _slWidth sl of + FixedSelectionWidth x -> x + _ -> 1 -- given a list of pictures that are each the size of a "text" call, displays them as -- a list on the screen diff --git a/src/ListHelp.hs b/src/ListHelp.hs index 4181051f5..2ceed735f 100644 --- a/src/ListHelp.hs +++ b/src/ListHelp.hs @@ -14,9 +14,14 @@ module ListHelp , merge , mergeBy , mergeOn + + , takeWhileArb + , takeWhileArb' + , foldrWhileArb ) where import Data.List import Data.Ord +import FoldableHelp loopPairs :: [a] -> [(a,a)] loopPairs (a:as) = snd $ foldr f (Just a,[]) (a:as) @@ -85,3 +90,21 @@ mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a] mergeOn f xs = map snd . mergeBy (comparing fst) (g xs) . g where g = map (\x -> let y = f x in y `seq` (y,x)) + +-- | A generalised version of takeWhile +takeWhileArb :: (a -> Bool) -> (a -> b -> a) -> a -> [b] -> [b] +takeWhileArb _ _ _ [] = [] +takeWhileArb t f y (x:xs) = case f y x of + y' | t y' -> x : takeWhileArb t f y' xs + | otherwise -> [] + +-- this may fuse better +-- should do tests +takeWhileArb' :: (a -> Bool) -> (a -> b -> a) -> a -> [b] -> [b] +takeWhileArb' t f a0 = snd . ssfold (t . fst) (\(a0',xs) x -> (f a0' x,x:xs)) (a0,[]) + +foldrWhileArb :: (b -> c -> c) -> c -> (a -> Bool) -> (a -> b -> a) -> a -> [b] -> c +foldrWhileArb _ z _ _ _ [] = z +foldrWhileArb h z t f y (x:xs) = case f y x of + y' | t y' -> h x $ foldrWhileArb h z t f y' xs + | otherwise -> h x z