Unify menu event handling and display

2021-09-03 13:48:52 +01:00
parent 6a2df15d0d
commit 111b86d2df
3 changed files with 104 additions and 100 deletions
@@ -3,23 +3,23 @@ module Dodge.Event.Menu
    ) where
 import Dodge.Data
 import Dodge.Data.Menu
-import Dodge.Base.Window
-import Dodge.Floor
-import Dodge.Initialisation
+--import Dodge.Base.Window
+--import Dodge.Floor
+--import Dodge.Initialisation
 import Dodge.SoundLogic
-import Dodge.Config.Data
+--import Dodge.Config.Data
 import Dodge.Config.Update
-import Dodge.Layout
-import Preload.Update
+--import Dodge.Layout
+--import Preload.Update
 import Dodge.Debug.Terminal
 import Dodge.Menu

-import Data.Maybe
-import Data.Foldable
+--import Data.Maybe
+--import Data.Foldable
 --import qualified Data.Set as S
 import Control.Lens
 import SDL
-import SDL.Internal.Numbered
+--import SDL.Internal.Numbered

 handlePressedKeyInMenu :: MenuLayer -> Scancode -> World -> Maybe World
 handlePressedKeyInMenu mState scode w = case mState of
@@ -30,76 +30,44 @@ handlePressedKeyInMenu mState scode w = case mState of
        ScancodeReturn  -> popMenu $ applyTerminalString s w
        ScancodeBackspace -> popMenu w >>= pushMenu (Terminal $ dropLast s)
        _               -> popMenu w >>= pushMenu (Terminal $ s ++ [scodeToChar scode])
-    LevelMenu _ -> case scode of
-        ScancodeEscape  -> Nothing
-        ScancodeO       -> pushMenu OptionMenu w
-        ScancodeC       -> pushMenu ControlList w
-        _               -> startLevel w
-    PauseMenu   -> case scode of
-        ScancodeEscape  -> Nothing
-        ScancodeR       -> return $ fromMaybe w $ _storedLevel w
-        ScancodeN       -> startNewGame
-        ScancodeO       -> pushMenu OptionMenu w
-        ScancodeC       -> pushMenu ControlList w
-        _               -> unpause w
-    GameOverMenu -> case scode of
-        ScancodeEscape  -> Nothing
-        ScancodeR       -> Just $ fromMaybe w $ _storedLevel w
-        ScancodeN       -> startNewGame
-        ScancodeO       -> pushMenu OptionMenu w
-        ScancodeC       -> pushMenu ControlList w
-        _               -> Just 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
-        ScancodeH       -> Just $ sw & config . volume_sound  %~ dec
-        ScancodeJ       -> Just $ sw & config . volume_sound  %~ inc
-        ScancodeN       -> Just $ sw & config . volume_music  %~ dec
-        ScancodeM       -> Just $ sw & config . volume_music  %~ inc
-        _               -> popMenu $ w & sideEffects %~ (saveConfig (_config w) :)
-    GraphicsOptionMenu -> case scode of
-        ScancodeW       -> Just $ w & config . wall_textured     %~ not
-        ScancodeS       -> Just $ updateFramebufferSize $ w & config . resolution_factor %~ cycleResolution
-        _ -> popMenu $ w & sideEffects %~ (saveConfig (_config w) :)
+    LevelMenu _     -> optionListToEffects levelMenuOptions startLevel scode w
+    PauseMenu       -> optionListToEffects pauseMenuOptions unpause scode w
+    GameOverMenu    -> optionListToEffects pauseMenuOptions pure scode w
+    OptionMenu      -> optionListToEffects optionsOptions popMenu scode w
+    SoundOptionMenu -> optionListToEffects 
+        soundMenuOptions 
+        ( popMenu . writeConfig ) 
+        scode 
+        w
+    GraphicsOptionMenu -> optionListToEffects graphicsMenuOptions (popMenu . writeConfig) scode w
    ControlList -> Just $ w & menuLayers %~ tail
    _ -> Just w
  where 
+    writeConfig = sideEffects %~ (saveConfig (_config w) :)
    unpause w' = Just . resumeSound $ w' {_menuLayers = []}
    startLevel = unpause . storeLevel
