Start unifying drawn cursors

2022-11-03 10:00:41 +00:00
parent 0872a2dd40
commit e6e5427f44
9 changed files with 129 additions and 44 deletions
@@ -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
@@ -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
@@ -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
-    | NSWCursor
-    | NSCursor
+    | BorderCursor (Set CardinalPoint)

 data SelectionItem = SelectionItem
    { _siPictures :: [Picture]
@@ -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")
@@ -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
-        | otherwise = NSWCursor
+        | ButtonRight `M.member` _mouseButtons (_input w) = [North,South,East,West]
+        | otherwise = [North,South,West]

 subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture
 subInventoryDisplay subinv cfig w = case subinv of
@@ -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
-        NSWCursor -> Just listCursorNSW
-        NSCursor -> Just listCursorNS
+        BorderCursor cps -> Just $ listCursorChooseBorderScale (_slVerticalGap sl) (_slScale sl) cps
        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 wth hgt =
-    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]
-            ]
+chooseCursorBorders :: Float -> Float -> Set CardinalPoint -> Picture
+chooseCursorBorders wth hgt = fold . Set.map (line . toLine)
  where
-    f _ False = Nothing
-    f a True = Just a
+    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]

 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 =
@@ -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
-                (\s vpos -> placeColorString (- hw + 50) vpos 0.2 s)
-                ops''
-                [hh -100, hh -150 ..]
+--            ++ zipWith
+--                (\s vpos -> placeColorString (- hw + 50) vpos 0.2 s)
+--                ops''
+--                [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
@@ -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
@@ -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'' :: Universe -> Universe
-functionalUpdate'' = advanceScrollAmount . functionalUpdate'
+    [] -> functionalUpdate' u

 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