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

Handle menu selection with mouse context, remove wheel scroll control

Browse Source
This commit is contained in:
justin
2024-11-17 12:32:05 +00:00
parent 53d8ca2861
commit 5b6c356bab
9 changed files with 147 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/SelectionList.hs
+1 -1
View File
@@ -23,7 +23,7 @@ data CursorDisplay
data SelectionList a = SelectionList
{ _slItems :: [SelectionItem a]
, _slSelPos :: Maybe Int
-- , _slSelPos :: Maybe Int
}
data SectionCursor = SectionCursor
src/Dodge/Default/SelectionList.hs
-1
View File
@@ -5,5 +5,4 @@ import Dodge.Data.SelectionList
defaultSelectionList :: SelectionList a
defaultSelectionList = SelectionList
{_slItems = mempty
, _slSelPos = Nothing
}
src/Dodge/Menu/Option.hs
+1 -1
View File
@@ -53,7 +53,7 @@ makeOptionsSelectionList ::
makeOptionsSelectionList maxlines mselpos u mos pmo =
defaultSelectionList
{ _slItems = optionsToSelections maxlines u mos pmo
, _slSelPos = mselpos
-- , _slSelPos = mselpos
}
optionsToSelections ::
src/Dodge/Render/List.hs
+6 -5
View File
@@ -14,6 +14,7 @@ module Dodge.Render.List (
listCursorChooseBorderScale,
selSecDrawCursorAt,
drawTitleBackground, -- should be renamed, made sensible
drawCursorAt,
) where
import Dodge.ListDisplayParams
@@ -38,11 +39,11 @@ drawSelectionList ldps cfig sl =
(ldps ^. ldpScale)
0
(makeSelectionListPictures sl)
<> drawCursorAt
(sl ^. slSelPos)
(sl ^. slItems)
ldps
(BoundaryCursor [North, South])
-- <> drawCursorAt
-- (sl ^. slSelPos)
-- (sl ^. slItems)
-- ldps
-- (BoundaryCursor [North, South])
drawTitleBackground :: Configuration -> Picture
drawTitleBackground cfig =
src/Dodge/Render/MenuScreen.hs
+16 -7
View File
@@ -3,16 +3,19 @@ module Dodge.Render.MenuScreen (
drawMenuScreen,
) where
import Dodge.ScreenPos
import Dodge.Data.CardinalPoint
import Control.Lens
import Dodge.Render.List
import Dodge.Base.Window
import Dodge.Data.SelectionList
import Dodge.Data.Universe
import Dodge.Render.List
import Picture
drawMenuScreen :: Configuration -> ScreenLayer -> Picture
drawMenuScreen cfig screen = case screen of
OptionScreen{_scTitle = titf, _scSelectionList = selpos, _scListDisplayParams = ldps} ->
drawOptions ldps cfig titf selpos
drawMenuScreen :: Configuration -> Maybe Int -> ScreenLayer -> Picture
drawMenuScreen cfig spos screen = case screen of
OptionScreen{_scTitle = titf, _scSelectionList = slist, _scListDisplayParams = ldps} ->
drawOptions ldps cfig titf spos slist
InputScreen inputstr help -> drawInputMenu cfig ('>' : inputstr) help
drawInputMenu ::
@@ -34,13 +37,19 @@ drawOptions ::
Configuration ->
-- | Title
String ->
-- | Select position
Maybe Int ->
SelectionList a ->
Picture
drawOptions ldps cfig title sl =
drawOptions ldps cfig title msel sl =
darkenBackground cfig
<> drawTitle cfig title
<> drawSelectionList ldps cfig sl
<> translateScreenPos cfig (ldps ^. ldpPos) (drawCursorAt
msel
(sl ^. slItems)
ldps
(BoundaryCursor [North, South])
)
darkenBackground :: Configuration -> Picture
darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -57,7 +57,7 @@ fpsText x = color col . text $ "ms/frame " ++ show x
drawMenuOrHUD :: Configuration -> Universe -> Picture
drawMenuOrHUD cfig u = case u ^. uvScreenLayers of
[] -> drawHUD (u ^. uvConfig) (u ^. uvWorld)
(lay : _) -> drawMenuScreen cfig lay
(lay : _) -> drawMenuScreen cfig (u ^? uvWorld . input . mouseContext . mcoMenuClick) lay
drawConcurrentMessage :: Universe -> Picture
drawConcurrentMessage u =
src/Dodge/Update/Input/ScreenLayer.hs
+36 -36
View File
@@ -41,10 +41,10 @@ optionScreenUpdate :: Universe -> Universe
optionScreenUpdate u =
(uvScreenLayers . ix 0 . scDisplayTime +~ 1)
. refreshOptionsSelectionList
. mouseOverSelectionList
-- . mouseOverSelectionList
. optionScreenDefaultEffect
. mouseClickOptionsList
. menuWheelEvents
-- . menuWheelEvents
. over (uvScreenLayers . _head) (setSelectionListRestriction (u ^. uvConfig))
$ u
@@ -61,32 +61,32 @@ mouseClickOptionsList u = fromMaybe u $ do
sl <- u ^? uvScreenLayers . ix 0 . scSelectionList
Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
Just 0 -> fromMaybe u $ do
i <- sl ^. slSelPos
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
f <- sl ^? slItems . ix i . siPayload . _1
return $ f u
_ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of
Just 0 -> fromMaybe u $ do
i <- sl ^. slSelPos
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
f <- sl ^? slItems . ix i . siPayload . _2
return $ f u
_ -> u
mouseOverSelectionList :: Universe -> Universe
mouseOverSelectionList u = fromMaybe u $ do
screen <- u ^? uvScreenLayers . ix 0
ldps <- screen ^? scListDisplayParams
let ymax = maybe 0 length $ screen ^? scSelectionList . slItems
yi <- ldpVerticalSelection (u ^. uvConfig) ldps (u ^. uvWorld . input . mousePos)
guard $ mmoving || (_scDisplayTime screen <= 1)
let myi = do
guard (yi >= 0 && yi < ymax && isselectable yi)
return yi
return $ u & uvScreenLayers . _head . scSelectionList . slSelPos .~ myi
where
isselectable yi =
fromMaybe False $
u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yi . siIsSelectable
mmoving = u ^. uvWorld . input . mouseMoving
--mouseOverSelectionList :: Universe -> Universe
--mouseOverSelectionList u = fromMaybe u $ do
-- screen <- u ^? uvScreenLayers . ix 0
-- ldps <- screen ^? scListDisplayParams
-- let ymax = maybe 0 length $ screen ^? scSelectionList . slItems
-- yi <- ldpVerticalSelection (u ^. uvConfig) ldps (u ^. uvWorld . input . mousePos)
-- guard $ mmoving || (_scDisplayTime screen <= 1)
-- let myi = do
-- guard (yi >= 0 && yi < ymax && isselectable yi)
-- return yi
-- return $ u & uvScreenLayers . _head . scSelectionList . slSelPos .~ myi
-- where
-- isselectable yi =
-- fromMaybe False $
-- u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yi . siIsSelectable
-- mmoving = u ^. uvWorld . input . mouseMoving
ldpVerticalSelection :: Configuration -> ListDisplayParams -> Point2 -> Maybe Int
ldpVerticalSelection cfig ldp (V2 _ y)
@@ -101,23 +101,23 @@ ldpVerticalSelection cfig ldp (V2 _ y)
yupper = floor $ (top - (y + ygap)) / yoff
ylower = ceiling ((top - y) / yoff) - 1
menuWheelEvents :: Universe -> Universe
menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
where
y = u ^. uvWorld . input . scrollAmount
--menuWheelEvents :: Universe -> Universe
--menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
-- where
-- y = u ^. uvWorld . input . scrollAmount
-- you probably want i to be 1 or -1
menuWheelStep :: Int -> Universe -> Universe
menuWheelStep i u = fromMaybe u $ do
sl <- u ^? uvScreenLayers . _head . scSelectionList
selpos <- sl ^? slSelPos . _Just
ymax <- fmap length (sl ^? slItems)
let newpos = (selpos - i) `mod` ymax
itm <- sl ^? slItems . ix newpos
let newu = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ const newpos
if _siIsSelectable itm
then Just newu
else Just $ menuWheelStep i newu
---- you probably want i to be 1 or -1
--menuWheelStep :: Int -> Universe -> Universe
--menuWheelStep i u = fromMaybe u $ do
-- sl <- u ^? uvScreenLayers . _head . scSelectionList
-- selpos <- sl ^? slSelPos . _Just
-- ymax <- fmap length (sl ^? slItems)
-- let newpos = (selpos - i) `mod` ymax
-- itm <- sl ^? slItems . ix newpos
-- let newu = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ const newpos
-- if _siIsSelectable itm
-- then Just newu
-- else Just $ menuWheelStep i newu
setSelectionListRestriction :: Configuration -> ScreenLayer -> ScreenLayer
setSelectionListRestriction cfig screen = fromMaybe screen $ do