-    dec x = max 0 (x - 0.1)
-    inc x = min 1 (x + 0.1)
-    pushMenu ml w'   = Just $ w' & menuLayers %~ (ml :)
    popMenu w'       = Just $ w' & menuLayers %~ tail
-    sw = w & sideEffects %~ (setVol (_config w) : )
-    startNewGame = Just $ w
-        & menuLayers .~ [WaitMessage "GENERATING..." 1]
-        & worldEvents .~ const aNewGame
-    aNewGame :: World
-    aNewGame = updateFramebufferSize $ generateLevelFromRoomList levx $ initialWorld 
-        & randGen .~ _randGen w
-        & config .~ _config w
    dropLast (x:xs) = init (x:xs)
    dropLast _ = []

 optionListToEffects :: [MenuOption] -> (World -> Maybe World) -> Scancode -> World -> Maybe World
-optionListToEffects mos eff sc w = case find (\mo -> _moKey mo == sc) mos of
+optionListToEffects mos eff sc w = case lookup sc listEffects of
    Nothing -> eff w
-    Just mo -> _moEffect mo w
+    Just eff' -> eff' w
+  where
+    listEffects = concatMap menuOptionToEffects mos

-
-
-cycleResolution :: (Eq a, Num a, Num p) => a -> p
-cycleResolution 1 = 2
-cycleResolution 2 = 4
-cycleResolution 4 = 1
-cycleResolution _ = 1
+menuOptionToEffects :: MenuOption -> [(Scancode,World -> Maybe World)]
+menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)]
+menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)]
+menuOptionToEffects Toggle2 
+    { _moKey1 = k1
+    , _moEff1 = eff1
+    , _moKey2 = k2
+    , _moEff2 = eff2 
+    } = [(k1,eff1) , (k2,eff2)]

 storeLevel :: World -> World
 storeLevel w = case _storedLevel w of
-                 Nothing -> w & storedLevel ?~ w
-                 _       -> w
+    Nothing -> w & storedLevel ?~ w
+    _       -> w
@@ -3,6 +3,7 @@ module Dodge.Menu
 import Dodge.Data
 import Dodge.Data.Menu
 import Dodge.Config.Data
+import Dodge.Config.Update
 import SDL
 import SDL.Internal.Numbered
 import Dodge.Layout
@@ -17,12 +18,19 @@ import Data.Maybe
 data MenuOption 
    = Toggle
        { _moKey    :: Scancode
-        , _moEffect :: World -> Maybe World
+        , _moEff    :: World -> Maybe World
+        , _moString :: World -> String
+        }
+    | Toggle2
+        { _moKey1   :: Scancode
+        , _moEff1   :: World -> Maybe World
+        , _moKey2   :: Scancode
+        , _moEff2   :: World -> Maybe World
        , _moString :: World -> String
        }
    | InvisibleToggle
        { _moKey    :: Scancode
-        , _moEffect :: World -> Maybe World
+        , _moEff    :: World -> Maybe World
        }

 optionsOptions :: [MenuOption]
@@ -30,9 +38,57 @@ optionsOptions =
    [ Toggle ScancodeV (pushMenu SoundOptionMenu) (const "VOLUME")
    , Toggle ScancodeG (pushMenu GraphicsOptionMenu) (const "GRAPHICS")
    ]
+levelMenuOptions :: [MenuOption]
+levelMenuOptions =
+    [  InvisibleToggle ScancodeEscape (const Nothing)
+    ,  InvisibleToggle ScancodeO        (pushMenu OptionMenu)
+    ,  InvisibleToggle ScancodeC        (pushMenu ControlList)
+    ]
+soundMenuOptions :: [MenuOption]
+soundMenuOptions =
+    [ Toggle2 ScancodeY (master dec . sw)
+        ScancodeU (master inc . sw) (\w -> "MASTER VOLUME:" ++ mavol w)
+    , Toggle2 ScancodeH (soundEffs dec . sw)
+        ScancodeJ (soundEffs inc . sw) (\w -> "EFFECTS VOLUME:" ++ snvol w)
+    , Toggle2 ScancodeN (music dec . sw)
+        ScancodeM (music inc . sw) (\w -> "MUSIC VOLUME:" ++ muvol w)
+    ]
+  where
+    dec x = max 0 (x - 0.1)
+    inc x = min 1 (x + 0.1)
+    sw w = w & sideEffects %~ (setVol (_config w) : )
+    master g    = Just . (config . volume_master %~ g)
+    soundEffs g = Just . (config . volume_sound %~ g)
+    music g     = Just . (config . volume_music %~ g)
+    cfig w = _config w
+    mavol w = f $ _volume_master $ cfig w
+    snvol w = f $ _volume_sound  $ cfig w
+    muvol w = f $ _volume_music  $ cfig w
+    f x = show (round $ 10 * x :: Int)

