From 860d63df45094b488a449c908cd85100b27d5aad Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 22 Nov 2022 10:14:25 +0000 Subject: [PATCH] Work on menus --- appDodge/Main.hs | 14 +++- src/Dodge/Data/SelectionList.hs | 28 ++++++- src/Dodge/Data/Universe.hs | 13 ++-- src/Dodge/Menu.hs | 46 +++++------ src/Dodge/Menu/Option.hs | 49 +++++++++--- src/Dodge/Menu/PushPop.hs | 4 +- src/Dodge/Render/HUD.hs | 20 +++-- src/Dodge/Render/List.hs | 11 ++- src/Dodge/Render/MenuScreen.hs | 134 +++++++++++++------------------- src/Dodge/Render/Picture.hs | 14 ++-- src/Dodge/SelectionList.hs | 16 ++++ src/Dodge/Update.hs | 67 ++++++++++------ src/Dodge/Update/Input.hs | 2 +- 13 files changed, 251 insertions(+), 167 deletions(-) create mode 100644 src/Dodge/SelectionList.hs diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 738b88666..c75978005 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -80,13 +80,25 @@ firstWorldLoad theConfig = do --return $ startNewGame $ Universe cancontinue <- doesFileExist "saveSlot/0" mseed <- loadSeed + let u = Universe + { --{_uvWorld = initialWorld + _uvWorld = splashScreen + , _uvConfig = theConfig + , _preloadData = pdata + , _uvScreenLayers = [] + , _uvIOEffects = return + , _uvTestString = testStringInit + , _uvSideEffects = mempty + , _uvCanContinue = cancontinue + , _uvMSeed = mseed + } return $ Universe { --{_uvWorld = initialWorld _uvWorld = splashScreen , _uvConfig = theConfig , _preloadData = pdata - , _uvScreenLayers = [splashMenu] + , _uvScreenLayers = [splashMenu u] , _uvIOEffects = return , _uvTestString = testStringInit , _uvSideEffects = mempty diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index 2c71e612b..54984fd81 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/src/Dodge/Data/SelectionList.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} module Dodge.Data.SelectionList where import Color import Picture.Data @@ -13,14 +14,36 @@ data SelectionList = SelectionList , _slScale :: Float , _slVerticalGap :: Float , _slItems :: [SelectionItem] + , _slShownItems :: [(SelectionItem,SelectionItemIndex)] , _slSelPos :: Maybe Int , _slCursorType :: CursorType , _slWidth :: SelectionWidth , _slLength :: Int + , _slSizeRestriction :: SelectionSizeRestriction + , _slSpecialItem :: SpecialSelectionItem } +data SelectionItemIndex = ListedSelectionItem Int + | ScrollUpSelectionItem + | ScrollDownSelectionItem + | SpecialSelectionItem + +data SpecialSelectionItem = NoSpecialSelectionItem + | BottomSelectionItem {_bottomSelectionItem :: SelectionItem} + +data SelectionSizeRestriction = NoSelectionSizeRestriction + | SelectionSizeRestriction + { _maxSelectionLines :: Int + , _overflowItemTop :: SelectionItem + , _overflowItemBottom :: SelectionItem + , _ssrType :: SSRType + } + +newtype SSRType = SSRFromScreenBottom {_ssrFromScreenBottom :: Float} + data SelectionWidth = FixedSelectionWidth Int - | VariableSelectionWidth [Int] + | VariableSelectionWidth (Int -> Int) + | UseMaxSelectionItemWidth data CursorType = NoCursor | BorderCursor (Set CardinalPoint) @@ -36,3 +59,6 @@ data SelectionItem = SelectionItem makeLenses ''SelectionList makeLenses ''SelectionItem +makeLenses ''SpecialSelectionItem +makeLenses ''SelectionSizeRestriction +makeLenses ''SSRType diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index ee4418474..d4b9e8613 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -12,6 +12,7 @@ module Dodge.Data.Universe ( module Loop.Data, ) where +import Dodge.Data.SelectionList import Control.Lens --import qualified Data.Map.Strict as M import Data.Preload @@ -21,7 +22,7 @@ import Dodge.Data.Config import Dodge.Data.World import Loop.Data import Picture.Data -import SDL (Scancode) +--import SDL (Scancode) data Universe = Universe { _uvWorld :: World @@ -48,15 +49,14 @@ data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions data ScreenLayer = OptionScreen - { _scTitle :: Universe -> String + { _scTitle :: String , _scOptions :: [MenuOption] - , _scDefaultEff :: Universe -> Universe + , _scMaybeOption :: Maybe MenuOption , _scOptionFlag :: OptionScreenFlag - , _scOptionsOffset :: Int - , _scSelPos :: Maybe Int + , _scSelectionList :: SelectionList } | ColumnsScreen - { _scTitle :: Universe -> String + { _scTitle :: String , _scColumns :: [(String, String)] } | InputScreen @@ -94,3 +94,4 @@ makeLenses ''Universe makeLenses ''ScreenLayer makeLenses ''SideEffect makeLenses ''MenuOptionDisplay +makeLenses ''MenuOption diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 8af2a19b8..b8c8cf740 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -4,6 +4,7 @@ module Dodge.Menu ( splashMenu, ) where +import Dodge.Data.SelectionList import ShortShow import Control.Monad import Dodge.Concurrent @@ -24,15 +25,15 @@ import System.Clipboard import Text.Read import Data.Maybe -splashMenu :: ScreenLayer -splashMenu = - slTitleOptionsEff "AMNESIS" splashMenuOptions id +splashMenu :: Universe -> ScreenLayer +splashMenu u = + slTitleOptionsEff "AMNESIS" splashMenuOptions Nothing id u & scOptionFlag .~ SplashOptions splashMenuOptions :: [MenuOption] splashMenuOptions = [ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue - , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelPos . _Just) + , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelectionList . slSelPos . _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") @@ -49,8 +50,8 @@ splashMenuOptions = displaywhenseed str u | isNothing (_uvMSeed u) = MODBlockedString str | otherwise = MODString str -pauseMenu :: ScreenLayer -pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions unpause +pauseMenu :: Universe -> ScreenLayer +pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (Just "CONTINUE") unpause pauseMenuOptions :: [MenuOption] pauseMenuOptions = @@ -75,8 +76,8 @@ saveQuitConc u = do void $ writeSaveSlot (SaveSlotNum 0) u return $ const Nothing -seedStartMenu :: String -> ScreenLayer -seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen +seedStartMenu :: String -> Universe -> ScreenLayer +seedStartMenu str = slTitleOptionsEff str seedStartOptions (Just "BACK") popScreen seedStartOptions :: [MenuOption] seedStartOptions = @@ -94,11 +95,11 @@ trySeedFromClipboard u = do (u & uvScreenLayers %~ tail) Just i -> return $ startSeedGame 0 i u -slTitleOptions :: String -> [MenuOption] -> ScreenLayer -slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig) +slTitleOptions :: String -> [MenuOption] -> Universe -> ScreenLayer +slTitleOptions title ops = slTitleOptionsEff title ops (Just "BACK") (popScreen . writeConfig) -optionMenu :: ScreenLayer -optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions popScreen +optionMenu :: Universe -> ScreenLayer +optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions (Just "BACK") popScreen optionsOptions :: [MenuOption] optionsOptions = @@ -106,10 +107,9 @@ optionsOptions = , makeSubmenuOption graphicsMenu $ MODString "GRAPHICS" , makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY" , makeSubmenuOption debugMenu $ MODString "DEBUG OPTIONS" - , Toggle popScreen $ const $ MODString "BACK" ] -debugMenu :: ScreenLayer +debugMenu :: Universe -> ScreenLayer debugMenu = slTitleOptions "OPTIONS:GAMEPLAY" @@ -117,7 +117,7 @@ debugMenu = debugMenuOptions :: [MenuOption] debugMenuOptions = - (map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" id]) + map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" id] where f :: DebugBool -> MenuOption f bd = @@ -141,7 +141,7 @@ debugMenuOptions = -- , makeBoolOption debug_cull_more_lights "CULL MORE LIGHTS" -- ] -- $ map Scancode [4 ..] -gameplayMenu :: ScreenLayer +gameplayMenu :: Universe -> ScreenLayer gameplayMenu = slTitleOptions "OPTIONS:GAMEPLAY" @@ -152,7 +152,7 @@ gameplayMenuOptions = [ makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL" ] -soundMenu :: ScreenLayer +soundMenu :: Universe -> ScreenLayer soundMenu = slTitleOptions "OPTIONS:VOLUME" @@ -179,7 +179,7 @@ soundMenuOptions = writeConfig :: Universe -> Universe writeConfig w = w & uvIOEffects %~ saveConfig (_uvConfig w) -graphicsMenu :: ScreenLayer +graphicsMenu :: Universe -> ScreenLayer graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions graphicsMenuOptions :: [MenuOption] @@ -190,9 +190,9 @@ graphicsMenuOptions = , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS" ] -gameOverMenu :: ScreenLayer -gameOverMenu = - slTitleOptionsEff "GAME OVER" pauseMenuOptions id +gameOverMenu :: Universe -> ScreenLayer +gameOverMenu u = + slTitleOptionsEff "GAME OVER" pauseMenuOptions Nothing id u & scOptionFlag .~ GameOverOptions -- OptionScreen @@ -209,8 +209,8 @@ gameOverMenu = unpause :: Universe -> Universe unpause w = resumeSound $ w & uvScreenLayers .~ [] -displayControls :: ScreenLayer -displayControls = ColumnsScreen (const "CONTROLS") listControls +displayControls :: Universe -> ScreenLayer +displayControls = const $ ColumnsScreen "CONTROLS" listControls listControls :: [(String, String)] listControls = diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs index 0828e5aa2..6a7f9a2a7 100644 --- a/src/Dodge/Menu/Option.hs +++ b/src/Dodge/Menu/Option.hs @@ -1,43 +1,68 @@ module Dodge.Menu.Option where -import Dodge.ScodeToChar +--import Dodge.ScodeToChar +import Data.Maybe +import Dodge.WindowLayout import Padding import Picture.Base import Dodge.Data.CardinalPoint import Dodge.Data.SelectionList import Dodge.Data.Universe import qualified Data.Set as Set +import LensHelp -slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> Universe) -> ScreenLayer -slTitleOptionsEff title ops eff = +slTitleOptionsEff :: String -> [MenuOption] -> Maybe String -> (Universe -> Universe) -> Universe -> ScreenLayer +slTitleOptionsEff title ops defstr eff u = OptionScreen - { _scTitle = const title + { _scTitle = title , _scOptions = ops - , _scDefaultEff = eff + , _scMaybeOption = fmap (Toggle eff . const . MODString) defstr , _scOptionFlag = NormalOptions - , _scOptionsOffset = 0 - , _scSelPos = Just 0 + , _scSelectionList = makeOptionsSelectionList (Just 0) u ops defstr } -makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> SelectionList -makeOptionsSelectionList mselpos u mos = SelectionList +makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> Maybe String -> SelectionList +makeOptionsSelectionList mselpos u mos defstr = SelectionList { _slPosX = 50 , _slPosY = 50 , _slOffset = 0 , _slScale = 2 , _slVerticalGap = 30 , _slItems = optionsToSelections u mos + , _slShownItems = [] , _slSelPos = mselpos , _slCursorType = BorderCursor (Set.fromList [North,South,West]) , _slWidth = FixedSelectionWidth 15 , _slLength = length $ optionsToSelections u mos + , _slSizeRestriction = SelectionSizeRestriction (availableMenuLines cfig) overflowit overflowit + (SSRFromScreenBottom 5) + , _slSpecialItem = fromMaybe NoSpecialSelectionItem $ do + str <- defstr + return $ BottomSelectionItem SelectionItem + { _siPictures = [color white $ text str] + , _siHeight = 1 + , _siIsSelectable = True + , _siWidth = length str + , _siColor = white + , _siOffX = 0 + } } + where + cfig = u ^. uvConfig + overflowit = SelectionItem + { _siPictures = [text "MORE OPTIONS"] + , _siHeight = 1 + , _siIsSelectable = True + , _siWidth = length "MORE OPTIONS" + , _siColor = white + , _siOffX = 0 + } optionsToSelections :: Universe -> [MenuOption] -> [SelectionItem] optionsToSelections u ops = map colStrToSelItem colstrs where maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops) - colstrs = zipWith (menuOptionToString u maxOptionLength) ['A'..] ops + colstrs = map (menuOptionToString u maxOptionLength) ops colStrToSelItem :: (Color,String) -> SelectionItem colStrToSelItem (col,str) = SelectionItem @@ -54,8 +79,8 @@ optionValueOffset u mo = case _moString mo u of MODStringOption s _ -> length s _ -> 0 -menuOptionToString :: Universe -> Int -> Char -> MenuOption -> (Color, String) -menuOptionToString w padAmount char mo = (thecol, (char:":") ++ optionText) +menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String) +menuOptionToString w padAmount mo = (thecol, optionText) where thecol = case _moString mo w of MODBlockedString{} -> greyN 0.5 diff --git a/src/Dodge/Menu/PushPop.hs b/src/Dodge/Menu/PushPop.hs index de6d9f2f8..26854e23b 100644 --- a/src/Dodge/Menu/PushPop.hs +++ b/src/Dodge/Menu/PushPop.hs @@ -6,6 +6,6 @@ import LensHelp popScreen :: Universe -> Universe popScreen = uvScreenLayers %~ tail -pushScreen :: ScreenLayer -> Universe -> Universe -pushScreen ml = uvScreenLayers .:~ ml +pushScreen :: (Universe -> ScreenLayer) -> Universe -> Universe +pushScreen ml u = u & uvScreenLayers .:~ ml u diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 8d395540c..a132bc7ad 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -1,6 +1,6 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Render.HUD ( - hudDrawings, + drawHUD, ) where import Dodge.Data.CardinalPoint @@ -29,12 +29,12 @@ import Picture import SDL (MouseButton (..)) import qualified Data.Set as Set -hudDrawings :: Universe -> Picture -hudDrawings uv = case w ^. cWorld . lWorld . hud . hudElement of +drawHUD :: Universe -> Picture +drawHUD uv = case w ^. cWorld . lWorld . hud . hudElement of DisplayCarte -> drawCarte cfig w DisplayInventory subinv -> drawInGameHUD subinv uv - <> subInventoryDisplay subinv cfig w + <> drawSubInventory subinv cfig w where w = _uvWorld uv cfig = _uvConfig uv @@ -58,9 +58,13 @@ defaultSelectionList = SelectionList , _slPosY = 0 , _slOffset = 0 , _slItems = [] + , _slShownItems = [] , _slSelPos = Nothing , _slCursorType = NoCursor , _slWidth = FixedSelectionWidth 15 + , _slLength = 0 + , _slSizeRestriction = NoSelectionSizeRestriction + , _slSpecialItem = NoSpecialSelectionItem } subInvSelectionList :: SelectionList @@ -71,9 +75,13 @@ subInvSelectionList = SelectionList , _slPosY = 60 , _slOffset = 0 , _slItems = [] + , _slShownItems = [] , _slSelPos = Nothing , _slCursorType = NoCursor , _slWidth = FixedSelectionWidth 15 + , _slLength = 0 + , _slSizeRestriction = NoSelectionSizeRestriction + , _slSpecialItem = NoSpecialSelectionItem } inventorySelectionList :: World -> [SelectionItem] @@ -107,8 +115,8 @@ inventoryDisplay subinv cfig w = drawSelectionList cfig $ | 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 +drawSubInventory :: SubInventory -> Configuration -> World -> Picture +drawSubInventory subinv cfig w = case subinv of LockedInventory -> mempty -- topInvCursor col cursPos cfig w NoSubInventory -> pictures diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 6ffede68d..3243d01c6 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -1,5 +1,6 @@ module Dodge.Render.List where +--import LensHelp import Data.Foldable import Data.Maybe import Data.Set (Set) @@ -12,6 +13,7 @@ import Dodge.Data.SelectionList import Geometry import ListHelp import Picture +import LensHelp drawSelectionList :: Configuration -> SelectionList -> Picture drawSelectionList cfig sl = @@ -22,13 +24,18 @@ drawSelectionList cfig sl = (_slPosY sl) cfig (_slOffset sl) - (concatMap _siPictures (_slItems sl)) + (makeSelectionListPictures sl) <> drawSelectionCursor cfig sl +makeSelectionListPictures :: SelectionList -> [Picture] +makeSelectionListPictures sl = case sl ^. slSizeRestriction of + SelectionSizeRestriction {} -> concatMap (_siPictures . fst) $ _slShownItems sl + _ -> concatMap _siPictures $ _slItems sl + drawSelectionCursor :: Configuration -> SelectionList -> Picture drawSelectionCursor cfig sl = fromMaybe mempty $ do i <- _slSelPos sl - selit <- (filter _siIsSelectable lis) !? i + selit <- filter _siIsSelectable lis !? i f <- case _slCursorType sl of BorderCursor cps -> Just $ listCursorChooseBorderScale (_slVerticalGap sl) (_slScale sl) cps NoCursor -> Nothing diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 634025134..f106bd7e9 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -4,33 +4,32 @@ module Dodge.Render.MenuScreen ( menuScreen', ) where -import Dodge.Menu.Option -import Dodge.Render.List +--import LensHelp +import Dodge.Base.WinScale import Dodge.Data.SelectionList +--import Dodge.Menu.Option +import Dodge.Render.List import qualified Data.Text as T import Dodge.Base.Window import Dodge.Data.Universe -import Dodge.WindowLayout import Padding import Picture -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" +menuScreen' :: Configuration -> ScreenLayer -> Picture +menuScreen' cfig screen = case screen of + OptionScreen{_scTitle = titf, _scSelectionList = selpos} -> + drawOptions cfig titf 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 + (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help -- (DisplayScreen sd) -> sd w - (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs + (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs -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 :: Configuration -> ScreenLayer -> Picture +menuScreen cfig screen = case screen of + OptionScreen{_scTitle = titf, _scSelectionList = selpos} -> + drawOptions cfig titf selpos "Use keys to navigate the menu" + (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help + (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs --displayStringList :: World -> [String] -> Picture --displayStringList w ss = pictures @@ -51,81 +50,65 @@ drawTwoColumnsScreen cfig title lps = ] drawTwoColumns :: Configuration -> [(String, String)] -> Picture -drawTwoColumns cfig lps = pictures $ zipWith f [hh -100, hh -130 ..] lps +drawTwoColumns cfig lps = listPicturesAtScaleOff 30 2 50 50 cfig 0 $ map f lps where - f y (s1, s2) = placeString (50 - hw) y 0.15 $ rightPad ln '.' s1 ++ s2 - hh = halfHeight cfig - hw = halfWidth cfig + f (s1, s2) = color white $ text $ rightPad ln '.' s1 ++ s2 ln = maximum (map (length . fst) lps) + 3 -drawOptions :: - Universe -> +--drawTwoColumns' :: Configuration -> [(String, String)] -> Picture +--drawTwoColumns' cfig lps = pictures $ zipWith f [hh -100, hh -130 ..] lps +-- where +-- f y (s1, s2) = placeString (50 - hw) y 0.15 $ rightPad ln '.' s1 ++ s2 +-- hh = halfHeight cfig +-- hw = halfWidth cfig +-- ln = maximum (map (length . fst) lps) + 3 + +drawInputMenu :: + Configuration -> -- | Title String -> - -- | Options - [MenuOption] -> - -- | Options offset - Int -> - -- | Select position - Maybe Int -> -- | Help Text String -> Picture -drawOptions u title ops off mselpos footer = - pictures $ +drawInputMenu cfig title footer = + pictures [ --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 ..] - where - -- ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] | - -- y <- map (+75) [0,50..hh*2]] - -- ] - - maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops') - ops' = case availableMenuLines cfig of - x | x < length ops -> take (availableMenuLines cfig) (drop off ops) - _ -> ops - ops'' = case availableMenuLines cfig of - x | x < length ops -> zipWith (menuOptionToString u maxOptionLength) ['A'..] ops' ++ [(white, "SPACE: MORE OPTIONS")] - _ -> zipWith (menuOptionToString u maxOptionLength) ['A'..] ops' - hh = halfHeight cfig - hw = halfWidth cfig - cfig = _uvConfig u - -defaultSelectionItem :: SelectionItem -defaultSelectionItem = SelectionItem - { _siPictures = [color white $ text "HELLOW"] - , _siHeight = 1 - , _siIsSelectable = True - , _siColor = white - , _siOffX = 0 - } - -colStrToSelItem :: (Color,String) -> SelectionItem -colStrToSelItem (col,str) = SelectionItem - { _siPictures = [color col $ text str] - , _siHeight = 1 - , _siIsSelectable = True - , _siColor = col - , _siOffX = 0 - } +drawOptions :: + Configuration -> + -- | Title + String -> + -- | Select position + SelectionList -> + -- | Help Text + String -> + Picture +drawOptions cfig title sl footer = + pictures + [ --darkenBackground cfig + drawTitle cfig title + , drawFooterText cfig red footer + , drawSelectionList cfig sl + ] darkenBackground :: Configuration -> Picture darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox drawTitle :: Configuration -> String -> Picture -drawTitle cfig = placeString (- hw + 30) (hh - 50) 0.4 +drawTitle cfig = winScale cfig . translate (30 - hw) (hh-50) . scale 0.4 0.4 . text where hh = halfHeight cfig hw = halfWidth cfig +--drawTitle' :: Configuration -> String -> Picture +--drawTitle' cfig = placeString (- hw + 30) (hh - 50) 0.4 +-- where +-- hh = halfHeight cfig +-- hw = halfWidth cfig + placeString :: -- | x distance from center Float -> @@ -137,17 +120,6 @@ placeString :: Picture placeString x y sc = color white . translate x y . scale sc sc . text -placeColorString :: - -- | x distance from center - Float -> - -- | y distance from center - Float -> - -- | scale - Float -> - (Color, String) -> - Picture -placeColorString x y sc (col, str) = color col . translate x y . scale sc sc . text $ str - drawFooterText :: Configuration -> Color -> String -> Picture drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1 where diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 1ddc25ead..ccaf0d7f3 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -14,10 +14,10 @@ import Picture fixedCoordPictures :: Universe -> Picture fixedCoordPictures u = - 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) + drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld . input) <> case u ^. uvScreenLayers of + [] -> drawHUD u + (lay : _) -> setDepth (-1) (menuScreen' cfig lay) +-- <> (setDepth (-1) . winScale cfig $ menuScreen cfig lay) where cfig = _uvConfig u @@ -33,9 +33,9 @@ drawConcurrentMessage u = f (RunningSideEffect ce) = ce ++ " IN PROGRESS" f x = _ceString x ++ " QUEUED" -customMouseCursor :: Configuration -> World -> Picture -customMouseCursor cfig w = +customMouseCursor :: Configuration -> Input -> Picture +customMouseCursor cfig inp = winScale cfig - . uncurryV translate (_mousePos (_input w)) + . uncurryV translate (_mousePos inp) . color white $ pictures [line [V2 (-5) 0, V2 5 0], line [V2 0 (-5), V2 0 5]] diff --git a/src/Dodge/SelectionList.hs b/src/Dodge/SelectionList.hs new file mode 100644 index 000000000..b5f85f39d --- /dev/null +++ b/src/Dodge/SelectionList.hs @@ -0,0 +1,16 @@ +module Dodge.SelectionList where + +import Dodge.Data.SelectionList +import LensHelp + +setShownSelectionItems :: SelectionList -> SelectionList +setShownSelectionItems sl = case sl ^? slSizeRestriction of + Just (SelectionSizeRestriction maxlines topit botit _) + | length allitems <= maxlines -> sl & slShownItems .~ allitems + | otherwise -> if offset > 0 + then sl & slShownItems .~ ((topit,ScrollUpSelectionItem) : take (maxlines - 2) (drop offset allitems)) + else sl & slShownItems .~ (take (maxlines - 2) allitems ++ [(botit,ScrollDownSelectionItem)]) + _ -> sl & slShownItems .~ allitems + where + offset = sl ^. slOffset + allitems = zipWith (\x y -> (x,ListedSelectionItem y)) (sl ^. slItems) [0..] diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index bcb6498bf..0e2237531 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -6,7 +6,8 @@ Description : Simulation update -} module Dodge.Update (updateUniverse) where -import Dodge.Menu.Option +--import Dodge.Menu.Option +import Dodge.SelectionList import Dodge.Data.SelectionList import Dodge.InputFocus import Color @@ -65,7 +66,7 @@ import SDL import Sound.Data import StrictHelp import qualified Data.Text as T -import ListHelp +--import ListHelp updateUniverse :: Universe -> Universe updateUniverse u = @@ -91,20 +92,24 @@ gotoTerminal w = case _uvScreenLayers w of (InputScreen{} : _) -> w _ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command" -mouseClickOptionsList :: [MenuOption] -> Maybe Int -> Universe -> Universe -mouseClickOptionsList mos mi u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of +mouseClickOptionsList :: [MenuOption] -> SelectionList -> Maybe MenuOption -> Universe -> Universe +mouseClickOptionsList mos sl mop u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of Just False -> fromMaybe u $ do - i <- mi - mo <- mos !? i - return $ _moEff mo u + i <- sl ^. slSelPos + si <- sl ^? slShownItems . ix i . _2 + return $ maybe u ($ u) $ case si of + ListedSelectionItem j -> mos ^? ix j . moEff + ScrollUpSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset %~ (min 0 . subtract 10) + ScrollDownSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset +~ 10 _ -> u mouseOverSelectionList :: SelectionList -> Universe -> Universe mouseOverSelectionList sl u | x > xl && x < xr && ylower == yupper && mmoving - && ylower >= 0 && ylower < _slLength sl = u & uvScreenLayers . _head . scSelPos ?~ yupper + && ylower >= 0 && ylower < ymax = u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper | otherwise = u where + ymax = maybe 0 length $ u ^? uvScreenLayers . _head . scSelectionList . slShownItems mmoving = u ^. uvWorld . input . mouseMoving ylower = ceiling $ (hh - (75 + y + _slPosY sl)) / 50 yupper = floor $ (hh - (15 + y + _slPosY sl)) / 50 @@ -115,32 +120,44 @@ mouseOverSelectionList sl u hh = halfHeight cfig hw = halfWidth cfig +setSelectionListRestriction :: Configuration -> SelectionList -> SelectionList +setSelectionListRestriction cfig sl = sl & slSizeRestriction . maxSelectionLines %~ const nlines + where + nlines = floor ((dToBot - vgap) / itmHeight) + vgap = sl ^. slVerticalGap + itmHeight = 10 * sl ^. slScale + vgap + dToBot = cfig ^. windowY - (sl ^. slPosY + dFromScreenBot) + dFromScreenBot = fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom + updateUseInput :: Universe -> Universe updateUseInput u = case u ^? uvScreenLayers . _head of Just (InputScreen thetext _) -> doInputScreenInput thetext u - Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff, _scOptionFlag = flag, _scSelPos = mselpos} - -> optionScreenUpdate mos defeff flag mselpos u --- foldl' (\u' scode -> optionListToEffects defeff scode mos u') u (M.keys $ M.filter (== InitialPress) pkeys) - Just ColumnsScreen{} -> u & uvScreenLayers %~ tail + Just OptionScreen{_scOptions = mos, _scMaybeOption = mop, _scOptionFlag = flag, _scSelectionList = sellist} + -> optionScreenUpdate mos mop flag sellist u +-- Just ColumnsScreen{} -> u & uvScreenLayers %~ tail _ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of - Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u-- M.foldlWithKey' (updateKeyInTerminal tmid) u pkeys + Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u _ -> M.foldlWithKey' updateKeyInGame u pkeys where pkeys = u ^. uvWorld . input . pressedKeys -optionScreenUpdate :: [MenuOption] -> (Universe -> Universe) -> OptionScreenFlag -> Maybe Int +optionScreenUpdate :: [MenuOption] -> Maybe MenuOption -> OptionScreenFlag + -> SelectionList -> Universe -> Universe -optionScreenUpdate mos defeff _ mselpos u = - optionScreenDefEff defeff - . mouseClickOptionsList mos mselpos - . mouseOverSelectionList - (makeOptionsSelectionList mselpos u mos) - $ menuWheelEvents +optionScreenUpdate mos mop _ sl u = + optionScreenDefEff mop + . mouseClickOptionsList mos sl mop + . mouseOverSelectionList sl + . menuWheelEvents + . over (uvScreenLayers . _head . scSelectionList) (setSelectionListRestriction cfig) + $ over (uvScreenLayers . _head . scSelectionList) setShownSelectionItems u + where + cfig = u ^. uvConfig -optionScreenDefEff :: (Universe -> Universe) -> Universe -> Universe +optionScreenDefEff :: Maybe MenuOption -> Universe -> Universe optionScreenDefEff f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of - Just InitialPress -> f u + Just InitialPress -> fromMaybe id (f ^? _Just . moEff) u _ -> u updateUniverseLast :: Universe -> Universe @@ -276,9 +293,9 @@ functionalUpdate w = $ over uvWorld updatePastWorlds w menuWheelEvents :: Universe -> Universe -menuWheelEvents u = u & uvScreenLayers . _head . scSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax) +menuWheelEvents u = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax) where - ymax = maybe 0 length (u ^? uvScreenLayers . _head . scOptions) + ymax = max 1 $ maybe 1 length (u ^? uvScreenLayers . _head . scSelectionList . slShownItems) y = u ^. uvWorld . input . scrollAmount updateWheelEvents :: World -> World @@ -622,7 +639,7 @@ checkEndGame :: Universe -> Universe checkEndGame uv = case w ^? cWorld . timeFlow . deathDelay of Just x | x < 0 -> - uv & uvScreenLayers .~ [gameOverMenu] + uv & uvScreenLayers .~ [gameOverMenu uv] Just _ -> uv & uvWorld . cWorld . timeFlow . deathDelay -~ 1 _ | _crHP (you w) < 1 -> uv & uvWorld . cWorld . timeFlow .~ DeathTime 50 _ -> uv diff --git a/src/Dodge/Update/Input.hs b/src/Dodge/Update/Input.hs index c4bf88832..1591150e0 100644 --- a/src/Dodge/Update/Input.hs +++ b/src/Dodge/Update/Input.hs @@ -84,7 +84,7 @@ updateKeyInGame uv sc InitialPress = case sc of updateKeyInGame uv _ _ = uv pauseGame :: Universe -> Universe -pauseGame = uvScreenLayers .~ [pauseMenu] +pauseGame u = u & uvScreenLayers .~ [pauseMenu u] spaceAction :: World -> World spaceAction w = case w ^?! cWorld . lWorld . hud . hudElement of