From e6e5427f448c647d1bbed9d2ca025c207a6b2b0f Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 3 Nov 2022 10:00:41 +0000 Subject: [PATCH] Start unifying drawn cursors --- src/Dodge/Data/CardinalPoint.hs | 14 ++++++++ src/Dodge/Data/Room.hs | 13 +++---- src/Dodge/Data/SelectionList.hs | 6 ++-- src/Dodge/Menu.hs | 1 + src/Dodge/Render/HUD.hs | 8 +++-- src/Dodge/Render/List.hs | 53 +++++++++++++++++----------- src/Dodge/Render/MenuScreen.hs | 62 ++++++++++++++++++++++++++++++--- src/Dodge/Render/Picture.hs | 3 +- src/Dodge/Update.hs | 13 ++++--- 9 files changed, 129 insertions(+), 44 deletions(-) create mode 100644 src/Dodge/Data/CardinalPoint.hs diff --git a/src/Dodge/Data/CardinalPoint.hs b/src/Dodge/Data/CardinalPoint.hs new file mode 100644 index 000000000..09883d912 --- /dev/null +++ b/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 diff --git a/src/Dodge/Data/Room.hs b/src/Dodge/Data/Room.hs index e2c8e8922..0e591493a 100644 --- a/src/Dodge/Data/Room.hs +++ b/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 diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index c43dbd0dd..10a31a385 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/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 - | NSWCursor - | NSCursor + | BorderCursor (Set CardinalPoint) data SelectionItem = SelectionItem { _siPictures :: [Picture] diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 68c233bd1..380ef2558 100644 --- a/src/Dodge/Menu.hs +++ b/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") diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 78fe0eada..2757e9be1 100644 --- a/src/Dodge/Render/HUD.hs +++ b/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 - | 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 diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 9b3bfd738..57f0f252a 100644 --- a/src/Dodge/Render/List.hs +++ b/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 - 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 = diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 7fac059d0..da61a5bfd 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/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 - (\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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 8da991d30..ca0aa60c4 100644 --- a/src/Dodge/Render/Picture.hs +++ b/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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index bc056e7f6..812fd8fe1 100644 --- a/src/Dodge/Update.hs +++ b/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'' :: 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