Work on mouse selection in menus

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")

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

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 
+drawSelectionList cfig sl =
-    (_slVerticalGap sl) 
+    listPicturesAtScaleOff
-    (_slScale sl)
+        (_slVerticalGap sl)
-    (_slPosX sl)
+        (_slScale sl)
-    (_slPosY sl)
+        (_slPosX sl)
-    cfig
+        (_slPosY sl)
-    (_slOffset sl)
+        cfig
-    (concatMap _siPictures (_slItems sl))
+        (_slOffset sl)
-    <> drawSelectionCursor cfig 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)
+            (15 - (9 * s) + xoff - halfWidth cfig)
-            (halfHeight cfig + 12.5 - (20 * fromIntegral yint + yoff + 20 + hgt + ygap))
+            (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]
+    top = 0
-    toLine East = [V2 wth hgt, V2 wth 0]
+    bot = - hgt
-    toLine South = [V2 wth 0, V2 0 0]
+    lef = 0
-    toLine West = [V2 0 0, V2 0 hgt]
+    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 =

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
+        [ --darkenBackground cfig
-        , drawTitle cfig title
+         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

src/Dodge/Render/Picture.hs

@@ -14,16 +14,11 @@ import Picture
 
 fixedCoordPictures :: Universe -> Picture
 fixedCoordPictures u =
-    drawConcurrentMessage u <> case u ^. uvScreenLayers of
+    drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld) <> case u ^. uvScreenLayers of
-        [] ->
+        [] -> hudDrawings u
-            pictures
-                [ hudDrawings u
-                , customMouseCursor cfig w
-                ]
         (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

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)))

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