justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Improve drawRBOptions positioning

Browse Source
This commit is contained in:
justin
2026-01-02 18:36:35 +00:00
parent 71f56c0638
commit 376ce4462c
9 changed files with 86 additions and 81 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/SelectionList.hs
+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
src/Dodge/Inventory/SelectionList.hs
+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
src/Dodge/ListDisplayParams.hs
+7 -3
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
src/Dodge/Render/HUD.hs
+32 -26
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,6 +263,8 @@ 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
@@ -267,41 +273,41 @@ drawRBOptions cfig w = fold $ do
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
160 (120 - xt)
0 0
( listCursorChooseBorderScale ( listCursor
0 0
1 1
(BoundaryCursor [North, South]) (BoundCurs [North, South])
curpos curpos
0 0
white white
21 25
1 1
) )
<> translate <> translate
380 (380 - xt)
0 0
( drawListYoff (curpos - i) (map (text . eqPosText) eslist) ( drawListYoff (curpos - i) (map (text . eqPosText) eslist)
<> listCursorChooseBorderScale 0 1 (bc East) (curpos - i) 0 white 7 (length eslist) <> listCursor 0 1 (bc East) (curpos - i) 0 white 7 (length eslist)
<> listCursorChooseBorderScale 0 1 (bc West) (curpos + 1) 0 white 7 (length eslist - (i + 1)) <> listCursor 0 1 (bc West) (curpos + 1) 0 white 7 (length eslist - (i + 1))
<> listCursorChooseBorderScale 0 1 (bc West) (curpos - i) 0 white 7 i <> listCursor 0 1 (bc West) (curpos - i) 0 white 7 i
<> maybetopborder i curpos <> maybetopborder i curpos
<> maybebottomborder i (length eslist) curpos <> maybebottomborder i (length eslist) curpos
) )
<> translate 460 0 (ytext extrastr) <> 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)
@@ -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)
) )
src/Dodge/Render/InfoBox.hs
+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
src/Dodge/Render/List.hs
+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]
src/Dodge/Render/MenuScreen.hs
+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
src/Dodge/SelectionSections.hs
+5 -4
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
@@ -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
src/Dodge/SelectionSections/Draw.hs
+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