Improve configuration handling

app/Main.hs

@@ -9,6 +9,7 @@ import Dodge.Update
 import Dodge.Event
 import Dodge.Render
 import Dodge.LoadConfig
+import Dodge.Config.Update
 import Dodge.LoadSound
 import Picture
 import Picture.Render
@@ -55,6 +56,7 @@ main = do
         (fmap (setWindowSize sizex sizey keyConfig) firstWorld)
         ( \preData w -> do
             startTicks <- SDL.ticks
+            updateDodgeConfig w
             void $ doDrawing (_renderData preData) w
             playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
             newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)

src/Dodge/Base.hs

@@ -770,7 +770,7 @@ levLayer HPtLayer           = 73
 levLayer ShadowLayer        = 75   
 levLayer LabelLayer         = 80
 levLayer InvLayer           = 85
-levLayer MenuLayer          = 90
+levLayer MenuDepth          = 90
 
 {- | Transform coordinates from world position to normalised screen coordinates.
  -}

src/Dodge/Config/Update.hs

@@ -0,0 +1,22 @@
+{-|
+IO actions that apply config side effects and save it to disk.
+-}
+module Dodge.Config.Update
+    where
+import Dodge.Data
+import Dodge.LoadConfig
+import Sound
+
+import Data.Aeson (encodeFile)
+import Control.Monad (when)
+
+updateDodgeConfig :: World -> IO ()
+updateDodgeConfig w = case _menuLayers w of
+    (ConfigSaveScreen _: _) -> do
+        putStrLn "Saving config"
+        encodeFile "data/dodge.config.json" cfig
+    _ -> when (_configNeedsUpdate w) $ do
+        setSoundVolume ( _volume_master cfig * _volume_sound cfig)
+        setMusicVolume ( _volume_master cfig * _volume_music cfig)
+  where
+    cfig = _config w

src/Dodge/Data.hs

@@ -65,7 +65,7 @@ data World = World
     , _pathPoints           :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
     , _pathInc              :: ~(M.Map Point2 [Point2])
     , _storedLevel          :: Maybe World
-    , _menuState            :: MenuState
+    , _menuLayers           :: [MenuLayer]
     , _worldState           :: M.Map WorldState Bool
     , _windowX              :: !Float
     , _windowY              :: !Float
@@ -83,6 +83,7 @@ data World = World
     , _varMovementStrafeSpeedModifier :: Float
     , _debugMode            :: Bool
     , _config               :: Configuration
+    , _configNeedsUpdate    :: Bool
     } 
 
 data Corpse = Corpse
@@ -100,7 +101,7 @@ data Layer
     | FlItLayer 
     | LabelLayer 
     | InvLayer 
-    | MenuLayer
+    | MenuDepth
     | PressPlateLayer 
     | CorpseLayer
     | UPtLayer

src/Dodge/Data/Menu.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE StrictData #-}
 module Dodge.Data.Menu
   where
-data MenuState 
+data MenuLayer 
     = LevelMenu Int
     | PauseMenu
     | GameOverMenu
     | OptionMenu
-    | InGame
+    | ConfigSaveScreen Int
   deriving (Eq,Ord)
 

src/Dodge/Default.hs

@@ -210,7 +210,7 @@ defaultWorld = World
     , _corpses = IM.empty
     , _decorations = IM.empty
     , _storedLevel = Nothing
-    , _menuState = LevelMenu 1
+    , _menuLayers = [LevelMenu 1]
     , _worldState = M.empty
     , _clickMousePos = (0,0)
     , _pathGraph = Data.Graph.Inductive.Graph.empty
@@ -236,6 +236,7 @@ defaultWorld = World
     , _varMovementStrafeSpeedModifier = 3
     , _debugMode = True
     , _config       = defaultConfig
