From 6a2df15d0d12edc127c3574a5cded069642dedfd Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 3 Sep 2021 12:38:56 +0100 Subject: [PATCH] Unify option menu display and effects --- src/Dodge/Event/Menu.hs | 27 +++++++------- src/Dodge/Menu.hs | 66 ++++++++++++++++++++++++++++++++++ src/Dodge/Render.hs | 11 ------ src/Dodge/Render/MenuScreen.hs | 50 +++++++++++++++++++------- src/Dodge/Render/Picture.hs | 2 +- 5 files changed, 117 insertions(+), 39 deletions(-) create mode 100644 src/Dodge/Menu.hs diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index bbb9fa54e..256f9bd7c 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -12,8 +12,10 @@ import Dodge.Config.Update import Dodge.Layout import Preload.Update import Dodge.Debug.Terminal +import Dodge.Menu import Data.Maybe +import Data.Foldable --import qualified Data.Set as S import Control.Lens import SDL @@ -47,10 +49,11 @@ handlePressedKeyInMenu mState scode w = case mState of ScancodeO -> pushMenu OptionMenu w ScancodeC -> pushMenu ControlList w _ -> Just w - OptionMenu -> case scode of - ScancodeV -> pushMenu SoundOptionMenu w - ScancodeG -> pushMenu GraphicsOptionMenu w - _ -> popMenu w + OptionMenu -> optionListToEffects optionsOptions popMenu scode w +-- OptionMenu -> case scode of +-- ScancodeV -> pushMenu SoundOptionMenu w +-- ScancodeG -> pushMenu GraphicsOptionMenu w +-- _ -> popMenu w SoundOptionMenu -> case scode of ScancodeY -> Just $ sw & config . volume_master %~ dec ScancodeU -> Just $ sw & config . volume_master %~ inc @@ -66,8 +69,7 @@ handlePressedKeyInMenu mState scode w = case mState of ControlList -> Just $ w & menuLayers %~ tail _ -> Just w where - unpause w' = Just . resumeSound $ - w' {_menuLayers = []} + unpause w' = Just . resumeSound $ w' {_menuLayers = []} startLevel = unpause . storeLevel dec x = max 0 (x - 0.1) inc x = min 1 (x + 0.1) @@ -84,16 +86,11 @@ handlePressedKeyInMenu mState scode w = case mState of dropLast (x:xs) = init (x:xs) dropLast _ = [] --- | hacky -scodeToChar :: Scancode -> Char -scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber +optionListToEffects :: [MenuOption] -> (World -> Maybe World) -> Scancode -> World -> Maybe World +optionListToEffects mos eff sc w = case find (\mo -> _moKey mo == sc) mos of + Nothing -> eff w + Just mo -> _moEffect mo w -updateFramebufferSize :: World -> World -updateFramebufferSize w = w & sideEffects - %~ (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : ) - where - (x,y) = (round $ getWindowX w, round $ getWindowY w) - divRes = w ^. config . resolution_factor cycleResolution :: (Eq a, Num a, Num p) => a -> p diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs new file mode 100644 index 000000000..09aca37a3 --- /dev/null +++ b/src/Dodge/Menu.hs @@ -0,0 +1,66 @@ +module Dodge.Menu + where +import Dodge.Data +import Dodge.Data.Menu +import Dodge.Config.Data +import SDL +import SDL.Internal.Numbered +import Dodge.Layout +import Dodge.Floor +import Dodge.Initialisation +import Preload.Update +import Dodge.Base.Window + +import Control.Lens +import Data.Maybe + +data MenuOption + = Toggle + { _moKey :: Scancode + , _moEffect :: World -> Maybe World + , _moString :: World -> String + } + | InvisibleToggle + { _moKey :: Scancode + , _moEffect :: World -> Maybe World + } + +optionsOptions :: [MenuOption] +optionsOptions = + [ Toggle ScancodeV (pushMenu SoundOptionMenu) (const "VOLUME") + , Toggle ScancodeG (pushMenu GraphicsOptionMenu) (const "GRAPHICS") + ] + +pushMenu ml w' = Just $ w' & menuLayers %~ (ml :) + +pauseMenuOptions :: [MenuOption] +pauseMenuOptions = + [ Toggle ScancodeN startNewGame (const "NEW LEVEL") + , Toggle ScancodeR (\w -> return $ fromMaybe w $ _storedLevel w) (const "RESTART") + , Toggle ScancodeO (pushMenu OptionMenu ) (const "OPTIONS") + , Toggle ScancodeC (pushMenu ControlList) (const "CONTROLS") + , InvisibleToggle ScancodeEscape (const Nothing) + ] + +startNewGame w = Just $ w + & menuLayers .~ [WaitMessage "GENERATING..." 1] + & worldEvents .~ const aNewGame + where + aNewGame :: World + aNewGame = updateFramebufferSize $ generateLevelFromRoomList levx $ initialWorld + & randGen .~ _randGen w + & config .~ _config w + +-- | hacky +scodeToChar :: Scancode -> Char +scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber + +charToScode :: Char -> Scancode +charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum + +updateFramebufferSize :: World -> World +updateFramebufferSize w = w & sideEffects + %~ (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : ) + where + (x,y) = (round $ getWindowX w, round $ getWindowY w) + divRes = w ^. config . resolution_factor diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index e53605e40..2524af08a 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -72,8 +72,6 @@ doDrawing pdata w = do -- set the coordinate uniform ready for drawing elements using world coordinates bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms setViewportSize (round winx `div` resFact) (round winy `div` resFact) --- viewport $= (Position 0 0 --- , divideSize (w ^. config . resolution_factor) $ Size (round $ fstV2 wins) (round $ sndV2 wins)) bindFramebuffer Framebuffer $= fst (_fboBase pdata) clearColor $= Color4 0 0 0 0 clear [ColorBuffer,DepthBuffer] @@ -120,8 +118,6 @@ doDrawing pdata w = do --depthMask $= Enabled --setup downscale viewport for blurring bloom setViewportSize (round winx `div` (2*resFact)) (round winy `div` (2*resFact)) --- viewport $= (Position 0 0 --- , divideSize (2 * (w ^. config . resolution_factor)) $ Size (round $ fstV2 wins) (round $ sndV2 wins)) bindFramebuffer Framebuffer $= fst (_fboHalf1 pdata) depthFunc $= Just Always textureBinding Texture2D $= Just (snd $ _fboBloom pdata) @@ -130,8 +126,6 @@ doDrawing pdata w = do replicateM_ 5 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata) blend $= Enabled setViewportSize (round winx `div` resFact) (round winy `div` resFact) --- viewport $= (Position 0 0 --- , divideSize (w ^. config . resolution_factor) $ Size (round $ fstV2 wins) (round $ sndV2 wins)) --draw clouds bindFramebuffer Framebuffer $= fst (_fboCloud pdata) depthFunc $= Just Lequal @@ -150,14 +144,10 @@ doDrawing pdata w = do renderLayer 2 shadV layerCounts renderWindows pdata windowPoints -- --downscale transparency depths - -- viewport $= (Position 0 0 - -- , divideSize (2 * (w ^. config . shadow_resolution)) $ Size (round $ fstV2 wins) (round $ sndV2 wins)) -- bindFramebuffer Framebuffer $= fst (_fboHalf3 pdata) -- bindTO (snd $ snd $ _fboCloud pdata) -- depthFunc $= Just Always -- drawShader (_fullscreenShader pdata) 4 - -- viewport $= (Position 0 0 - -- , divideSize (w ^. config . shadow_resolution) $ Size (round $ fstV2 wins) (round $ sndV2 wins)) ----draw lightmap for cloud buffer depthMask $= Disabled blend $= Enabled @@ -190,7 +180,6 @@ doDrawing pdata w = do drawShader (_fullscreenShader pdata) 4 --set viewport for radial distortion setViewportSize (round winx) (round winy) - --viewport $= (Position 0 0, Size (round $ fstV2 wins) (round $ sndV2 wins)) depthFunc $= Just Always blendFunc $= (One,Zero) -- perform any radial distortion diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 2436225cb..1350e7bb3 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -6,37 +6,42 @@ module Dodge.Render.MenuScreen ) where import Dodge.Data.Menu +import Dodge.Data --import Dodge.Config.Update import Dodge.Config.Data --import Dodge.Base (halfWidth,halfHeight) import Picture import Geometry +import Dodge.Menu --import Geometry.Data menuScreen - :: Configuration + :: World + -> Configuration -> Float -- Half width of screen -> Float -- Half height of screen -> [MenuLayer] -> Picture -menuScreen cfig hw hh mLays = case mLays of +menuScreen w cfig hw hh mLays = case mLays of (LevelMenu x:_) -> optionsList hw hh ("LEVEL"++show x) [] - (PauseMenu:_) -> optionsList hw hh "PAUSED" - ["N - NEW LEVEL" - ,"R - RESTART" - ,"O - OPTIONS" - ,"C - CONTROLS" - ] + (PauseMenu : _) -> optionsFromList w hw hh "PAUSED" pauseMenuOptions +-- (PauseMenu:_) -> optionsList hw hh "PAUSED" +-- ["N - NEW LEVEL" +-- ,"R - RESTART" +-- ,"O - OPTIONS" +-- ,"C - CONTROLS" +-- ] (GameOverMenu:_) -> optionsList hw hh "GAME OVER" ["N - NEW LEVEL" ,"R - RESTART" ,"O - OPTIONS" ,"C - CONTROLS" ] - (OptionMenu : _) -> optionsList hw hh "OPTIONS" - ["V - VOLUME" - ,"G - GRAPHICS" - ] + (OptionMenu : _) -> optionsFromList w hw hh "OPTIONS" optionsOptions +-- (OptionMenu : _) -> optionsList hw hh "OPTIONS" +-- ["V - VOLUME" +-- ,"G - GRAPHICS" +-- ] (SoundOptionMenu : _) -> optionsList hw hh "OPTIONS:VOLUME" ["Y - MASTER VOLUME + U : " ++ mavol ,"H - SOUND VOLUME + J : " ++ snvol @@ -71,6 +76,27 @@ displayStringList hw hh ss = pictures ys = [0,22..] f y s = translate (10-hw) y . scale 0.15 0.15 $ text s +optionsFromList + :: World + -> Float -- ^ Half screen width + -> Float -- ^ Half screen height + -> String -- ^ Title + -> [MenuOption] -- ^ Options + -> Picture +optionsFromList w hw hh tit ops = pictures $ + [darkenBackground + ,theTitle] + ++ + zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) (map (menuOptionToString w) ops') [hh-100,hh-150 ..] + where + ops' = filter notInvisible ops + notInvisible InvisibleToggle {} = False + notInvisible _ = True + placeString x y sc t = translate x y $ scale sc sc $ color white $ text t + darkenBackground = color (withAlpha 0.5 black) $ polygon $ screenBox hw hh + theTitle = placeString (-hw + 30) (hh - 50) 0.4 tit +menuOptionToString :: World -> MenuOption -> String +menuOptionToString w mo = (scodeToChar $ _moKey mo) : ':' : _moString mo w optionsList :: Float -- ^ Half screen width diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index ff58334b0..329a11ece 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -50,7 +50,7 @@ fixedCoordPictures w = case _menuLayers w of [ hudDrawings w , customMouseCursor w ] - lays -> scaler . onLayer MenuDepth $ menuScreen (_config w) (halfWidth w) (halfHeight w) lays + lays -> scaler . onLayer MenuDepth $ menuScreen w (_config w) (halfWidth w) (halfHeight w) lays where scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)