Unify option menu display and effects

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
+    OptionMenu -> optionListToEffects optionsOptions popMenu scode w
-        ScancodeV       -> pushMenu SoundOptionMenu w
+--    OptionMenu -> case scode of
-        ScancodeG       -> pushMenu GraphicsOptionMenu w
+--        ScancodeV       -> pushMenu SoundOptionMenu w
-        _ -> popMenu 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 $
+    unpause w' = Just . resumeSound $ w' {_menuLayers = []}
-                        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
+optionListToEffects :: [MenuOption] -> (World -> Maybe World) -> Scancode -> World -> Maybe World
-scodeToChar :: Scancode -> Char
+optionListToEffects mos eff sc w = case find (\mo -> _moKey mo == sc) mos of
-scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber
+    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

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

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

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"
+    (PauseMenu : _) -> optionsFromList w hw hh "PAUSED" pauseMenuOptions
-        ["N - NEW LEVEL"
+--    (PauseMenu:_)   -> optionsList hw hh "PAUSED"
-        ,"R - RESTART"
+--        ["N - NEW LEVEL"
-        ,"O - OPTIONS"
+--        ,"R - RESTART"
-        ,"C - CONTROLS"
+--        ,"O - OPTIONS"
-        ]
+--        ,"C - CONTROLS"
+--        ]
     (GameOverMenu:_) -> optionsList hw hh "GAME OVER" 
         ["N - NEW LEVEL"
         ,"R - RESTART"
         ,"O - OPTIONS"
         ,"C - CONTROLS"
         ]
-    (OptionMenu : _) -> optionsList hw hh "OPTIONS" 
+    (OptionMenu : _) -> optionsFromList w hw hh "OPTIONS" optionsOptions
-        ["V - VOLUME"
+--    (OptionMenu : _) -> optionsList hw hh "OPTIONS" 
-        ,"G - GRAPHICS"
+--        ["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

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)