+    , _configNeedsUpdate = False
     }
 youLight = 
     TLS { _tlsPos = (0,0)

src/Dodge/Event.hs

@@ -57,8 +57,8 @@ handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of
     where but = mouseButtonEventButton mbev
 
 handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World
-handleMouseWheelEvent mwev w = case _menuState w of
+handleMouseWheelEvent mwev w = case _menuLayers w of
-   InGame -> case mouseWheelEventPos mwev of
+   [] -> case mouseWheelEventPos mwev of
         V2 x y | y > 0      -> Just (wheelUpEvent w)
                | y < 0      -> Just (wheelDownEvent w)
                | otherwise  -> Just w

src/Dodge/Event/Keyboard.hs

@@ -57,9 +57,9 @@ handlePressedKeyInGame _ w = Just w
 handlePressedKey :: Bool -> Scancode -> World -> Maybe World
 handlePressedKey True _       w = Just w
 handlePressedKey _    scode w
-    | _menuState w == InGame 
+    | _menuLayers w == [] 
                 = handlePressedKeyInGame scode w
-    | otherwise = handlePressedKeyInMenu (_menuState w) scode w
+    | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w
 handlePressedKey _ _ w = Just w
 
 debugKey :: Scancode -> World -> Maybe World 
@@ -70,7 +70,6 @@ debugKey scancode w
     | scancode == ScancodeF6 = Just $ dropLight' w 
 debugKey _ w = Just w
 
-
 spaceAction :: World -> World
 spaceAction w = case listToMaybe $ _closeActiveObjects w of
     Just (Left flit) -> pickUpItem' flit w
@@ -78,7 +77,7 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of
     Nothing -> w
 
 pauseGame :: World -> World
-pauseGame w = w {_menuState = PauseMenu}
+pauseGame w = w {_menuLayers = [PauseMenu]}
 
 toggleMap w = w & carteDisplay %~ not
 escapeMap w = w & carteDisplay .~ False

src/Dodge/Event/Menu.hs

@@ -7,24 +7,25 @@ import Dodge.Rooms
 import Dodge.Floor
 import Dodge.Initialisation
 import Dodge.SoundLogic
+import Dodge.LoadConfig
 
 import Data.Maybe
 import qualified Data.Set as S
-
 import Control.Lens
-
 import SDL
 
-handlePressedKeyInMenu :: MenuState -> Scancode -> World -> Maybe World
+handlePressedKeyInMenu :: MenuLayer -> Scancode -> World -> Maybe World
 handlePressedKeyInMenu mState scode w = case mState of
     LevelMenu _ -> case scode of
             ScancodeEscape  -> Nothing
+            ScancodeO       -> goToOptionMenu w
             _               -> startLevel w
     PauseMenu   -> case scode of
             ScancodeEscape  -> Nothing
             ScancodeR       -> return $ fromMaybe w $ _storedLevel w
             ScancodeN       -> Just $ putSound $ generateLevel 1 
                                       $ initialWorld {_randGen = _randGen w}
+            ScancodeO       -> goToOptionMenu w
             _               -> unpause w
     GameOverMenu -> case scode of
             ScancodeEscape  -> Nothing
@@ -32,13 +33,27 @@ handlePressedKeyInMenu mState scode w = case mState of
             ScancodeN       -> Just $ putSound $ generateLevel 1 
                                                        $ initialWorld
                                                            {_randGen = _randGen w}
+            ScancodeO       -> goToOptionMenu w
             _               -> Just w
+    OptionMenu -> case scode of
+            ScancodeY       -> Just $ w & config . volume_master %~ dec
+            ScancodeU       -> Just $ w & config . volume_master %~ inc
+            ScancodeH       -> Just $ w & config . volume_sound  %~ dec
+            ScancodeJ       -> Just $ w & config . volume_sound  %~ inc
+            ScancodeN       -> Just $ w & config . volume_music  %~ dec
+            ScancodeM       -> Just $ w & config . volume_music  %~ inc
+            _               -> Just $ w & menuLayers %~ (ConfigSaveScreen 1:) . tail
+                                        & configNeedsUpdate .~ False
     _ -> Just w
   where 
     unpause w' = Just . resumeSound $
-                        w' {_menuState = InGame}
+                        w' {_menuLayers = []}
     startLevel = unpause . storeLevel
     putSound = id -- set loadedSounds (_loadedSounds w)
+    dec x = max 0 (x - 0.1)
+    inc x = min 1 (x + 0.1)
+    goToOptionMenu w = Just $ w & menuLayers %~ (OptionMenu :)
+                                & configNeedsUpdate .~ True
 
 storeLevel :: World -> World
 storeLevel w = case _storedLevel w of

src/Dodge/Initialisation.hs

@@ -47,7 +47,7 @@ initialWorld = defaultWorld
                 , _sounds = M.empty
                 , _decorations = IM.empty
                 , _storedLevel = Nothing
-                , _menuState = LevelMenu 1
+                , _menuLayers = [LevelMenu 1]
                 , _worldState = M.empty
                 , _windowX = 800
                 , _windowY = 600

src/Dodge/LoadConfig.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StrictData #-}
@@ -6,6 +7,9 @@ module Dodge.LoadConfig
       Configuration (..)
     , loadDodgeConfig
     , defaultConfig
+    , volume_master
+    , volume_sound
+    , volume_music
     , module Dodge.LoadConfig.KeyConfig
     ) where
 import Dodge.LoadConfig.KeyConfig
@@ -16,14 +20,17 @@ import GHC.Generics
 import qualified GHC.Int
 import qualified SDL
 import System.Directory
+import Control.Lens
 
 data Configuration = Configuration
