Work on mouse selection in menus

2022-11-03 14:16:28 +00:00
parent e6e5427f44
commit 6e7cd14f49
7 changed files with 133 additions and 96 deletions
@@ -4,6 +4,7 @@ module Dodge.Menu (
    splashMenu,
 ) where

+import ShortShow
 import Control.Monad
 import Dodge.Concurrent
 import Dodge.Config.Update
@@ -33,6 +34,7 @@ splashMenuOptions =
    basicKeyOptions
        [ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue
        , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelPos . _Just)
+        , Toggle id (\u -> MODString $ shortShow $ u ^. uvWorld . input . mousePos)
        , Toggle ( startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED")
        , Toggle reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
        , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")
@@ -1,6 +1,13 @@
 module Dodge.Menu.Option
    where
+import Dodge.ScodeToChar
+import Padding
+import Picture.Base
+import Color
+import Dodge.Data.CardinalPoint
+import Dodge.Data.SelectionList
 import Dodge.Data.Universe
+import qualified Data.Set as Set

 slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> Universe) -> ScreenLayer
 slTitleOptionsEff title ops eff =
@@ -12,3 +19,54 @@ slTitleOptionsEff title ops eff =
        , _scOptionsOffset = 0
        , _scSelPos = Just 0
        }
+
+makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> SelectionList
+makeOptionsSelectionList mselpos u mos = SelectionList
+    { _slPosX = 50
+    , _slPosY = 50
+    , _slOffset = 0
+    , _slScale = 2
+    , _slVerticalGap = 30
+    , _slItems = optionsToSelections u mos
+    , _slSelPos = mselpos
+    , _slCursorType = BorderCursor (Set.fromList [North,South,West])
+    , _slWidth = FixedSelectionWidth 15
+    }
+
+optionsToSelections :: Universe -> [MenuOption] -> [SelectionItem]
+optionsToSelections u ops = map colStrToSelItem colstrs
+  where
+    maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) visibleops)
+    colstrs = map (menuOptionToString u maxOptionLength) visibleops
+    visibleops = filter notInvisible ops
+    notInvisible InvisibleToggle{} = False
+    notInvisible _ = True
+
+colStrToSelItem :: (Color,String) -> SelectionItem
+colStrToSelItem (col,str) = SelectionItem
+    { _siPictures = [color col $ text str]
+    , _siHeight = 1
+    , _siIsSelectable = True
+    , _siColor = col
+    , _siOffX = 0
+    }
+
+optionValueOffset :: Universe -> MenuOption -> Int
+optionValueOffset u mo = case _moString mo u of
+    MODStringOption s _ -> length s
+    _ -> 0
+
+menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
+menuOptionToString w padAmount mo = (thecol, theKeys ++ optionText)
+  where
+    thecol = case _moString mo w of
+        MODBlockedString{} -> greyN 0.5
+        _ -> white
+    optionText = case _moString mo w of
+        MODStringOption s t -> rightPad padAmount '.' s ++ t
+        x -> _modString x
+    theKeys = case mo of
+        Toggle{_moKey = k} -> stc k : ":"
+        Toggle2{_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":"
+        _ -> undefined
+    stc = scodeToChar
@@ -1,28 +1,29 @@
 module Dodge.Render.List where

-import ListHelp
-import Dodge.Data.SelectionList
 import Data.Foldable
 import Data.Maybe
-import Dodge.Base.WinScale
-import Dodge.Base.Window
-import Dodge.Data.Config
-import Dodge.Data.CardinalPoint
-import Geometry
-import Picture
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Dodge.Base.WinScale
+import Dodge.Base.Window
+import Dodge.Data.CardinalPoint
+import Dodge.Data.Config
+import Dodge.Data.SelectionList
+import Geometry
+import ListHelp
+import Picture

 drawSelectionList :: Configuration -> SelectionList -> Picture
-drawSelectionList cfig sl = listPicturesAtScaleOff 
-    (_slVerticalGap sl) 
-    (_slScale sl)
-    (_slPosX sl)
-    (_slPosY sl)
-    cfig
-    (_slOffset sl)
-    (concatMap _siPictures (_slItems sl))
-    <> drawSelectionCursor cfig sl
+drawSelectionList cfig sl =
+    listPicturesAtScaleOff
+        (_slVerticalGap sl)
+        (_slScale sl)
+        (_slPosX sl)
+        (_slPosY sl)
+        cfig
+        (_slOffset sl)
+        (concatMap _siPictures (_slItems sl))
+        <> drawSelectionCursor cfig sl

 drawSelectionCursor :: Configuration -> SelectionList -> Picture
 drawSelectionCursor cfig sl = fromMaybe mempty $ do
@@ -55,19 +56,28 @@ stackPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
 stackPicturesAt tx ty cfig = stackPicturesAtOff tx ty cfig 0

 stackPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture
-stackPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i, i-1 ..]
+stackPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i, i -1 ..]

 -- displays a cursor that should match up to list text pictures
 -- the width of a character appears to be 9(?!)
 -- this is probably because it is 8 pixels plus one for the border
 listCursorChooseBorderScale ::
    Float ->
