Start unifying drawn cursors

src/Dodge/Data/CardinalPoint.hs

@@ -0,0 +1,14 @@
+module Dodge.Data.CardinalPoint where
+
+data CardinalPoint
+    = North
+    | East
+    | South
+    | West
+    deriving (Eq, Ord, Show)
+
+data CardinalCover
+    = NSEW
+    | NSE
+    | NSW
+    | NS

src/Dodge/Data/Room.hs

@@ -1,10 +1,14 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Dodge.Data.Room where
+module Dodge.Data.Room (
+    module Dodge.Data.Room,
+    module Dodge.Data.CardinalPoint,
+) where
 
 import Control.Lens
 import qualified Data.Set as S
+import Dodge.Data.CardinalPoint
 import Geometry
 
 data RoomPos = RoomPos
@@ -44,13 +48,6 @@ data RoomLinkType
     | BlockedLink
     deriving (Eq, Ord, Show)
 
-data CardinalPoint
-    = North
-    | East
-    | South
-    | West
-    deriving (Eq, Ord, Show)
-
 data RoomWire
     = --RoomWire Point2 Float
       WallWire Point2 Float Float

src/Dodge/Data/SelectionList.hs

@@ -3,6 +3,8 @@ module Dodge.Data.SelectionList where
 import Color
 import Picture.Data
 import Control.Lens
+import Data.Set (Set)
+import Dodge.Data.CardinalPoint
 
 data SelectionList = SelectionList
     { _slPosX :: Float
@@ -20,9 +22,7 @@ data SelectionWidth = FixedSelectionWidth Int
     | VariableSelectionWidth [Int]
 
 data CursorType = NoCursor
-    | NSEWCursor
+    | BorderCursor (Set CardinalPoint)
-    | NSWCursor
-    | NSCursor
 
 data SelectionItem = SelectionItem
     { _siPictures :: [Picture]

src/Dodge/Menu.hs

@@ -32,6 +32,7 @@ splashMenuOptions :: [MenuOption]
 splashMenuOptions =
     basicKeyOptions
         [ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue
+        , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelPos . _Just)
         , 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/Render/HUD.hs

@@ -3,6 +3,7 @@ module Dodge.Render.HUD (
     hudDrawings,
 ) where
 
+import Dodge.Data.CardinalPoint
 import Dodge.Data.SelectionList
 import Control.Lens
 import qualified Data.Map.Strict as M
@@ -26,6 +27,7 @@ import ListHelp
 import Padding
 import Picture
 import SDL (MouseButton (..))
+import qualified Data.Set as Set
 
 hudDrawings :: Universe -> Picture
 hudDrawings uv = case w ^. cWorld . lWorld . hud . hudElement of
@@ -96,13 +98,13 @@ inventoryDisplay :: SubInventory -> Configuration -> World -> Picture
 inventoryDisplay subinv cfig w = drawSelectionList cfig $
     defaultSelectionList & slItems .~ inventorySelectionList w
         & slWidth .~ FixedSelectionWidth topInvW
-        & slCursorType .~ selcursortype
+        & slCursorType .~ BorderCursor (Set.fromList selcursortype)
         & slSelPos .~ inventoryCursorPos subinv w
         & slWidth .~ FixedSelectionWidth (determineInvSelCursorWidth w)
   where
     selcursortype
-        | ButtonRight `M.member` _mouseButtons (_input w) = NSEWCursor
+        | ButtonRight `M.member` _mouseButtons (_input w) = [North,South,East,West]
-        | otherwise = NSWCursor
+        | otherwise = [North,South,West]
 
 subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture
 subInventoryDisplay subinv cfig w = case subinv of

src/Dodge/Render/List.hs

@@ -7,8 +7,11 @@ 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
 
 drawSelectionList :: Configuration -> SelectionList -> Picture
 drawSelectionList cfig sl = listPicturesAtScaleOff 
@@ -26,9 +29,7 @@ drawSelectionCursor cfig sl = fromMaybe mempty $ do
     i <- _slSelPos sl
     selit <- (filter _siIsSelectable lis) !? i
     f <- case _slCursorType sl of
-        NSEWCursor -> Just listCursorNESW
+        BorderCursor cps -> Just $ listCursorChooseBorderScale (_slVerticalGap sl) (_slScale sl) cps
-        NSWCursor -> Just listCursorNSW
-        NSCursor -> Just listCursorNS
         NoCursor -> Nothing
     let j = sum . map _siHeight $ takeWhileArb (<= i) (\x itsel -> x + if _siIsSelectable itsel then 1 else 0) 0 lis
         col = _siColor selit
@@ -56,11 +57,29 @@ 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 ..]
 
+-- 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
+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))
+        . color col
+        $ chooseCursorBorders (s * wth) (s * hgt) borders
+  where
+    x = 9
+    wth = x * fromIntegral cursxsize + 9
+    hgt = 20 * fromIntegral cursysize
+
 -- 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
 listCursorChooseBorder ::
-    [Bool] -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
+    Set CardinalPoint -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
 listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize =
     winScale cfig
         . translate
@@ -74,31 +93,25 @@ listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize =
     hgt = 20 * fromIntegral cursysize
 
 -- note we cannot simply scale lines because they are drawn as solid rectangles
-chooseCursorBorders :: Float -> Float -> [Bool] -> Picture
+chooseCursorBorders :: Float -> Float -> Set CardinalPoint -> Picture
-chooseCursorBorders wth hgt =
+chooseCursorBorders wth hgt = fold . Set.map (line . toLine)
-    fold . catMaybes
-        . zipWith
-            f
-            [ line [V2 0 hgt, V2 wth hgt]
-            , line [V2 wth hgt, V2 wth 0]
-            , line [V2 wth 0, V2 0 0]
-            , line [V2 0 0, V2 0 hgt]
-            ]
   where
