Fix scroll selection of floor items and buttons

2022-12-25 23:37:42 +00:00
parent 2ae7f2bbc1
commit d2141d90ae
13 changed files with 75 additions and 126 deletions
@@ -3,6 +3,7 @@ module Dodge.Render.HUD (
    drawHUD,
 ) where

+import Dodge.Inventory.SelectionList
 import Dodge.Data.CardinalPoint
 import Dodge.Data.SelectionList
 import Control.Lens
@@ -33,17 +34,18 @@ drawHUD :: Universe -> Picture
 drawHUD uv = case w ^. cWorld . lWorld . hud . hudElement of
    DisplayCarte -> drawCarte cfig w
    DisplayInventory subinv ->
-        drawInGameHUD subinv uv
+        drawInGameHUD sl uv
            <> drawSubInventory subinv cfig w
  where
+    sl = makeInventorySelectionList w
    w = _uvWorld uv
    cfig = _uvConfig uv

-drawInGameHUD :: SubInventory -> Universe -> Picture
-drawInGameHUD subinv uv =
+drawInGameHUD :: SelectionList () -> Universe -> Picture
+drawInGameHUD sl uv =
    pictures
        [ winScale cfig . dShadCol white $ displayHP 0 cfig w
-        , inventoryDisplay subinv cfig w
+        , inventoryDisplay sl cfig w
        ]
  where
    w = _uvWorld uv
@@ -59,13 +61,6 @@ defaultListDisplayParams  = ListDisplayParams
    , _ldpWidth = FixedSelectionWidth 15
    } 

-defaultSelectionList :: SelectionList a
-defaultSelectionList = SelectionList
-    {_slItems = []
-    , _slSelPos = Nothing
-    , _slLength = 0
-    }
-
 subInvListDisplayParams :: ListDisplayParams
 subInvListDisplayParams = ListDisplayParams
    { _ldpVerticalGap = 10
@@ -83,25 +78,6 @@ subInvSelectionList = SelectionList
    , _slLength = 0
    }

-inventorySelectionList :: World -> [SelectionItem ()]
-inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
-    ++ [SelectionItem displayFreeSlots 1 True (length thetext) invDimColor 2 ()]
-            ++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . 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"
-    displayFreeSlots = [color invDimColor $ text thetext]
-
-inventoryCursorPos :: SubInventory -> World -> Maybe Int
-inventoryCursorPos subinv w = case subinv of
-    CombineInventory {} -> Nothing
-    _ -> Just $ yourInvSel w
-
 invDisplayParams :: World -> ListDisplayParams
 invDisplayParams w = defaultListDisplayParams
    & ldpWidth .~ FixedSelectionWidth topInvW
@@ -112,10 +88,8 @@ invDisplayParams w = defaultListDisplayParams
        | ButtonRight `M.member` _mouseButtons (_input w) = [North,South,East,West]
        | otherwise = [North,South,West]

-inventoryDisplay :: SubInventory -> Configuration -> World -> Picture
-inventoryDisplay subinv cfig w = drawSelectionList (invDisplayParams w) cfig $
-    defaultSelectionList & slItems .~ inventorySelectionList w
-        & slSelPos .~ inventoryCursorPos subinv w
+inventoryDisplay :: SelectionList () -> Configuration -> World -> Picture
+inventoryDisplay sl cfig w = drawSelectionList (invDisplayParams w) cfig sl

 drawSubInventory :: SubInventory -> Configuration -> World -> Picture
 drawSubInventory subinv cfig w = case subinv of
@@ -171,15 +145,16 @@ drawSubInventory subinv cfig w = case subinv of
        extrapics
    closeobjectcursor = case selectedCloseObject w of
        Nothing -> mempty
-        Just (i, co) ->
-            listCursorNS
-                clObjFloatIn
-                0
-                cfig
-                (selNumPos i w)
-                (closeObjectCol co)
-                topInvW
-                (invSelSize i w)
+        Just (i,co) -> drawCursorAt (invDisplayParams w & ldpCursorType .~ BorderCursor (Set.fromList [North,South])) cfig (Just i) (inventorySelectionList w)
+--        Just (i, co) ->
+--            listCursorNS
+--                clObjFloatIn
+--                0
+--                cfig
+--                (selNumPos i w)
+--                (closeObjectCol co)
+--                topInvW
+--                (invSelSize i w)
    itcol = fromMaybe (greyN 0.5) (it ^? _Just . itInvColor)
    cr = you w
    it = yourItem w
@@ -356,38 +331,8 @@ invHead cfig s =
        $ text s


-closeObjectToSelectionItem :: Int -> Either FloorItem Button -> SelectionItem ()
-closeObjectToSelectionItem n e = SelectionItem
-    { _siPictures = pics
-    , _siHeight = length pics
-    , _siIsSelectable = True
-    , _siWidth = 15
-    , _siColor = col
-    , _siOffX = 2
-    , _siPayload = ()
-    }
-  where
-    (pics,col) = closeObjectToTextPictures' n e
-
-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
-
-clObjFloatIn :: Float
-clObjFloatIn = fromIntegral clObjIntIn * 9
+--clObjFloatIn :: Float
+--clObjFloatIn = fromIntegral clObjIntIn * 9

 drawCarte :: Configuration -> World -> Picture
 drawCarte cfig w =
@@ -475,23 +420,6 @@ picsToSelectable wdth pics = SelectionItem
 textSelItems :: [String] -> [SelectionItem ()]
 textSelItems = map (picsToSelectable 15 . (:[]) . text)

-invSelectionItem :: Creature -> (Int,Item) -> SelectionItem ()
-invSelectionItem cr (i,it) = SelectionItem
-    { _siPictures = pics
-    , _siHeight = length pics
-    , _siIsSelectable = True
-    , _siWidth = 15
-    , _siColor = col
-    , _siOffX = 0
-    , _siPayload = ()
-    }
-  where
-    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 #-}
 itemText it = f $ case _itCurseStatus it of
@@ -12,7 +12,7 @@ import Dodge.Data.SelectionList
 import Geometry
 import ListHelp
 import Picture
--import LensHelp
+import LensHelp

 drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
 drawSelectionList ldps cfig sl =
@@ -32,9 +32,10 @@ makeSelectionListPictures sl = concatMap _siPictures $ _slItems sl
 --    SelectionSizeRestriction {} -> concatMap (_siPictures . fst) $ _slShownItems sl
 --    _ -> concatMap _siPictures $ _slItems sl

-drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
-drawSelectionCursor ldps cfig sl = fromMaybe mempty $ do
-    i <- _slSelPos sl
+
+drawCursorAt :: ListDisplayParams -> Configuration -> Maybe Int -> [SelectionItem a] -> Picture
+drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do
+    i <- mi
    selit <- lis !? i
    f <- case _ldpCursorType ldps of
        BorderCursor cps -> Just $ listCursorChooseBorderScale (_ldpVerticalGap ldps) (_ldpScale ldps) cps
@@ -43,11 +44,13 @@ drawSelectionCursor ldps cfig sl = fromMaybe mempty $ do
        col = _siColor selit
    return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j col wdth (_siHeight selit)
  where
-    lis = _slItems sl
    wdth = case _ldpWidth ldps of
        FixedSelectionWidth x -> x
        _ -> 1

+drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
+drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (sl ^. slSelPos) (sl ^. slItems)
+
 -- given a list of pictures that are each the size of a "text" call, displays them as
 -- a list on the screen
 listPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture