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

Allow drag selection box sizes to differ from selected box sizes

Browse Source 
More tweaking needs to be done, after deciding a max width for selection
items.
This commit is contained in:
justin
2026-05-17 23:09:33 +01:00
parent 70479b6e79
commit 8010335ffe
7 changed files with 212 additions and 147 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Inventory/Add.hs
-5
View File
@@ -63,7 +63,6 @@ tryPutItemInInvAt mcipos i itid w = do
(j, w') <- tryPutItemInInv mcipos itid w
guard (i <= _unNInt j)
return $ foldr f w' [i + 1 .. _unNInt j]
-- return $ w'
where
f j = swapInvItems (\_ _ -> Just (j -1)) j
@@ -84,7 +83,3 @@ pickUpItemAt :: Int -> (Int,Int) -> World -> World
pickUpItemAt invid (i,itid) w = fromMaybe w $ do
p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
soundStart (CrSound 0) p pickUpS Nothing <$> tryPutItemInInvAt (Just i) invid itid w
-- & _Just . hud . diSections . ix 0 . ssSet %~ IS.map f
where
f j | j >= invid = j +1
| otherwise = j
src/Dodge/Render/HUD.hs
+24 -15
View File
@@ -24,7 +24,7 @@ import Dodge.Data.DoubleTree
import Dodge.Data.EquipType
import Dodge.Data.SelectionList
import Dodge.Data.Terminal.Status
import Dodge.Data.World
import Dodge.Data.Universe
import Dodge.DoubleTree
import Dodge.Equipment.Text
import Dodge.Inventory
@@ -50,26 +50,29 @@ import NewInt
import Picture
import SDL (MouseButton (..))
drawHUD :: Config -> World -> Picture
drawHUD cfig w =
drawInventory (w ^. hud . diSections) w cfig subinv
drawHUD :: Universe -> Picture
drawHUD u =
drawInventory (w ^. hud . diSections) u cfig subinv
<> drawSubInventory subinv cfig w
where
w = u ^. uvWorld
cfig = u ^. uvConfig
subinv = w ^. hud . subInventory
drawInventory :: IMSS () -> World -> Config -> SubInventory -> Picture
drawInventory sss w cfig = \case
drawInventory :: IMSS () -> Universe -> Config -> SubInventory -> Picture
drawInventory sss u cfig = \case
DisplayTerminal{} ->
drawSelectionSections sss invDP cfig
<> itemconnections
<> drawMouseOver cfig w
<> drawMouseOver u
_ ->
drawSelectionSections sss invDP cfig
<> foldMap (drawSSCursor sss invDP curs cfig) (w ^. hud . diSelection)
<> drawRootCursor w sss (w ^. hud . diSelection) invDP cfig
<> itemconnections
<> drawMouseOver cfig w
<> drawMouseOver u
where
w = u ^. uvWorld
curs = invCursorParams w
itemconnections = fromMaybe mempty $ do
inv' <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
@@ -104,12 +107,14 @@ getRootItemBounds i inv = do
y <- locDTLeftmost root ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
return (x, y)
drawMouseOver :: Config -> World -> Picture
drawMouseOver cfig w =
drawMouseOver :: Universe -> Picture
drawMouseOver u =
concat
(invsel <|> combinvsel <|> drawDragSelecting cfig w)
(invsel <|> combinvsel <|> drawDragSelecting u)
<> concat (drawDragSelected cfig w)
where
w = u ^. uvWorld
cfig = u ^. uvConfig
invsel = do
(j, i) <-
w ^? input . mouseContext . mcoInvSelect
@@ -148,13 +153,14 @@ drawDragSelected cfig w = do
<> IS.foldr (f 3) mempty ys3
<> IS.foldr (f 5) mempty ys5
drawDragSelecting :: Config -> World -> Maybe Picture
drawDragSelecting cfig w = do
drawDragSelecting :: Universe -> Maybe Picture
drawDragSelecting u = do
x <- w ^? input . mouseContext . mcoSecSelStart
sss <- w ^? hud . diSections
y <- inverseSelNumPos cfig invDP (w^.input.mousePos) sss
-- y <- inverseSelNumPos cfig invDP (w^.input.mousePos) sss
y <- mouseInvPosFixWidth u
let f i ss
| i ==0 || i == 3 = IM.foldMapWithKey (\j _ -> selSecDrawCursor invDP BackdropCurs sss (Sel i j))
| i ==0 || i == 3 = IM.foldMapWithKey (\j _ -> selSecDrawCursor' invDP BackdropCurs sss (Sel i j))
(ss ^. ssItems)
| otherwise = mempty
return
@@ -162,6 +168,9 @@ drawDragSelecting cfig w = do
. color (0.2 *^ white)
. IM.foldMapWithKey f
$ sssSelectionSlice sss x y
where
w = u ^. uvWorld
cfig = u ^. uvConfig
drawSubInventory :: SubInventory -> Config -> World -> Picture
drawSubInventory subinv cfig w = case subinv of
src/Dodge/Render/List.hs
+21
View File
@@ -12,6 +12,7 @@ module Dodge.Render.List (
toTopLeft,
listCursor,
selSecDrawCursor,
selSecDrawCursor',
drawTitleBackground, -- should be renamed, made sensible
drawCursorAt,
drawLabelledList,
@@ -116,6 +117,26 @@ selSecDrawCursor ldp curs sss sel = fold $ do
(_siWidth si)
(_siHeight si)
selSecDrawCursor' :: LDParams -> CursorDisplay -> IMSS a -> Selection -> Picture
selSecDrawCursor' ldp curs sss sel = fold $ do
let i = sel ^. slSec
j = sel ^. slInt
yint <- selSecYint i j sss
sindent <- sss ^? ix i . ssIndent
si <- sss ^? ix i . ssItems . ix j
return $
listCursor
(ldp ^. ldpVerticalGap)
(ldp ^. ldpScale)
curs
yint
--(_siOffX si)
sindent
(_siColor si)
--(_siWidth si + sindent)
16
(_siHeight si)
-- displays a cursor that should match up to list text pictures
listCursor ::
Float ->
src/Dodge/Render/Picture.hs
+2 -1
View File
@@ -67,9 +67,10 @@ fpsText x = scale 0.2 0.2 . color col . text $ "ms/frame " ++ show x
| x < 50 = orange
| otherwise = red
-- why config and universe here?
drawMenuOrHUD :: Config -> Universe -> Picture
drawMenuOrHUD cf u = case u ^. uvScreenLayers of
[] -> drawHUD (u ^. uvConfig) (u ^. uvWorld)
[] -> drawHUD u
(x : _) -> drawMenuScreen (u ^? uvWorld . input . mouseContext . mcoMenuClick . _Just) x cf
drawConcurrentMessage :: Universe -> Picture
src/Dodge/SelectionSections.hs
+36
View File
@@ -8,11 +8,15 @@ module Dodge.SelectionSections (
inverseSelSecYint,
posSelSecYint,
inverseSelNumPos,
inverseSelNumPosFixedWidth,
mouseInvPosFixWidth,
ssLookupGE,
ssLookupLE,
sssSelectionSlice,
) where
import Dodge.ListDisplayParams
import Dodge.Data.Universe
import Control.Applicative
import qualified Control.Foldl as L
import Control.Lens
@@ -229,10 +233,42 @@ inverseSelSecYintXPosCheck cfig ldp x yint sss = do
guard $ x - x1 < 160 && x > x1
return sel
inverseSelSecYintXPosCheckFixedWidth ::
Config -> LDParams -> Float -> Int -> IMSS a -> Maybe (XInfinity (Int, Int))
inverseSelSecYintXPosCheckFixedWidth cfig ldp x yint sss = do
let sel = inverseSelSecYint yint sss
(i,j) <- case sel of
NonInf v -> Just v
NegInf -> do
(i',j',_) <- ssLookupMin sss
return (i',j')
PosInf -> do
(i',j',_) <- ssLookupMax sss
return (i',j')
let V2 x0 _ = screenPosAbs cfig (ldp ^. ldpPos)
sindent <- sss ^? ix i . ssIndent
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) - 0.5)
guard $ x - x1 < 170 && x > x1
return sel
mouseInvPosFixWidth :: Universe -> Maybe (XInfinity (Int,Int))
mouseInvPosFixWidth u = inverseSelNumPosFixedWidth
(u^.uvConfig)
invDP
(u^.uvWorld. input . mousePos)
(u ^.uvWorld. hud . diSections)
inverseSelNumPos :: Config -> LDParams -> Point2 -> IMSS a -> Maybe (XInfinity (Int, Int))
inverseSelNumPos cfig ldp (V2 x y) =
inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y)
inverseSelNumPosFixedWidth :: Config -> LDParams -> Point2 -> IMSS a -> Maybe (XInfinity (Int, Int))
inverseSelNumPosFixedWidth cfig ldp (V2 x y) =
inverseSelSecYintXPosCheckFixedWidth cfig ldp x (posSelSecYint cfig ldp y)
sssSelectionSlice :: IMSS a -> XInfinity (Int,Int) -> XInfinity (Int,Int) -> IMSS a
sssSelectionSlice sss x1 x2 = fromMaybe mempty $ do
let (xmin,xmax) | x1 < x2 = (x1,x2)
src/Dodge/Update/Input/InGame.hs
+2 -3
View File
@@ -133,8 +133,7 @@ doDrag n k u = fromMaybe u $ do
tryDropSelected :: Universe -> Maybe Universe
tryDropSelected u = do
let mi = mouseInvPos u ^? _Just . nonInf . _1
guard $ maybe True (== 3) mi
guard $ maybe True (== 3) $ mouseInvPos u ^? _Just . nonInf . _1
cr <- w ^? cWorld . lWorld . creatures . ix 0
Sel 0 j <- w ^. hud . diSelection
xs <- selectionSet $ u ^. uvWorld . hud
@@ -194,7 +193,7 @@ updateMouseReleaseInGame u = uvWorld . input . mouseContext .~ MouseInGame
doDragSelect :: XInfinity (Int, Int) -> Universe -> Universe
doDragSelect x u = fromMaybe u $ do
sss <- u ^? uvWorld . hud . diSections
y <- mouseInvPos u
y <- mouseInvPosFixWidth u
return $ IM.foldlWithKey' f u $ sssSelectionSlice sss x y
where
f u' i ss