-    f _ False = Nothing
+    toLine North = [V2 0 hgt, V2 wth hgt]
-    f a True = Just a
+    toLine East = [V2 wth hgt, V2 wth 0]
+    toLine South = [V2 wth 0, V2 0 0]
+    toLine West = [V2 0 0, V2 0 hgt]
 
 listCursorNS :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-listCursorNS = listCursorChooseBorder [True, False, True]
+listCursorNS = listCursorChooseBorder (Set.fromList [North,South])
 
 listCursorNES :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-listCursorNES = listCursorChooseBorder [True, True, True]
+listCursorNES = listCursorChooseBorder (Set.fromList [North,South,East])
 
 listCursorNESW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-listCursorNESW = listCursorChooseBorder [True, True, True, True]
+listCursorNESW = listCursorChooseBorder (Set.fromList [North,South,East,West])
 
 listCursorNSW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-listCursorNSW = listCursorChooseBorder [True, False, True, True]
+listCursorNSW = listCursorChooseBorder (Set.fromList [North,South,West])
 
 fillScreenText :: Configuration -> String -> Picture
 fillScreenText cfig str =

src/Dodge/Render/MenuScreen.hs

@@ -1,8 +1,12 @@
 {- The menu picture.  -}
 module Dodge.Render.MenuScreen (
     menuScreen,
+    menuScreen',
 ) where
 
+import Dodge.Data.CardinalPoint
+import Dodge.Render.List
+import Dodge.Data.SelectionList
 import qualified Data.Text as T
 import Dodge.Base.Window
 import Dodge.Data.Universe
@@ -10,6 +14,16 @@ import Dodge.ScodeToChar
 import Dodge.WindowLayout
 import Padding
 import Picture
+import qualified Data.Set as Set
+
+menuScreen' :: Universe -> ScreenLayer -> Picture
+menuScreen' w screen = case screen of
+    OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off, _scSelPos = selpos} ->
+        drawOptions w (titf w) mos off selpos "Use keys to navigate the menu"
+    --    (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
+    (InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 Nothing help
+    --    (DisplayScreen sd) -> sd w
+    (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs
 
 menuScreen :: Universe -> ScreenLayer -> Picture
 menuScreen w screen = case screen of
@@ -64,11 +78,12 @@ drawOptions u title ops off mselpos footer =
         [ darkenBackground cfig
         , drawTitle cfig title
         , drawFooterText cfig red footer
+        , drawSelectionList cfig (makeOptionsSelectionList mselpos u ops)
         ]
-            ++ zipWith
+--            ++ zipWith
-                (\s vpos -> placeColorString (- hw + 50) vpos 0.2 s)
+--                (\s vpos -> placeColorString (- hw + 50) vpos 0.2 s)
-                ops''
+--                ops''
-                [hh -100, hh -150 ..]
+--                [hh -100, hh -150 ..]
   where
     --    ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] |
     --            y <- map (+75) [0,50..hh*2]]
@@ -88,6 +103,45 @@ drawOptions u title ops off mselpos footer =
     hw = halfWidth cfig
     cfig = _uvConfig u
 
+defaultSelectionItem :: SelectionItem
+defaultSelectionItem =  SelectionItem
+    { _siPictures = [color white $ text "HELLOW"]
+    , _siHeight = 1
+    , _siIsSelectable = True
+    , _siColor = white
+    , _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]
+    , _siHeight = 1
+    , _siIsSelectable = True
+    , _siColor = col
+    , _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

src/Dodge/Render/Picture.hs

@@ -20,7 +20,8 @@ fixedCoordPictures u =
                 [ hudDrawings u
                 , customMouseCursor cfig w
                 ]
-        (lay : _) -> setDepth (-1) . winScale cfig $ menuScreen u lay
+        (lay : _) -> (setDepth (-1) $ menuScreen' u lay) 
+            <> (setDepth (-1) . winScale cfig $ menuScreen u lay)
   where
     w = _uvWorld u
     cfig = _uvConfig u

src/Dodge/Update.hs

@@ -68,6 +68,7 @@ import qualified Data.Text as T
 updateUniverse :: Universe -> Universe
 updateUniverse u =
     updateUniverseLast
+        . advanceScrollAmount
         . maybeOpenTerminal
         . over (uvWorld . input . textInput) (const mempty)
         . updateUniverseMid
@@ -91,7 +92,7 @@ gotoTerminal w = case _uvScreenLayers w of
 updateUseInput :: Universe -> Universe
 updateUseInput u = case u ^? uvScreenLayers . _head of
     Just (InputScreen thetext _) -> doInputScreenInput thetext u
-    Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff} ->
+    Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff} -> 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
@@ -121,10 +122,7 @@ updateUniverseMid u = case _uvScreenLayers u of
                     . updateClouds
                )
     (_ : _) -> u
-    [] -> functionalUpdate'' u
+    [] -> functionalUpdate' u
-
-functionalUpdate'' :: Universe -> Universe
-functionalUpdate'' = advanceScrollAmount . functionalUpdate'
 
 functionalUpdate' :: Universe -> Universe
 functionalUpdate' u = case u ^. uvWorld . cWorld . timeFlow of
@@ -234,6 +232,11 @@ functionalUpdate w =
         . over uvWorld updateWheelEvents
         $ over uvWorld updatePastWorlds w
 
+menuWheelEvents :: Universe -> Universe
+menuWheelEvents u = u & uvScreenLayers . _head . scSelPos . _Just -~ y
+  where
+    y = u ^. uvWorld . input . scrollAmount
+
 updateWheelEvents :: World -> World
 updateWheelEvents w = foldr ($) w (replicate (abs y) (updateWheelEvent (signum y)))
   where