Unify menu event handling and display

src/Dodge/Event/Menu.hs

@@ -3,23 +3,23 @@ module Dodge.Event.Menu
     ) where
 import Dodge.Data
 import Dodge.Data.Menu
-import Dodge.Base.Window
+--import Dodge.Base.Window
-import Dodge.Floor
+--import Dodge.Floor
-import Dodge.Initialisation
+--import Dodge.Initialisation
 import Dodge.SoundLogic
-import Dodge.Config.Data
+--import Dodge.Config.Data
 import Dodge.Config.Update
-import Dodge.Layout
+--import Dodge.Layout
-import Preload.Update
+--import Preload.Update
 import Dodge.Debug.Terminal
 import Dodge.Menu
 
-import Data.Maybe
+--import Data.Maybe
-import Data.Foldable
+--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
+    LevelMenu _     -> optionListToEffects levelMenuOptions startLevel scode w
-        ScancodeEscape  -> Nothing
+    PauseMenu       -> optionListToEffects pauseMenuOptions unpause scode w
-        ScancodeO       -> pushMenu OptionMenu w
+    GameOverMenu    -> optionListToEffects pauseMenuOptions pure scode w
-        ScancodeC       -> pushMenu ControlList w
+    OptionMenu      -> optionListToEffects optionsOptions popMenu scode w
-        _               -> startLevel w
+    SoundOptionMenu -> optionListToEffects 
-    PauseMenu   -> case scode of
+        soundMenuOptions 
-        ScancodeEscape  -> Nothing
+        ( popMenu . writeConfig ) 
-        ScancodeR       -> return $ fromMaybe w $ _storedLevel w
+        scode 
-        ScancodeN       -> startNewGame
+        w
-        ScancodeO       -> pushMenu OptionMenu w
+    GraphicsOptionMenu -> optionListToEffects graphicsMenuOptions (popMenu . writeConfig) scode 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) :)
     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
 
-
+menuOptionToEffects :: MenuOption -> [(Scancode,World -> Maybe World)]
-
+menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)]
-cycleResolution :: (Eq a, Num a, Num p) => a -> p
+menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)]
-cycleResolution 1 = 2
+menuOptionToEffects Toggle2 
-cycleResolution 2 = 4
+    { _moKey1 = k1
-cycleResolution 4 = 1
+    , _moEff1 = eff1
-cycleResolution _ = 1
+    , _moKey2 = k2
+    , _moEff2 = eff2 
+    } = [(k1,eff1) , (k2,eff2)]
 
 storeLevel :: World -> World
 storeLevel w = case _storedLevel w of
-                 Nothing -> w & storedLevel ?~ w
+    Nothing -> w & storedLevel ?~ w
-                 _       -> w
+    _       -> w

src/Dodge/Menu.hs

@@ -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

src/Dodge/Render/MenuScreen.hs

@@ -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"
+    (GameOverMenu : _) -> optionsFromList w hw hh "GAME OVER" pauseMenuOptions
---        ["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 : _) -> optionsFromList w hw hh "OPTIONS" optionsOptions
---    (OptionMenu : _) -> optionsList hw hh "OPTIONS" 
+    (SoundOptionMenu : _) -> optionsFromList w hw hh "OPTIONS:VOLUME" soundMenuOptions
---        ["V - VOLUME"
+    (GraphicsOptionMenu : _) -> optionsFromList w hw hh "OPTIONS:GRAPHICS" graphicsMenuOptions
---        ,"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)
-        ]
     (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