From 6e7cd14f49382e72ce27f5bcc1ce6c6f9fba6e1d Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 3 Nov 2022 14:16:28 +0000 Subject: [PATCH] Work on mouse selection in menus --- src/Dodge/Menu.hs | 2 + src/Dodge/Menu/Option.hs | 58 ++++++++++++++++++++++++++ src/Dodge/Render/List.hs | 71 +++++++++++++++++++------------- src/Dodge/Render/MenuScreen.hs | 44 ++------------------ src/Dodge/Render/Picture.hs | 21 +--------- src/Dodge/Render/ShapePicture.hs | 7 +--- src/Dodge/Update.hs | 26 +++++++++++- 7 files changed, 133 insertions(+), 96 deletions(-) diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 380ef2558..5df417410 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -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") diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs index c83b1d52b..0595a97fd 100644 --- a/src/Dodge/Menu/Option.hs +++ b/src/Dodge/Menu/Option.hs @@ -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 diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 57f0f252a..6ffede68d 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -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 = diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index da61a5bfd..232539c07 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index ca0aa60c4..1ddc25ead 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -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 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index aba56dd3c..13e212783 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -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))) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 812fd8fe1..8ee64f74d 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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