-    Float -> Set CardinalPoint -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
+    Float ->
+    Set CardinalPoint ->
+    Float ->
+    Float ->
+    Configuration ->
+    Int ->
+    Color ->
+    Int ->
+    Int ->
+    Picture
 listCursorChooseBorderScale ygap s borders xoff yoff cfig yint col cursxsize cursysize =
    winScale cfig
        . translate
-            (6 + xoff - halfWidth cfig)
-            (halfHeight cfig + 12.5 - (20 * fromIntegral yint + yoff + 20 + hgt + ygap))
+            (15 - (9 * s) + xoff - halfWidth cfig)
+            (halfHeight cfig + negate (yoff - s * 12.5) - ((s * 10 + ygap) * (fromIntegral yint + 1)))
        . color col
        $ chooseCursorBorders (s * wth) (s * hgt) borders
  where
@@ -96,22 +106,25 @@ listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize =
 chooseCursorBorders :: Float -> Float -> Set CardinalPoint -> Picture
 chooseCursorBorders wth hgt = fold . Set.map (line . toLine)
  where
-    toLine North = [V2 0 hgt, V2 wth hgt]
-    toLine East = [V2 wth hgt, V2 wth 0]
-    toLine South = [V2 wth 0, V2 0 0]
-    toLine West = [V2 0 0, V2 0 hgt]
+    top = 0
+    bot = - hgt
+    lef = 0
+    toLine North = [V2 lef top, V2 wth top]
+    toLine East = [V2 wth top, V2 wth bot]
+    toLine South = [V2 wth bot, V2 lef bot]
+    toLine West = [V2 lef bot, V2 lef top]

 listCursorNS :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-listCursorNS = listCursorChooseBorder (Set.fromList [North,South])
+listCursorNS = listCursorChooseBorder (Set.fromList [North, South])

 listCursorNES :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-listCursorNES = listCursorChooseBorder (Set.fromList [North,South,East])
+listCursorNES = listCursorChooseBorder (Set.fromList [North, South, East])

 listCursorNESW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-listCursorNESW = listCursorChooseBorder (Set.fromList [North,South,East,West])
+listCursorNESW = listCursorChooseBorder (Set.fromList [North, South, East, West])

 listCursorNSW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-listCursorNSW = listCursorChooseBorder (Set.fromList [North,South,West])
+listCursorNSW = listCursorChooseBorder (Set.fromList [North, South, West])

 fillScreenText :: Configuration -> String -> Picture
 fillScreenText cfig str =
@@ -4,6 +4,7 @@ module Dodge.Render.MenuScreen (
    menuScreen',
 ) where

+import Dodge.Menu.Option
 import Dodge.Data.CardinalPoint
 import Dodge.Render.List
 import Dodge.Data.SelectionList
@@ -75,8 +76,8 @@ drawOptions ::
    Picture
 drawOptions u title ops off mselpos footer =
    pictures $
-        [ darkenBackground cfig
-        , drawTitle cfig title
+        [ --darkenBackground cfig
+         drawTitle cfig title
        , drawFooterText cfig red footer
        , drawSelectionList cfig (makeOptionsSelectionList mselpos u ops)
        ]
@@ -112,18 +113,6 @@ defaultSelectionItem =  SelectionItem
    , _siOffX = 0
    }

-makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> SelectionList
-makeOptionsSelectionList mselpos u mos = SelectionList
-    { _slPosX = 50
-    , _slPosY = 50
-    , _slOffset = 0
-    , _slScale = 2
-    , _slVerticalGap = 30
-    , _slItems = optionsToSelections u mos
-    , _slSelPos = mselpos
-    , _slCursorType = BorderCursor (Set.fromList [North,South,West])
-    , _slWidth = FixedSelectionWidth 15
-    }
 colStrToSelItem :: (Color,String) -> SelectionItem
 colStrToSelItem (col,str) = SelectionItem
    { _siPictures = [color col $ text str]
@@ -133,19 +122,6 @@ colStrToSelItem (col,str) = SelectionItem
    , _siOffX = 0
    }

-optionsToSelections :: Universe -> [MenuOption] -> [SelectionItem]
-optionsToSelections u ops = map colStrToSelItem colstrs
-  where
-    maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) visibleops)
-    colstrs = map (menuOptionToString u maxOptionLength) visibleops
-    visibleops = filter notInvisible ops
-    notInvisible InvisibleToggle{} = False
-    notInvisible _ = True
-
-optionValueOffset :: Universe -> MenuOption -> Int
-optionValueOffset u mo = case _moString mo u of
-    MODStringOption s _ -> length s
-    _ -> 0

 darkenBackground :: Configuration -> Picture
 darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
@@ -184,17 +160,3 @@ drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
    hh = halfHeight cfig
    hw = halfWidth cfig

-menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
-menuOptionToString w padAmount mo = (thecol, theKeys ++ optionText)
-  where
-    thecol = case _moString mo w of
-        MODBlockedString{} -> greyN 0.5
-        _ -> white
-    optionText = case _moString mo w of
-        MODStringOption s t -> rightPad padAmount '.' s ++ t
-        x -> _modString x
-    theKeys = case mo of
-        Toggle{_moKey = k} -> stc k : ":"
-        Toggle2{_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":"
-        _ -> undefined
-    stc = scodeToChar
@@ -14,16 +14,11 @@ import Picture

 fixedCoordPictures :: Universe -> Picture
 fixedCoordPictures u =
-    drawConcurrentMessage u <> case u ^. uvScreenLayers of
-        [] ->
-            pictures
-                [ hudDrawings u
-                , customMouseCursor cfig w
-                ]
+    drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld) <> case u ^. uvScreenLayers of
+        [] -> hudDrawings u
        (lay : _) -> (setDepth (-1) $ menuScreen' u lay) 
            <> (setDepth (-1) . winScale cfig $ menuScreen u lay)
  where
-    w = _uvWorld u
    cfig = _uvConfig u

 drawConcurrentMessage :: Universe -> Picture
@@ -38,18 +33,6 @@ drawConcurrentMessage u =
    f (RunningSideEffect ce) = ce ++ " IN PROGRESS"
    f x = _ceString x ++ " QUEUED"

--    = case u ^? uvSideEffects . _head of
--    --Just (BlockingConcEffect str) -> fillWidthText cfig str
--    Just (RunningSideEffect str) ->
--        stackPicturesAt
--            (halfWidth cfig)
--            (_windowY cfig - 50)
--            cfig
--            [centerText str]
--    _ -> mempty
--  where
--    cfig = _uvConfig u
-
 customMouseCursor :: Configuration -> World -> Picture
 customMouseCursor cfig w =
    winScale cfig
@@ -40,12 +40,9 @@ import ShapePicture
 import ShortShow
 import Sound.Data

-singleSPic :: SPic -> SPic
-singleSPic = id
-
 worldSPic :: Configuration -> World -> SPic
 worldSPic cfig w =
-    singleSPic (mempty, extraPics cfig w)
+    (mempty, extraPics cfig w)
        <> foldup drawProp' (filtOn _prPos _props)
        <> foldup drawProjectile (filtOn _prjPos _projectiles)
        <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
@@ -55,7 +52,7 @@ worldSPic cfig w =
        <> foldup floorItemSPic (filtOn _flItPos _floorItems)
        <> foldup btSPic (filtOn _btPos _buttons)
        <> foldup mcSPic (filtOn _mcPos _machines)
-        <> singleSPic (anyTargeting cfig w)
+        <> anyTargeting cfig w
  where
    foldup = foldMap'
    filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
@@ -6,6 +6,8 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where

+import Dodge.Menu.Option
+import Dodge.Data.SelectionList
 import Dodge.InputFocus
 import Dodge.Event.Menu
 import Color
@@ -89,10 +91,29 @@ gotoTerminal w = case _uvScreenLayers w of
    (InputScreen{} : _) -> w
    _ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command"

+optionScreenUpdates :: Universe -> Universe
+optionScreenUpdates u = case u ^? uvScreenLayers . _head of
+    Just (OptionScreen {_scOptions = mos, _scSelPos = mselpos}) -> mouseOverSelectionList 
+        (makeOptionsSelectionList mselpos u mos) u
+    _ -> u
+
+mouseOverSelectionList :: SelectionList -> Universe -> Universe
+mouseOverSelectionList sl u
+    | x > xl && x < xr = u & uvScreenLayers . _head . scSelPos .~ Just (ceiling $ y' / 50)
+    | otherwise = u
+  where
+    y' = hh - (75 + y + _slPosY sl)
+    xl = _slPosX sl - hw
+    xr = xl + _slScale sl * 15 * 9
+    V2 x y = u ^. uvWorld . input . mousePos
+    cfig = u ^. uvConfig
+    hh = halfHeight cfig
+    hw = halfWidth cfig
+
 updateUseInput :: Universe -> Universe
 updateUseInput u = case u ^? uvScreenLayers . _head of
    Just (InputScreen thetext _) -> doInputScreenInput thetext u
-    Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff} -> menuWheelEvents $
+    Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff} -> optionScreenUpdates . menuWheelEvents $
        foldl' (\u' scode -> optionListToEffects defeff scode mos u') u (M.keys $ M.filter (== InitialPress) pkeys)
    Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
    _ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
@@ -233,8 +254,9 @@ functionalUpdate w =
        $ over uvWorld updatePastWorlds w

 menuWheelEvents :: Universe -> Universe
-menuWheelEvents u = u & uvScreenLayers . _head . scSelPos . _Just -~ y
+menuWheelEvents u = u & uvScreenLayers . _head . scSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax)
  where
+    ymax = maybe 0 length (u ^? uvScreenLayers . _head . scOptions)
    y = u ^. uvWorld . input . scrollAmount

 updateWheelEvents :: World -> World