+pushMenu :: MenuLayer -> World -> Maybe World
 pushMenu ml w'   = Just $ w' & menuLayers %~ (ml :)

+--soundOptions :: [MenuOption]
+--soundOptions =
+--    [ Toggle2 ScancodeY 
+
+graphicsMenuOptions :: [MenuOption]
+graphicsMenuOptions =
+    [ Toggle ScancodeW (Just . (config . wall_textured %~ not))  wtextstring
+    , Toggle ScancodeS upf resostring
+    ]
+  where
+    wtextstring w = "WALL TEXTURES:" ++ show (_wall_textured $ _config w)
+    resostring w  = "RESOLUTION: 1/" ++ show (_resolution_factor $ _config w)
+    upf w = Just $ updateFramebufferSize $ w & config . resolution_factor %~ cycleResolution
+
+cycleResolution :: (Eq a, Num a, Num p) => a -> p
+cycleResolution 1 = 2
+cycleResolution 2 = 4
+cycleResolution 4 = 1
+cycleResolution _ = 1
+
 pauseMenuOptions :: [MenuOption]
 pauseMenuOptions =
    [ Toggle ScancodeN startNewGame (const "NEW LEVEL")
@@ -42,6 +98,7 @@ pauseMenuOptions =
    , InvisibleToggle ScancodeEscape (const Nothing)
    ]

+startNewGame :: World -> Maybe World
 startNewGame w = Just $ w
        & menuLayers .~ [WaitMessage "GENERATING..." 1]
        & worldEvents .~ const aNewGame
@@ -23,34 +23,12 @@ menuScreen
    -> [MenuLayer]
    -> Picture
 menuScreen w cfig hw hh mLays = case mLays of
-    (LevelMenu x:_) -> optionsList hw hh ("LEVEL"++show x) [] 
+    (LevelMenu x:_) -> optionsFromList w hw hh ("LEVEL"++show x) levelMenuOptions
    (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"
-        ]
+    (GameOverMenu : _) -> optionsFromList w hw hh "GAME OVER" pauseMenuOptions
    (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
-        ,"N - MUSIC  VOLUME + M : " ++ muvol
-        ]
-    (GraphicsOptionMenu : _) -> optionsList hw hh "OPTIONS:GRAPHICS" 
-        ["W - WALL TEXTURES:" ++ show (_wall_textured cfig)
-        ,"S - RESOLUTION: 1/" ++ show (_resolution_factor cfig)
-        ]
+    (SoundOptionMenu : _) -> optionsFromList w hw hh "OPTIONS:VOLUME" soundMenuOptions
+    (GraphicsOptionMenu : _) -> optionsFromList w hw hh "OPTIONS:GRAPHICS" graphicsMenuOptions
    (ControlList : _) -> pictures 
        [color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
        ,tst (-100) 100 0.4 "CONTROLS"
@@ -62,10 +40,6 @@ menuScreen w cfig hw hh mLays = case mLays of
    _ -> blank
  where 
    tst x y sc t = translate x y $ scale sc sc $ color white $ text t
-    mavol = f $ _volume_master cfig
-    snvol = f $ _volume_sound  cfig
-    muvol = f $ _volume_music  cfig
-    f x = show (round $ 10 * x :: Int)

 displayStringList :: Float -> Float -> [String] -> Picture
 displayStringList hw hh ss = pictures
@@ -96,7 +70,12 @@ optionsFromList w hw hh tit ops = pictures $
    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
+menuOptionToString w mo@(Toggle{})
+    = (scodeToChar $ _moKey mo) : ':' : _moString mo w
+menuOptionToString w mo@(Toggle2{})
+    = (scodeToChar $ _moKey1 mo) : '/' : (scodeToChar $ _moKey2 mo) : ':' : _moString mo w
+menuOptionToString _ _ = "undefined option string"
+

 optionsList
    :: Float    -- ^ Half screen width