-  { volume_master   :: Float
+  { _volume_master   :: Float
-  , volume_sound    :: Float
+  , _volume_sound    :: Float
-  , volume_music    :: Float
+  , _volume_music    :: Float
   }
   deriving (Generic, Show)
 
+makeLenses ''Configuration
+
 instance ToJSON Configuration where
   toEncoding = genericToEncoding defaultOptions
 
@@ -39,8 +46,8 @@ loadDodgeConfig = do
       return defaultConfig
 
 defaultConfig = Configuration
-    { volume_master = 1
+    { _volume_master = 1
-    , volume_sound  = 1
+    , _volume_sound  = 1
-    , volume_music  = 1
+    , _volume_music  = 1
     }
  

src/Dodge/Render/MenuScreen.hs

@@ -3,34 +3,50 @@ module Dodge.Render.MenuScreen
     )
     where
 import Dodge.Data
+import Dodge.LoadConfig
 import Dodge.Base (halfWidth,halfHeight)
 
 import Picture
 
 menuScreen :: World -> Picture
-menuScreen w = case _menuState w of
+menuScreen w = case _menuLayers w of
-                        InGame -> blank 
+    [] -> blank 
-                        LevelMenu x -> 
+    (LevelMenu x:_) -> pictures 
-                            pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w
+        [color (withAlpha 0.5 black) $ polygon $ screenBox w
-                            tst (-100) 100 0.4 ("LEVEL "++show x)
+        ,tst (-100) 100 0.4 ("LEVEL "++show x)
-                            ,controlsList
+        ,controlsList
-                            ]
+        ]
-                        PauseMenu   -> pictures 
+    (PauseMenu:_)   -> pictures 
-                                    [color (withAlpha 0.5 black) $ polygon $ screenBox w
+        [color (withAlpha 0.5 black) $ polygon $ screenBox w
-                                    ,tst (-100) 100 0.4 "PAUSED"
+        ,tst (-100) 100 0.4 "PAUSED"
-                                    ,tst (-100) 50 0.2 "n - new level"
+        ,tst (-100) 50 0.2 "n - new level"
-                                    ,tst (-100) 0 0.2 "r - restart"
+        ,tst (-100) 0 0.2 "r - restart"
-                                    ,tst (-100) (-50) 0.2 "o - options"
+        ,tst (-100) (-50) 0.2 "o - options"
-                                    , controlsList
+        , controlsList
-                                    ]
+        ]
-                        GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
+    (GameOverMenu:_) -> pictures 
-                                    ,tst (-100) 100 0.4 "GAME OVER"
+        [color (withAlpha 0.5 black) $ polygon $ screenBox w
-                                    ,tst (-100) 50 0.2 "n - new level"
+        ,tst (-100) 100 0.4 "GAME OVER"
-                                    ,tst (-100) 0 0.2 "r - restart"
+        ,tst (-100) 50 0.2 "n - new level"
-                                    ,tst (-100) (-50) 0.2 "o - options"
+        ,tst (-100) 0 0.2 "r - restart"
-                                    ,controlsList
+        ,tst (-100) (-50) 0.2 "o - options"
-                                    ]
+        ,controlsList
-                where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
+        ]
+    (OptionMenu : _) -> pictures 
+        [color (withAlpha 0.5 black) $ polygon $ screenBox w
+        ,tst (-100) 100 0.4 "OPTIONS"
+        ,tst (-180) 50 0.2    $ "y - master volume + u : " ++ mavol
+        ,tst (-180) 0 0.2     $ "h - sound  volume + j : " ++ snvol
+        ,tst (-180) (-50) 0.2 $ "n - music  volume + m : " ++ muvol
+        ,controlsList
+        ]
+    _ -> blank
+  where 
+    tst x y sc t = translate x y $ scale sc sc $ color white $ text t
+    mavol = f $ _volume_master $ _config w
+    snvol = f $ _volume_sound  $ _config w
+    muvol = f $ _volume_music  $ _config w
+    f x = show $ round $ 10 * x
 
 controlsList = pictures [tst (-250) (-130) 0.15 "controls:"
                ,tst (-150) (-130) 0.15 "wasd"

src/Dodge/Render/Picture.hs

@@ -29,7 +29,7 @@ worldPictures w = pictures $ concat
 fixedCoordPictures :: World -> Picture
 fixedCoordPictures w = pictures
     [ hudDrawings w
-    , scaler . onLayer MenuLayer $ menuScreen w
+    , scaler . onLayer MenuDepth $ menuScreen w
     , customMouseCursor w
     ]
   where 

src/Dodge/Update.hs

@@ -23,14 +23,15 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
 import Control.Lens
 {- | The update step.
-If the '_menuState' is not 'InGame', this is the identity.
+If '_menuLayers' is not empty, or the saving screen, this is the identity.
-This means that the only way to change the world is using event handling.
+In such menus, the only way to change the world is using event handling.
  -}
 update :: World -> World
-update w 
+update w = case _menuLayers w of
-    | _menuState w /= InGame = w
+    (ConfigSaveScreen x: ls) -> w & menuLayers .~ (ConfigSaveScreen (x-1) : ls)
-    | otherwise = 
+    (ConfigSaveScreen 0: ls) -> w & menuLayers .~ ls
-            let w1 = updateParticles' . updateProjectiles 
+    (_ : _) -> w    
+    []  ->  let w1 = updateParticles' . updateProjectiles 
                                       . updateLightSources
                                       . zoneClouds
                                       . updateClouds
@@ -101,7 +102,7 @@ setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
     where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
 
 checkEndGame :: World -> World
-checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuState = GameOverMenu}
+checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
                | otherwise         = w
 
 updateClouds :: World -> World