Improve drawRBOptions positioning

This commit is contained in:
2026-01-02 18:36:35 +00:00
parent 71f56c0638
commit 376ce4462c
9 changed files with 86 additions and 81 deletions
+2 -2
View File
@@ -18,8 +18,8 @@ data LDParams = LDP -- List display parameters
} }
data CursorDisplay data CursorDisplay
= BoundaryCursor [CardinalPoint] = BoundCurs [CardinalPoint]
| BackdropCursor | BackdropCurs
data SectionCursor = SectionCursor data SectionCursor = SectionCursor
{ _scurPos :: Int { _scurPos :: Int
+3 -9
View File
@@ -51,19 +51,13 @@ invSelectionItem w indent loc =
-- note the convoluted display of the hotkey/equipment, this was done to avoid a -- note the convoluted display of the hotkey/equipment, this was done to avoid a
-- space leak -- space leak
itemDisplay :: World -> Creature -> CItem -> [String] itemDisplay :: World -> Creature -> CItem -> [String]
itemDisplay w cr ci = -- f itemDisplay w cr ci = basicItemDisplay itm `g` anyextra
basicItemDisplay itm
-- (itemNumberDisplay w cr ci)
`g` anyextra
where where
itm = ci ^. _1 itm = ci ^. _1
NInt itid = itm ^. itID NInt itid = itm ^. itID
--f (x:xs) (y:_) = itemDisplayPad x y : xs g (x:xs) (Just y) = (x <> y) : xs
--f xs _ = xs
--g (x:xs) (y:_) = (rightPad 15 ' ' x ++ y) : xs
g (x:xs) (y:_) = (x ++ y) : xs
g xs _ = xs g xs _ = xs
anyextra = maybeToList (anyscroll <> anyexternal <> anyhotkey <> anyequippos) anyextra = anyscroll <> anyexternal <> anyhotkey <> anyequippos
anyhotkey = fmap hotkeyToString anyhotkey = fmap hotkeyToString
(w ^? cWorld . lWorld . imHotkeys . unNIntMap . ix itid) (w ^? cWorld . lWorld . imHotkeys . unNIntMap . ix itid)
anyequippos = do anyequippos = do
+8 -4
View File
@@ -17,7 +17,8 @@ import Linear
import SDL (MouseButton (..)) import SDL (MouseButton (..))
defaultLDP :: LDParams defaultLDP :: LDParams
defaultLDP = LDP defaultLDP =
LDP
{ _ldpVerticalGap = 0 { _ldpVerticalGap = 0
, _ldpScale = 1 , _ldpScale = 1
, _ldpPos = , _ldpPos =
@@ -32,10 +33,13 @@ invDP :: LDParams
invDP = defaultLDP & ldpPos . spPixelOff .~ V2 16 (-20) invDP = defaultLDP & ldpPos . spPixelOff .~ V2 16 (-20)
invCursorParams :: World -> CursorDisplay invCursorParams :: World -> CursorDisplay
invCursorParams w = BoundaryCursor $ case w ^? hud . subInventory of invCursorParams w = BoundCurs $ case w ^? hud . subInventory of
-- Just ExamineInventory{} -> [North, South, East, West] -- Just ExamineInventory{} -> [North, South, East, West]
Just CombineInventory{} -> [] Just CombineInventory{} -> []
_ | ButtonRight `M.member` _mouseButtons (_input w) -> [North, South, East, West] _
| ButtonRight `M.member` _mouseButtons (_input w)
&& (null $ w ^? rbState . opSel) ->
[North, South, East, West]
_ -> [North, South, West] _ -> [North, South, West]
secondColumnLDP :: LDParams secondColumnLDP :: LDParams
+48 -42
View File
@@ -79,8 +79,8 @@ drawInventory sss w cfig = \case
Just (_ : _) -> Nothing Just (_ : _) -> Nothing
_ -> return . drawItemConnections sss cfig $ invAdj inv _ -> return . drawItemConnections sss cfig $ invAdj inv
drawRootCursor drawRootCursor ::
:: World -> IMSS () -> Maybe Selection -> LDParams -> Config -> Picture World -> IMSS () -> Maybe Selection -> LDParams -> Config -> Picture
drawRootCursor w sss msel ldp cfig = fromMaybe mempty $ do drawRootCursor w sss msel ldp cfig = fromMaybe mempty $ do
cr <- w ^? cWorld . lWorld . creatures . ix 0 cr <- w ^? cWorld . lWorld . creatures . ix 0
guard $ crIsAiming cr guard $ crIsAiming cr
@@ -90,13 +90,17 @@ drawRootCursor w sss msel ldp cfig = fromMaybe mempty $ do
inv' <- w ^? cWorld . lWorld . creatures . ix 0 . crInv inv' <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
let inv = fmap (\k -> w ^?! cWorld . lWorld . items . ix k) inv' let inv = fmap (\k -> w ^?! cWorld . lWorld . items . ix k) inv'
(x, y) <- getRootItemBounds j $ _unNIntMap inv (x, y) <- getRootItemBounds j $ _unNIntMap inv
let curs =
if null (w ^? rbState . opSel)
then BoundCurs [minBound ..]
else BoundCurs [North, South, West]
return $ return $
drawSSMultiCursor drawSSMultiCursor
sss sss
(Just (0, x)) (Just (0, x))
(Just (y - x)) (Just (y - x))
ldp ldp
(BoundaryCursor [minBound ..]) curs
cfig cfig
getRootItemBounds :: Int -> IM.IntMap Item -> Maybe (Int, Int) getRootItemBounds :: Int -> IM.IntMap Item -> Maybe (Int, Int)
@@ -125,7 +129,7 @@ drawMouseOver cfig w =
-- . color white -- . color white
$ selSecDrawCursor invDP curs sss (Sel j i mempty) $ selSecDrawCursor invDP curs sss (Sel j i mempty)
-- curs = BoundaryCursor [West] -- curs = BoundaryCursor [West]
curs = BackdropCursor curs = BackdropCurs
combinvsel = do combinvsel = do
(j, i) <- (j, i) <-
(w ^? input . mouseContext . mcoCombSelect) (w ^? input . mouseContext . mcoCombSelect)
@@ -148,7 +152,7 @@ drawDragSelected cfig w = do
) )
Sel i _ _ <- w ^? hud . diSelection . _Just Sel i _ _ <- w ^? hud . diSelection . _Just
sss <- w ^? hud . diSections sss <- w ^? hud . diSections
let f x = (selSecDrawCursor invDP BackdropCursor sss (Sel i x mempty) <>) let f x = (selSecDrawCursor invDP BackdropCurs sss (Sel i x mempty) <>)
return return
. translateScreenPos cfig (invDP ^. ldpPos) . translateScreenPos cfig (invDP ^. ldpPos)
. color (0.2 *^ white) . color (0.2 *^ white)
@@ -159,7 +163,7 @@ drawDragSelecting :: Config -> World -> Maybe Picture
drawDragSelecting cfig w = do drawDragSelecting cfig w = do
OverInvDragSelect (Just (i, j)) (Just b) <- w ^? input . mouseContext OverInvDragSelect (Just (i, j)) (Just b) <- w ^? input . mouseContext
sss <- w ^? hud . diSections sss <- w ^? hud . diSections
let f x = selSecDrawCursor invDP BackdropCursor sss (Sel i x mempty) let f x = selSecDrawCursor invDP BackdropCurs sss (Sel i x mempty)
return return
. translateScreenPos cfig (invDP ^. ldpPos) . translateScreenPos cfig (invDP ^. ldpPos)
. color (0.2 *^ white) . color (0.2 *^ white)
@@ -189,7 +193,7 @@ drawCombineInventory cfig sss w =
<> foldMap (drawSSCursor sss secondColumnLDP curs cfig) msel <> foldMap (drawSSCursor sss secondColumnLDP curs cfig) msel
<> combineInventoryExtra sss msel cfig w <> combineInventoryExtra sss msel cfig w
where where
curs = BoundaryCursor [North, South, West] curs = BoundCurs [North, South, West]
msel = w ^? hud . subInventory . ciSelection . _Just msel = w ^? hud . subInventory . ciSelection . _Just
drawExamineInventory :: Config -> World -> Picture drawExamineInventory :: Config -> World -> Picture
@@ -259,49 +263,51 @@ drawRBOptions cfig w = fold $ do
sss <- w ^? hud . diSections sss <- w ^? hud . diSections
Sel i' j _ <- w ^? hud . diSelection . _Just Sel i' j _ <- w ^? hud . diSelection . _Just
curpos <- selSecYint i' j sss curpos <- selSecYint i' j sss
itext <- sss ^? ix i' . ssItems . ix j . siPictures . ix 0
ind <- sss ^? ix i' . ssItems . ix j . siOffX
let ytext = drawListElement 0 1 0 curpos . text let ytext = drawListElement 0 1 0 curpos . text
midstr = equipAllocString ae midstr = equipAllocString ae
extrastr = case ae of extrastr = case ae of
SwapEquipment{_allocOldPos = oldp, _allocSwapID = sid} -> SwapEquipment{_allocOldPos = oldp, _allocSwapID = sid} ->
"SWAPS " ++ otheritem sid ++ " ONTO " ++ eqPosText oldp " SWAPS " ++ otheritem sid ++ " ONTO " ++ eqPosText oldp
ReplaceEquipment{_allocRemoveID = rid} -> ReplaceEquipment{_allocRemoveID = rid} ->
"REMOVES " ++ otheritem rid " REMOVES " ++ otheritem rid
_ -> "" _ -> ""
return $ return
--toTopLeft cfig $ . translateScreenPos cfig (invDP ^. ldpPos)
translateScreenPos cfig (invDP ^. ldpPos) $ . translate (10 * fromIntegral (ind + length itext)) 0
--translate 290 (-1) (ytext midstr) $ translate (290 - xt) 0 (ytext midstr)
translate 290 0 (ytext midstr) <> translate
<> translate (120 - xt)
160 0
( listCursor
0 0
( listCursorChooseBorderScale 1
0 (BoundCurs [North, South])
1 curpos
(BoundaryCursor [North, South])
curpos
0
white
21
1
)
<> translate
380
0 0
( drawListYoff (curpos - i) (map (text . eqPosText) eslist) white
<> listCursorChooseBorderScale 0 1 (bc East) (curpos - i) 0 white 7 (length eslist) 25
<> listCursorChooseBorderScale 0 1 (bc West) (curpos + 1) 0 white 7 (length eslist - (i + 1)) 1
<> listCursorChooseBorderScale 0 1 (bc West) (curpos - i) 0 white 7 i )
<> maybetopborder i curpos <> translate
<> maybebottomborder i (length eslist) curpos (380 - xt)
) 0
<> translate 460 0 (ytext extrastr) ( drawListYoff (curpos - i) (map (text . eqPosText) eslist)
<> listCursor 0 1 (bc East) (curpos - i) 0 white 7 (length eslist)
<> listCursor 0 1 (bc West) (curpos + 1) 0 white 7 (length eslist - (i + 1))
<> listCursor 0 1 (bc West) (curpos - i) 0 white 7 i
<> maybetopborder i curpos
<> maybebottomborder i (length eslist) curpos
)
<> translate (460 - xt) 0 (ytext extrastr)
where where
bc x = BoundaryCursor [x] xt = 260
maybetopborder 0 curpos = listCursorChooseBorderScale 0 1 (bc North) curpos 0 white 7 1 bc x = BoundCurs [x]
maybetopborder 0 curpos = listCursor 0 1 (bc North) curpos 0 white 7 1
maybetopborder _ _ = mempty maybetopborder _ _ = mempty
maybebottomborder a b curpos maybebottomborder a b curpos
| a == b - 1 = listCursorChooseBorderScale 0 1 (bc South) curpos 0 white 7 1 | a == b - 1 = listCursor 0 1 (bc South) curpos 0 white 7 1
| otherwise = mempty | otherwise = mempty
otheritem (NInt j) = fromMaybe "" $ do otheritem (NInt j) = fromMaybe "" $ do
itype <- w ^? cWorld . lWorld . items . ix j . itType itype <- w ^? cWorld . lWorld . items . ix j . itType
@@ -344,7 +350,7 @@ combineInventoryExtra sss msel cfig w = fold $ do
translateScreenPos cfig (invDP ^. ldpPos) $ translateScreenPos cfig (invDP ^. ldpPos) $
selSecDrawCursor selSecDrawCursor
invDP invDP
(BoundaryCursor [North, South, East, West]) (BoundCurs [North, South, East, West])
(w ^. hud . diSections) (w ^. hud . diSections)
(Sel 0 i mempty) (Sel 0 i mempty)
@@ -353,7 +359,7 @@ drawTerminalDisplay w cfig tid = fold $ do
tm <- w ^? cWorld . lWorld . terminals . ix tid tm <- w ^? cWorld . lWorld . terminals . ix tid
let toselitm (str, col) = SelItem [str] 1 55 True col 0 Nothing NoSIDisplayMod let toselitm (str, col) = SelItem [str] 1 55 True col 0 Nothing NoSIDisplayMod
f = f =
--toselitm ("TERMINAL " ++ show tid, white) -- toselitm ("TERMINAL " ++ show tid, white)
toselitm ("", white) toselitm ("", white)
: ( map (toselitm . (_1 %~ (" " <>))) : ( map (toselitm . (_1 %~ (" " <>)))
. displayTermInput . displayTermInput
@@ -395,7 +401,7 @@ drawTerminalCursorLink w cfig tm = fold $ do
(invDP ^. ldpPos) (invDP ^. ldpPos)
( selSecDrawCursor ( selSecDrawCursor
invDP invDP
(BoundaryCursor [North, South, East, West]) (BoundCurs [North, South, East, West])
(w ^. hud . diSections) (w ^. hud . diSections)
(Sel 5 j mempty) (Sel 5 j mempty)
) )
+2 -2
View File
@@ -28,10 +28,10 @@ renderInfoListAt x y cfig cam (p, ss) =
<> toTopLeft <> toTopLeft
cfig cfig
( translate x (- y) $ ( translate x (- y) $
listCursorChooseBorderScale listCursor
0 0
1 1
(BoundaryCursor [North, South]) (BoundCurs [North, South])
0 0
0 0
white white
+7 -7
View File
@@ -10,7 +10,7 @@ module Dodge.Render.List (
drawListYoff, drawListYoff,
stackPicturesAt, stackPicturesAt,
toTopLeft, toTopLeft,
listCursorChooseBorderScale, listCursor,
selSecDrawCursor, selSecDrawCursor,
drawTitleBackground, -- should be renamed, made sensible drawTitleBackground, -- should be renamed, made sensible
drawCursorAt, drawCursorAt,
@@ -76,7 +76,7 @@ drawCursorAt mi lis ldps width curs = fromMaybe mempty $ do
i <- mi i <- mi
selit <- lis !? i selit <- lis !? i
return $ return $
listCursorChooseBorderScale listCursor
(_ldpVerticalGap ldps) (_ldpVerticalGap ldps)
(_ldpScale ldps) (_ldpScale ldps)
curs curs
@@ -106,7 +106,7 @@ selSecDrawCursor ldp curs sss sel = fold $ do
sindent <- sss ^? ix i . ssIndent sindent <- sss ^? ix i . ssIndent
si <- sss ^? ix i . ssItems . ix j si <- sss ^? ix i . ssItems . ix j
return $ return $
listCursorChooseBorderScale listCursor
(ldp ^. ldpVerticalGap) (ldp ^. ldpVerticalGap)
(ldp ^. ldpScale) (ldp ^. ldpScale)
curs curs
@@ -117,7 +117,7 @@ selSecDrawCursor ldp curs sss sel = fold $ do
(_siHeight si) (_siHeight si)
-- displays a cursor that should match up to list text pictures -- displays a cursor that should match up to list text pictures
listCursorChooseBorderScale :: listCursor ::
Float -> Float ->
Float -> Float ->
CursorDisplay -> CursorDisplay ->
@@ -127,7 +127,7 @@ listCursorChooseBorderScale ::
Int -> Int ->
Int -> Int ->
Picture Picture
listCursorChooseBorderScale ygap s curs yint xint col cursxsize cursysize = listCursor ygap s curs yint xint col cursxsize cursysize =
translate translate
((10 * fromIntegral xint - 5) * s) ((10 * fromIntegral xint - 5) * s)
(-(ygap + (s * 20 + ygap) * fromIntegral yint)) (-(ygap + (s * 20 + ygap) * fromIntegral yint))
@@ -140,8 +140,8 @@ listCursorChooseBorderScale ygap s curs yint xint col cursxsize cursysize =
-- note we cannot simply scale lines because they are drawn as solid rectangles -- note we cannot simply scale lines because they are drawn as solid rectangles
chooseCursorBorders :: Float -> Float -> CursorDisplay -> Picture chooseCursorBorders :: Float -> Float -> CursorDisplay -> Picture
chooseCursorBorders w h = \case chooseCursorBorders w h = \case
BoundaryCursor ps -> foldMap (line . toLine) ps BoundCurs ps -> foldMap (line . toLine) ps
BackdropCursor -> polygon $ rectNSWE 0 h' 0 w BackdropCurs -> polygon $ rectNSWE 0 h' 0 w
where where
h' = negate h h' = negate h
toLine North = [V2 0 0, V2 w 0] toLine North = [V2 0 0, V2 w 0]
+1 -1
View File
@@ -41,7 +41,7 @@ drawOptions title msel sl cf =
<> translateScreenPos <> translateScreenPos
cf cf
(menuLDP ^. ldpPos) (menuLDP ^. ldpPos)
(drawCursorAt msel sl menuLDP 50 (BoundaryCursor [North, South])) (drawCursorAt msel sl menuLDP 50 (BoundCurs [North, South]))
darkenBackground :: Config -> Picture darkenBackground :: Config -> Picture
darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
+14 -13
View File
@@ -10,17 +10,17 @@ module Dodge.SelectionSections (
inverseSelNumPos, inverseSelNumPos,
) where ) where
import Dodge.Data.HUD
import Dodge.Data.CardinalPoint
import qualified Data.IntSet as IS
import Control.Applicative import Control.Applicative
import qualified Control.Foldl as L import qualified Control.Foldl as L
import Control.Lens import Control.Lens
import Control.Monad import Control.Monad
import Data.Foldable import Data.Foldable
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Data.Maybe import Data.Maybe
import Dodge.Data.CardinalPoint
import Dodge.Data.Config import Dodge.Data.Config
import Dodge.Data.HUD
import Dodge.Data.SelectionList import Dodge.Data.SelectionList
import Dodge.ScreenPos import Dodge.ScreenPos
import Geometry.Data import Geometry.Data
@@ -86,14 +86,14 @@ ssLookupDown i j sss = case ssLookupGT i j sss of
ssLookupNextMax :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a) ssLookupNextMax :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupNextMax i j sss = case ssLookupGT i j sss of ssLookupNextMax i j sss = case ssLookupGT i j sss of
Just x@(i',j',_) | i' == i && j' > j -> Just x Just x@(i', j', _) | i' == i && j' > j -> Just x
_ -> ssLookupMaxInSection i sss <|> ssLookupDown i j sss _ -> ssLookupMaxInSection i sss <|> ssLookupDown i j sss
ssLookupMaxInSection :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a) ssLookupMaxInSection :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupMaxInSection i sss = do ssLookupMaxInSection i sss = do
ss <- sss ^? ix i . ssItems ss <- sss ^? ix i . ssItems
(j,s) <- IM.lookupMax ss (j, s) <- IM.lookupMax ss
return (i,j,s) return (i, j, s)
ssLookupLT :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a) ssLookupLT :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
ssLookupLT i j sss = fromMaybe (ssLookupLT' i sss) $ do ssLookupLT i j sss = fromMaybe (ssLookupLT' i sss) $ do
@@ -152,7 +152,8 @@ posSelSecYint cfig ldp y = floor $ (y0 - y) / (20 / ldp ^. ldpScale + ldp ^. ldp
selSecYint :: Int -> Int -> IMSS a -> Maybe Int selSecYint :: Int -> Int -> IMSS a -> Maybe Int
selSecYint i j sss = do selSecYint i j sss = do
ss <- sss ^? ix i ss <- sss ^? ix i
return . (secpos +) return
. (secpos +)
. subtract (ss ^. ssOffset) . subtract (ss ^. ssOffset)
. sum . sum
. fmap _siHeight . fmap _siHeight
@@ -162,7 +163,7 @@ selSecYint i j sss = do
secpos = sum . fmap _ssShownLength . fst $ IM.split i sss secpos = sum . fmap _ssShownLength . fst $ IM.split i sss
inverseSelSecYint :: Int -> IMSS a -> XInfinity (Int, Int) inverseSelSecYint :: Int -> IMSS a -> XInfinity (Int, Int)
inverseSelSecYint yint sss inverseSelSecYint yint sss
| yint < 0 = NegInf | yint < 0 = NegInf
| otherwise = fromMaybe PosInf $ do | otherwise = fromMaybe PosInf $ do
((i, ss), othersss) <- IM.minViewWithKey sss ((i, ss), othersss) <- IM.minViewWithKey sss
@@ -171,19 +172,19 @@ inverseSelSecYint yint sss
then return $ inverseSelSecYint (yint - l) othersss then return $ inverseSelSecYint (yint - l) othersss
else do else do
let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss) let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss)
(j,_) <- L.fold (L.find (\(_,x) -> x - _ssOffset ss > yint)) $ IM.toList ls (j, _) <- L.fold (L.find (\(_, x) -> x - _ssOffset ss > yint)) $ IM.toList ls
return $ NonInf (i, j) return $ NonInf (i, j)
inverseSelSecYintXPosCheck :: inverseSelSecYintXPosCheck ::
Config -> LDParams -> Float -> Int -> IMSS a -> Maybe (Int,Int) Config -> LDParams -> Float -> Int -> IMSS a -> Maybe (Int, Int)
inverseSelSecYintXPosCheck cfig ldp x yint sss = do inverseSelSecYintXPosCheck cfig ldp x yint sss = do
(i,j) <- inverseSelSecYint yint sss ^? nonInf (i, j) <- inverseSelSecYint yint sss ^? nonInf
let V2 x0 _ = screenPosAbs cfig (ldp ^. ldpPos) let V2 x0 _ = screenPosAbs cfig (ldp ^. ldpPos)
sindent <- sss ^? ix i . ssIndent sindent <- sss ^? ix i . ssIndent
itindent <- sss ^? ix i . ssItems . ix j . siOffX itindent <- sss ^? ix i . ssItems . ix j . siOffX
let x1 = x0 + _ldpScale ldp * 10 * (fromIntegral (sindent + itindent) - 0.5) let x1 = x0 + _ldpScale ldp * 10 * (fromIntegral (sindent + itindent) - 0.5)
guard $ x - x1 < 160 && x > x1 guard $ x - x1 < 160 && x > x1
return (i,j) return (i, j)
inverseSelNumPos :: Config -> LDParams -> Point2 -> IMSS a -> Maybe (Int, Int) inverseSelNumPos :: Config -> LDParams -> Point2 -> IMSS a -> Maybe (Int, Int)
inverseSelNumPos cfig ldp (V2 x y) = inverseSelNumPos cfig ldp (V2 x y) =
+1 -1
View File
@@ -55,7 +55,7 @@ drawSSMultiCursor sss msel mextra ldp curs cfig = translateScreenPos cfig (ldp ^
maxxoff = maximum . fmap _siOffX $ selitms maxxoff = maximum . fmap _siOffX $ selitms
minxoff = minimum . fmap _siOffX $ selitms minxoff = minimum . fmap _siOffX $ selitms
return $ return $
listCursorChooseBorderScale listCursor
(ldp ^. ldpVerticalGap) (ldp ^. ldpVerticalGap)
(ldp ^. ldpScale) (ldp ^. ldpScale)
curs curs