Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/loop

app/Main.hs

@@ -5,14 +5,11 @@ import LoadConfig
 import Dodge.Default
 import Dodge.Data
 import Dodge.Initialisation
-import Dodge.Rooms
-import Dodge.Layout
 import Dodge.Update
 import Dodge.Event
 import Dodge.Render
-import Dodge.Menu
-import Dodge.Floor
 import Dodge.LoadConfig
+import Dodge.Config.Update
 import Dodge.LoadSound
 import Picture
 import Picture.Render
@@ -22,27 +19,58 @@ import Preload
 import Sound.Data
 import Music
 
-import           Control.Concurrent
+import Control.Concurrent
-import           Control.Lens
+import Control.Lens
-import           Foreign                   (Word32)
+import Foreign (Word32)
-
 import Control.Monad (when,void)
-
+import System.Random
 import qualified Data.Map                  as M
-import           Graphics.Rendering.OpenGL hiding (color, rotate, scale,
+import qualified Data.IntMap                  as IM
-                                            translate)
+import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate)
-import qualified Data.Map as M
-import qualified Data.IntMap as IM
 import qualified SDL
 import qualified SDL.Mixer                 as Mix
 
-doPreload' :: IO (PreloadData a)
+main :: IO ()
-doPreload' = do
+main = do
+    (sizex,sizey) <- loadConfig
+    keyConfig <- loadKeyConfig
+    dodgeConfig <- loadDodgeConfig
+    setupLoop
+        (sizex,sizey)
+        (SDL.cursorVisible $= False >> doPreload' dodgeConfig >>= resizeSpareFBO sizex sizey)
+        (\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
+        (fmap (setWindowSize sizex sizey keyConfig . (config .~ dodgeConfig)) firstWorld)
+        doSideEffects
+        handleEvent
+        (Just . update)
+
+doSideEffects :: PreloadData SoundOrigin -> World -> IO (PreloadData SoundOrigin)
+doSideEffects 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)
+    
+    endTicks <- SDL.ticks
+    let lastFrameTicks = _frameTimer preData
+    when (_debugMode w) $ void $ renderFoldable
+                (_renderData preData)
+                (picToLTree Nothing . setLayer 1 . setDepth (-1)
+                    . translate (-0.5) (-0.8) . scale 0.0005 0.0005
+                    . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
+                )
+    foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds
+                    & frameTimer .~ endTicks)) (_doneSideEffects w)
+
+doPreload' :: Dodge.LoadConfig.Configuration -> IO (PreloadData a)
+doPreload' config = do
     lChunks <- loadSounds
     lMusic  <- loadMusic
     let sData = SoundData {_loadedChunks = lChunks, _playingSounds = M.empty}
         mData = MusicData {_loadedMusic = lMusic}
     Mix.playMusic Mix.Forever (lMusic IM.! 0)
+    setVolume config
     rData <- preloadRender
     return $ PreloadData 
         { _renderData   = rData 
@@ -51,38 +79,6 @@ doPreload' = do
         , _frameTimer   = 0
         }
 
-main :: IO ()
-main = do
-    (sizex,sizey) <- loadConfig
-    keyConfig <- loadKeyConfig
-    setupLoop
-        (sizex,sizey)
-        (SDL.cursorVisible $= False >> doPreload' >>= resizeSpareFBO sizex sizey)
-        (\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
-        (fmap (setWindowSize sizex sizey keyConfig) firstWorld)
-        ( \preData w -> do
-            startTicks <- SDL.ticks
-            void $ doDrawing (_renderData preData) w
-            playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
-            newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
-
-            endTicks <- SDL.ticks
-            let lastFrameTicks = _frameTimer preData
-            when (_debugMode w) $ void $ renderFoldable
-                        (_renderData preData)
-                        (picToLTree Nothing . setLayer 1 . setDepth (-1)
-                            . translate (-0.5) (-0.8) . scale 0.0005 0.0005
-                            . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
-                        )
-
-
-            return $ preData & soundData . playingSounds .~ newPlayingSounds
-                             & frameTimer .~ endTicks
-        )
-        (flip $ menuEvents handleEvent)
-        (Just . update)
-    Mix.closeAudio
-
 checkForGlErrors :: IO ()
 checkForGlErrors = do
     errs <- errors

src/Dodge/AIs.hs

@@ -1,11 +1,9 @@
 module Dodge.AIs where
--- imports {{{
 import Dodge.Data
 import Dodge.Base
 import Dodge.Path
 import Dodge.SoundLogic
 import Dodge.CreatureAction
-import Dodge.Event
 import Dodge.RandomHelp
 import Dodge.WorldEvent
 

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/Data.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Config.Data (
+      Configuration (..)
+    , defaultConfig
+    , volume_master
+    , volume_sound
+    , volume_music
+    ) where
+
+import Data.Aeson
+import Foreign.C.Types
+import GHC.Generics
+import qualified GHC.Int
+import qualified SDL
+import System.Directory
+import Control.Lens
+
+data Configuration = Configuration
+  { _volume_master   :: Float
+  , _volume_sound    :: Float
+  , _volume_music    :: Float
+  }
+  deriving (Generic, Show)
+
+makeLenses ''Configuration
+
+instance ToJSON Configuration where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON Configuration
+
+defaultConfig = Configuration
+    { _volume_master = 1
+    , _volume_sound  = 1
+    , _volume_music  = 1
+    }
+ 

src/Dodge/Config/Update.hs

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

src/Dodge/Creature/YourControl.hs

@@ -5,7 +5,6 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.CreatureAction
 import Dodge.Update.UsingInput
-import Dodge.Event
 import Dodge.CreatureState
 import Dodge.LoadConfig
 
@@ -90,3 +89,12 @@ wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (0,0) ks
     where f (0,0) = ((0,0), Nothing)
           f p     = (errorNormalizeV 46 p, Just $ argV p)
 
+mouseActionsCr :: S.Set SDL.MouseButton -> Creature -> Creature
+mouseActionsCr keys cr 
+    | rbPressed 
+        = set ( crState . stance . posture) Aiming cr
+    | otherwise
+        = set ( crState . stance . posture) AtEase cr
+    where lbPressed = SDL.ButtonLeft `S.member` keys
+          rbPressed = SDL.ButtonRight `S.member` keys
+

src/Dodge/Data.hs

@@ -3,11 +3,15 @@
 {-# LANGUAGE StrictData #-}
 module Dodge.Data 
     ( module Dodge.Data
+    , module Dodge.Data.Menu
     , Point2 (..)
     , Sound (..)
     , soundTime
     )
   where
+import Dodge.Data.Menu
+import Preload.Data
+
 import Picture.Data
 import Geometry.Data
 import Sound.Data
@@ -23,7 +27,8 @@ import SDL (Scancode, MouseButton)
 import Graphics.Rendering.OpenGL (PrimitiveMode (..),GLfloat,Program,VertexArrayObject,BufferObject)
 import Codec.Picture (Image,PixelRGBA8)
 import qualified Data.DList as DL
-import Dodge.LoadConfig
+import Dodge.Config.Data
+import Dodge.LoadConfig.KeyConfig
 
 import Data.Int (Int16)
 
@@ -62,7 +67,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
@@ -78,7 +83,11 @@ data World = World
     , _keyConfig            :: KeyConfigSDL
     , _varMovementSpeedModifier :: Float
     , _varMovementStrafeSpeedModifier :: Float
-    , _debugMode :: Bool
+    , _debugMode            :: Bool
+    , _config               :: Configuration
+    , _configNeedsUpdate    :: Bool
+    , _sideEffects          :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
+    , _doneSideEffects      :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
     } 
 
 data Corpse = Corpse
@@ -96,7 +105,7 @@ data Layer
     | FlItLayer 
     | LabelLayer 
     | InvLayer 
-    | MenuLayer
+    | MenuDepth
     | PressPlateLayer 
     | CorpseLayer
     | UPtLayer
@@ -242,13 +251,6 @@ data Faction
 data WorldState = DoorNumOpen Int | CrNumAlive Int
   deriving (Eq,Ord)
 
-data MenuState 
-    = LevelMenu Int
-    | PauseMenu
-    | GameOverMenu
-    | InGame
-  deriving (Eq,Ord)
-
 data Button = Button 
     { _btPict :: Picture
     , _btPos :: Point2

src/Dodge/Data/Menu.hs

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

src/Dodge/Default.hs

@@ -1,28 +1,28 @@
 {-# LANGUAGE BangPatterns #-}
+{- |
+Module      : Dodge.Default
+Description : Instances of data structures  
+
+This module contains prototypical data structures.
+-}
 module Dodge.Default where
 
 import Dodge.Item.Weapon.Recock
-
 import Dodge.Data
 import Dodge.SoundLogic
 import Dodge.Base
-
+import Dodge.LoadConfig
 import Geometry
 import Picture
 
 import Control.Lens
-
 import System.Random
-
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Graph.Inductive.Graph hiding ((&))
 import Data.List
 
-import Dodge.LoadConfig
-
--- defalt datatypes / prototypes {{{
 defaultWall = Wall { _wlLine = [(0,0),(50,0)]
                    , _wlID = 0
                    , _wlColor = greyN 0.6
@@ -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
@@ -234,10 +234,13 @@ defaultWorld = World
     , _keyConfig = defaultKeyConfigSDL
     , _varMovementSpeedModifier = 3
     , _varMovementStrafeSpeedModifier = 3
-    , _debugMode = False
+    , _debugMode = True
+    , _config       = defaultConfig
+    , _configNeedsUpdate = False
+    , _sideEffects          = []
+    , _doneSideEffects      = []
     }
 youLight = 
---    LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) 
     TLS { _tlsPos = (0,0)
         ,_tlsRad = 300
         ,_tlsIntensity = 0.1

src/Dodge/Event.hs

@@ -1,12 +1,28 @@
-module Dodge.Event where
+{- |
-import Dodge.Event.Keyboard
+Module      : Dodge.Event
+Description : Direct event handling
 
+Deals with direct events.
+This includes individual key or mouse presses, but /not/ continuous held down input.
+We cannot handle multiple keys held down at once here,
+(eg left mouse button + right mouse button)
+because these are separate events.
+Instead we store the events in a set, and deal with the combinations in
+"Dodge.Update".
+-}
+module Dodge.Event 
+    ( handleEvent
+    ) where
+import Dodge.Event.Keyboard
+import Dodge.Event.Menu
 import Dodge.Data
 import Dodge.Base
 import Dodge.CreatureAction
 import Dodge.SoundLogic
 import Dodge.Inventory
 import Geometry
+import Preload.Update
+
 import Control.Lens
 import Data.Maybe
 import Data.Char
@@ -15,16 +31,12 @@ import Data.Function (on)
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import SDL
--- Deals with direct events
--- This includes individual key/mouse presses, but /not/ continuous held down input
--- We cannot handle multiple keys held down at once here,
--- (eg left mouse button + right mouse button)
--- because these are separate events
--- Instead we store the events in a set, and deal with the combinations in
--- Update
 
-handleEvent :: Event -> World -> Maybe World
+handleEvent :: World -> Event -> Maybe World
-handleEvent e = case eventPayload e of
+handleEvent = flip handleEvent'
+
+handleEvent' :: Event -> World -> Maybe World
+handleEvent' e = case eventPayload e of
     KeyboardEvent kev           -> handleKeyboardEvent kev
     MouseMotionEvent mmev       -> handleMouseMotionEvent mmev
     MouseButtonEvent mbev       -> handleMouseButtonEvent mbev
@@ -47,16 +59,20 @@ handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of
     where but = mouseButtonEventButton mbev
 
 handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World
-handleMouseWheelEvent mwev = 
+handleMouseWheelEvent mwev w = case _menuLayers w of
-    case mouseWheelEventPos mwev of
+   [] -> case mouseWheelEventPos mwev of
-        V2 x y | y > 0      -> Just . wheelUpEvent
+        V2 x y | y > 0      -> Just (wheelUpEvent w)
-               | y < 0      -> Just . wheelDownEvent
+               | y < 0      -> Just (wheelDownEvent w)
-               | otherwise  -> Just
+               | otherwise  -> Just w
+   _ -> Just w
 
 handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World
-handleResizeEvent sev = Just . set windowX (fromIntegral x)
+handleResizeEvent sev = Just 
-                             . set windowY (fromIntegral y)
+    . set windowX (fromIntegral x)
-  where V2 x y = windowSizeChangedEventSize sev
+    . set windowY (fromIntegral y)
+    . over sideEffects ( resizeSpareFBO (fromIntegral x) (fromIntegral y) : )
+  where 
+    V2 x y = windowSizeChangedEventSize sev
 
 handlePressedMouseButton :: MouseButton -> World -> Maybe World
 handlePressedMouseButton but w 
@@ -113,12 +129,3 @@ before y (x:z:ys) | y == z    = x
 after y (x:z:ys)  | y == x    = z
                   | otherwise = after y (z:ys)
 
-mouseActionsCr :: S.Set MouseButton -> Creature -> Creature
-mouseActionsCr keys cr 
-    | rbPressed 
-        = set ( crState . stance . posture) Aiming cr
-    | otherwise
-        = set ( crState . stance . posture) AtEase cr
-    where lbPressed = ButtonLeft `S.member` keys
-          rbPressed = ButtonRight `S.member` keys
-

src/Dodge/Event/Keyboard.hs

@@ -1,3 +1,6 @@
+{- |
+Deals with keyboard events.
+-}
 module Dodge.Event.Keyboard
     ( handleKeyboardEvent
     )
@@ -12,6 +15,7 @@ import Dodge.LevelGen
 import Dodge.Creature.Inanimate
 import qualified Data.IntMap.Strict as IM
 import Dodge.Event.Test
+import Dodge.Event.Menu
 
 import SDL
 import Data.Maybe
@@ -20,6 +24,11 @@ import Control.Lens
 
 import Picture
 
+{- | Handles keyboard press and release.
+On release, remove scancode from the 'Set' of pressed keys.
+On press, adds the scancode, and perhaps applies a direct effect:
+see 'handlePressedKeyInGame'.
+ -}
 handleKeyboardEvent :: KeyboardEventData -> World -> Maybe World
 handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of
     Released    -> Just $ w & keys %~ S.delete kcode
@@ -30,33 +39,35 @@ handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of
   where
     kcode = (keysymScancode . keyboardEventKeysym) kev
 
+handlePressedKeyInGame :: Scancode -> World -> Maybe World
+handlePressedKeyInGame scode w
+    |  scode == escapeKey (_keyConfig w) = Nothing
+    |  scode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w
+    |  scode == dropItemKey (_keyConfig w) = Just $ dropItem w
+    |  scode == toggleMapKey (_keyConfig w) = Just $ toggleMap w
+    |  scode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ reloadWeapon (_yourID w) w
+    |  scode == testEventKey (_keyConfig w) = Just $ testEvent w
+    |  scode == spaceActionKey (_keyConfig w) = Just $ spaceAction w
+    |  scode == rotateCameraPlusKey (_keyConfig w)  = Just $ w & cameraRot +~ 0.01
+    |  scode == rotateCameraMinusKey (_keyConfig w) = Just $ w & cameraRot -~ 0.01
+    |  scode ==   ScancodeF11      = Just $ w {_debugMode = not $ _debugMode w} 
+    | _debugMode w = debugKey scode w
+handlePressedKeyInGame _ w = Just w
+
 handlePressedKey :: Bool -> Scancode -> World -> Maybe World
 handlePressedKey True _       w = Just w
-handlePressedKey _    scancode w 
+handlePressedKey _    scode w
-    |  scancode == escapeKey (_keyConfig w) = Nothing
+    | _menuLayers w == [] 
-    |  scancode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w
+                = handlePressedKeyInGame scode w
-    |  scancode == dropItemKey (_keyConfig w) = Just $ dropItem w
+    | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w
-    |  scancode == toggleMapKey (_keyConfig w) = Just $ toggleMap w
-    |  scancode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ reloadWeapon (_yourID w) w
-    |  scancode == testEventKey (_keyConfig w) = Just $ testEvent w
-    |  scancode == spaceActionKey (_keyConfig w) = Just $ spaceAction w
-    -- Rotation seems to be duplicated here and in Camera.hs ? why
-    |  scancode == rotateCameraPlusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w + 0.01}
-    |  scancode == rotateCameraMinusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w - 0.01}
-    |  scancode ==   ScancodeF11      = Just $ w {_debugMode = not $ _debugMode w} 
-    | _debugMode w = debugKey scancode w
-    -- |  _debugMode w && scancode ==   ScancodeF7      = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w - 1}
-    -- |   _debugMode w && scancode ==   ScancodeF8      = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w + 1}
-    -- |   _debugMode w && scancode ==   ScancodeF5      = Just $ dropLight w 
-    -- |   _debugMode w && scancode ==   ScancodeF6      = Just $ dropLight' w 
 handlePressedKey _ _ w = Just w
 
 debugKey :: Scancode -> World -> Maybe World 
 debugKey scancode w
-    | scancode ==   ScancodeF7      = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w - 1}
+    | scancode == ScancodeF7 = Just $ w & varMovementSpeedModifier -~ 1
-    | scancode ==   ScancodeF8      = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w + 1}
+    | scancode == ScancodeF8 = Just $ w & varMovementSpeedModifier +~ 1
-    | scancode ==   ScancodeF5      = Just $ dropLight w 
+    | scancode == ScancodeF5 = Just $ dropLight w 
-    | scancode ==   ScancodeF6      = Just $ dropLight' w 
+    | scancode == ScancodeF6 = Just $ dropLight' w 
 debugKey _ w = Just w
 
 spaceAction :: World -> World
@@ -66,14 +77,14 @@ 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
 
 dropLight :: World -> World
 dropLight w = placeLS ls dec pos 0
-        -- $ over creatures IM.insert i (lamp)
+        --  $ over creatures IM.insert i (lamp)
         $ w
         --case yourItem w of
         --NoItem -> w

src/Dodge/Event/Menu.hs

@@ -0,0 +1,66 @@
+module Dodge.Event.Menu
+    ( handlePressedKeyInMenu
+    )
+    where
+import Dodge.Data
+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 :: MenuLayer -> Scancode -> World -> Maybe World
+handlePressedKeyInMenu mState scode w = case mState of
+    LevelMenu _ -> case scode of
+            ScancodeEscape  -> Nothing
+            ScancodeO       -> goToOptionMenu w
+            ScancodeC       -> goToControls 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
+            ScancodeC       -> goToControls w
+            _               -> unpause w
+    GameOverMenu -> case scode of
+            ScancodeEscape  -> Nothing
+            ScancodeR       -> Just $ fromMaybe w $ _storedLevel w
+            ScancodeN       -> Just $ putSound $ generateLevel 1 
+                                                       $ initialWorld
+                                                           {_randGen = _randGen w}
+            ScancodeO       -> goToOptionMenu w
+            ScancodeC       -> goToControls 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 , ConfigSaveScreen] ++) . tail
+                                        & configNeedsUpdate .~ False
+    ControlList -> Just $ w & menuLayers %~ tail
+    _ -> Just w
+  where 
+    unpause w' = Just . resumeSound $
+                        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
+    goToControls w = Just $ w & menuLayers %~ (ControlList :)
+
+storeLevel :: World -> World
+storeLevel w = case _storedLevel w of
+                 Nothing -> w & storedLevel ?~ w
+                 _       -> w

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,152 +1,31 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StrictData #-}
 module Dodge.LoadConfig
-  where
+    ( 
-import Data.Aeson
+      loadDodgeConfig
-import Foreign.C.Types
+    , module Dodge.LoadConfig.KeyConfig
-import GHC.Generics
+    , module Dodge.Config.Data
-import qualified GHC.Int
+    ) where
-import qualified SDL
+import Dodge.LoadConfig.KeyConfig
-import SDL.Internal.Numbered as SDL.Internal.Numbered
+import Dodge.Config.Data
+import Dodge.Config.Update
 
+import Data.Aeson
 import System.Directory
 
-data KeyConfig = KeyConfig
+loadDodgeConfig :: IO Configuration
-  { moveUpBinding :: Int,
+loadDodgeConfig = do
-    moveDownBinding :: Int,
+    fExists <- doesFileExist "data/dodge.config.json"
-    moveLeftBinding :: Int,
-    moveRightBinding :: Int,
-    pauseBinding :: Int,
-    escapeBinding :: Int,
-    dropItemBinding :: Int,
-    toggleMapBinding :: Int,
-    reloadBinding :: Int,
-    testEventBinding :: Int,
-    spaceActionBinding :: Int,
-    rotateCameraPlusBinding :: Int,
-    rotateCameraMinusBinding :: Int,
-    zoomInBinding :: Int,
-    zoomOutBinding :: Int,
-    newBinding :: Int
-  }
-  deriving (Generic, Show)
-
-data KeyConfigSDL = KeyConfigSDL
-  { moveUpKey :: SDL.Scancode,
-    moveDownKey :: SDL.Scancode,
-    moveLeftKey :: SDL.Scancode,
-    moveRightKey :: SDL.Scancode,
-    pauseKey :: SDL.Scancode,
-    escapeKey :: SDL.Scancode,
-    dropItemKey :: SDL.Scancode,
-    toggleMapKey :: SDL.Scancode,
-    reloadKey :: SDL.Scancode,
-    testEventKey :: SDL.Scancode,
-    spaceActionKey :: SDL.Scancode,
-    rotateCameraPlusKey :: SDL.Scancode,
-    rotateCameraMinusKey :: SDL.Scancode,
-    zoomInKey :: SDL.Scancode,
-    zoomOutKey :: SDL.Scancode,
-    newKey :: SDL.Scancode 
-  }
-  deriving (Generic, Show)
-
-defaultKeyConfigSDL =
-  KeyConfigSDL
-    { moveUpKey = SDL.ScancodeW,
-      moveDownKey = SDL.ScancodeS,
-      moveLeftKey = SDL.ScancodeA,
-      moveRightKey = SDL.ScancodeD,
-      pauseKey = SDL.ScancodeP,
-      escapeKey = SDL.ScancodeEscape,
-      dropItemKey = SDL.ScancodeF,
-      toggleMapKey = SDL.ScancodeM,
-      reloadKey = SDL.ScancodeR,
-      testEventKey = SDL.ScancodeT,
-      spaceActionKey = SDL.ScancodeSpace,
-      rotateCameraPlusKey = SDL.ScancodeQ,
-      rotateCameraMinusKey = SDL.ScancodeE,
-      zoomInKey = SDL.ScancodeJ,
-      zoomOutKey = SDL.ScancodeK,
-      newKey = SDL.ScancodeN
-    }
-
-instance ToJSON KeyConfig where
-  toEncoding = genericToEncoding defaultOptions
-
-instance FromJSON KeyConfig where
-  parseJSON = withObject "KeyConfig" $ \o -> do
-    moveUpBinding <- o .:? "moveUp" .!= 119
-    moveDownBinding <- o .:? "moveDown" .!= 115
-    moveLeftBinding <- o .:? "moveLeft" .!= 97
-    moveRightBinding <- o .:? "moveRight" .!= 100
-    pauseBinding <- o .:? "pause" .!= 112
-    escapeBinding <- o .:? "escape" .!= 27
-    dropItemBinding <- o .:? "dropItem" .!= 102
-    toggleMapBinding <- o .:? "toggleMap" .!= 109
-    reloadBinding <- o .:? "reload" .!= 114
-    testEventBinding <- o .:? "testEvent" .!= 116
-    spaceActionBinding <- o .:? "spaceAction" .!= 32
-    rotateCameraPlusBinding <- o .:? "rotateCameraPlus" .!= 113
-    rotateCameraMinusBinding <- o .:? "rotateCameraMinus" .!= 101
-    zoomInBinding <- o .:? "zoomIn" .!= 106
-    zoomOutBinding <- o .:? "zoomOut" .!= 107
-    newBinding <- o .:? "new" .!= 110
-    return
-      KeyConfig
-        { moveUpBinding = moveUpBinding,
-          moveDownBinding = moveDownBinding,
-          moveLeftBinding = moveLeftBinding,
-          moveRightBinding = moveRightBinding,
-          pauseBinding = pauseBinding,
-          escapeBinding = escapeBinding,
-          dropItemBinding = dropItemBinding,
-          toggleMapBinding = toggleMapBinding,
-          reloadBinding = reloadBinding,
-          testEventBinding = testEventBinding,
-          spaceActionBinding = spaceActionBinding,
-          rotateCameraPlusBinding = rotateCameraPlusBinding,
-          rotateCameraMinusBinding = rotateCameraMinusBinding,
-          zoomInBinding = zoomInBinding,
-          zoomOutBinding = zoomOutBinding,
-          newBinding = newBinding
-        }
-
-loadKeyConfig :: IO KeyConfigSDL
-loadKeyConfig = do
-    fExists <- doesFileExist "keys.json"
     if fExists
     then do
-        mayConfig <- decodeFileStrict "keys.json"
+        mayConfig <- decodeFileStrict "data/dodge.config.json"
-        print mayConfig
         case mayConfig of
-          Just config ->
+          Just config -> setVolume config >> return config
-            return
-              KeyConfigSDL
-                { moveUpKey = getSdlScancode $ moveUpBinding config,
-                  moveDownKey = getSdlScancode $ moveDownBinding config,
-                  moveLeftKey = getSdlScancode $ moveLeftBinding config,
-                  moveRightKey = getSdlScancode $ moveRightBinding config,
-                  pauseKey = getSdlScancode $ pauseBinding config,
-                  escapeKey = getSdlScancode $ escapeBinding config,
-                  dropItemKey = getSdlScancode $ dropItemBinding config,
-                  toggleMapKey = getSdlScancode $ toggleMapBinding config,
-                  reloadKey = getSdlScancode $ reloadBinding config,
-                  testEventKey = getSdlScancode $ testEventBinding config,
-                  spaceActionKey = getSdlScancode $ spaceActionBinding config,
-                  rotateCameraPlusKey = getSdlScancode $ rotateCameraPlusBinding config,
-                  rotateCameraMinusKey = getSdlScancode $ rotateCameraMinusBinding config,
-                  zoomInKey = getSdlScancode $ zoomInBinding config,
-                  zoomOutKey = getSdlScancode $ zoomOutBinding config,
-                  newKey = getSdlScancode $ newBinding config
-                }
           Nothing -> do
-            putStrLn "invalid keys.json, loading default config"
+            putStrLn "invalid data/dodge.config.json, loading default config"
-            -- This is duplicated but not sure how to reduce
+            return defaultConfig
-            return defaultKeyConfigSDL
     else do
-        putStrLn "No keys.json found, loading default config"
+        putStrLn "No data/data/dodge.config.json found, loading defaults"
-        return defaultKeyConfigSDL
+        return defaultConfig
-
-getSdlScancode :: Int -> SDL.Scancode
-getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode

src/Dodge/LoadConfig/KeyConfig.hs

@@ -0,0 +1,152 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Dodge.LoadConfig.KeyConfig
+  where
+import Data.Aeson
+import Foreign.C.Types
+import GHC.Generics
+import qualified GHC.Int
+import qualified SDL
+import SDL.Internal.Numbered as SDL.Internal.Numbered
+
+import System.Directory
+
+data KeyConfig = KeyConfig
+  { moveUpBinding :: Int,
+    moveDownBinding :: Int,
+    moveLeftBinding :: Int,
+    moveRightBinding :: Int,
+    pauseBinding :: Int,
+    escapeBinding :: Int,
+    dropItemBinding :: Int,
+    toggleMapBinding :: Int,
+    reloadBinding :: Int,
+    testEventBinding :: Int,
+    spaceActionBinding :: Int,
+    rotateCameraPlusBinding :: Int,
+    rotateCameraMinusBinding :: Int,
+    zoomInBinding :: Int,
+    zoomOutBinding :: Int,
+    newBinding :: Int
+  }
+  deriving (Generic, Show)
+
+data KeyConfigSDL = KeyConfigSDL
+  { moveUpKey :: SDL.Scancode,
+    moveDownKey :: SDL.Scancode,
+    moveLeftKey :: SDL.Scancode,
+    moveRightKey :: SDL.Scancode,
+    pauseKey :: SDL.Scancode,
+    escapeKey :: SDL.Scancode,
+    dropItemKey :: SDL.Scancode,
+    toggleMapKey :: SDL.Scancode,
+    reloadKey :: SDL.Scancode,
+    testEventKey :: SDL.Scancode,
+    spaceActionKey :: SDL.Scancode,
+    rotateCameraPlusKey :: SDL.Scancode,
+    rotateCameraMinusKey :: SDL.Scancode,
+    zoomInKey :: SDL.Scancode,
+    zoomOutKey :: SDL.Scancode,
+    newKey :: SDL.Scancode 
+  }
+  deriving (Generic, Show)
+
+defaultKeyConfigSDL =
+  KeyConfigSDL
+    { moveUpKey = SDL.ScancodeW,
+      moveDownKey = SDL.ScancodeS,
+      moveLeftKey = SDL.ScancodeA,
+      moveRightKey = SDL.ScancodeD,
+      pauseKey = SDL.ScancodeP,
+      escapeKey = SDL.ScancodeEscape,
+      dropItemKey = SDL.ScancodeF,
+      toggleMapKey = SDL.ScancodeM,
+      reloadKey = SDL.ScancodeR,
+      testEventKey = SDL.ScancodeT,
+      spaceActionKey = SDL.ScancodeSpace,
+      rotateCameraPlusKey = SDL.ScancodeQ,
+      rotateCameraMinusKey = SDL.ScancodeE,
+      zoomInKey = SDL.ScancodeJ,
+      zoomOutKey = SDL.ScancodeK,
+      newKey = SDL.ScancodeN
+    }
+
+instance ToJSON KeyConfig where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON KeyConfig where
+  parseJSON = withObject "KeyConfig" $ \o -> do
+    moveUpBinding <- o .:? "moveUp" .!= 119
+    moveDownBinding <- o .:? "moveDown" .!= 115
+    moveLeftBinding <- o .:? "moveLeft" .!= 97
+    moveRightBinding <- o .:? "moveRight" .!= 100
+    pauseBinding <- o .:? "pause" .!= 112
+    escapeBinding <- o .:? "escape" .!= 27
+    dropItemBinding <- o .:? "dropItem" .!= 102
+    toggleMapBinding <- o .:? "toggleMap" .!= 109
+    reloadBinding <- o .:? "reload" .!= 114
+    testEventBinding <- o .:? "testEvent" .!= 116
+    spaceActionBinding <- o .:? "spaceAction" .!= 32
+    rotateCameraPlusBinding <- o .:? "rotateCameraPlus" .!= 113
+    rotateCameraMinusBinding <- o .:? "rotateCameraMinus" .!= 101
+    zoomInBinding <- o .:? "zoomIn" .!= 106
+    zoomOutBinding <- o .:? "zoomOut" .!= 107
+    newBinding <- o .:? "new" .!= 110
+    return
+      KeyConfig
+        { moveUpBinding = moveUpBinding,
+          moveDownBinding = moveDownBinding,
+          moveLeftBinding = moveLeftBinding,
+          moveRightBinding = moveRightBinding,
+          pauseBinding = pauseBinding,
+          escapeBinding = escapeBinding,
+          dropItemBinding = dropItemBinding,
+          toggleMapBinding = toggleMapBinding,
+          reloadBinding = reloadBinding,
+          testEventBinding = testEventBinding,
+          spaceActionBinding = spaceActionBinding,
+          rotateCameraPlusBinding = rotateCameraPlusBinding,
+          rotateCameraMinusBinding = rotateCameraMinusBinding,
+          zoomInBinding = zoomInBinding,
+          zoomOutBinding = zoomOutBinding,
+          newBinding = newBinding
+        }
+
+loadKeyConfig :: IO KeyConfigSDL
+loadKeyConfig = do
+    fExists <- doesFileExist "keys.json"
+    if fExists
+    then do
+        mayConfig <- decodeFileStrict "keys.json"
+        print mayConfig
+        case mayConfig of
+          Just config ->
+            return
+              KeyConfigSDL
+                { moveUpKey = getSdlScancode $ moveUpBinding config,
+                  moveDownKey = getSdlScancode $ moveDownBinding config,
+                  moveLeftKey = getSdlScancode $ moveLeftBinding config,
+                  moveRightKey = getSdlScancode $ moveRightBinding config,
+                  pauseKey = getSdlScancode $ pauseBinding config,
+                  escapeKey = getSdlScancode $ escapeBinding config,
+                  dropItemKey = getSdlScancode $ dropItemBinding config,
+                  toggleMapKey = getSdlScancode $ toggleMapBinding config,
+                  reloadKey = getSdlScancode $ reloadBinding config,
+                  testEventKey = getSdlScancode $ testEventBinding config,
+                  spaceActionKey = getSdlScancode $ spaceActionBinding config,
+                  rotateCameraPlusKey = getSdlScancode $ rotateCameraPlusBinding config,
+                  rotateCameraMinusKey = getSdlScancode $ rotateCameraMinusBinding config,
+                  zoomInKey = getSdlScancode $ zoomInBinding config,
+                  zoomOutKey = getSdlScancode $ zoomOutBinding config,
+                  newKey = getSdlScancode $ newBinding config
+                }
+          Nothing -> do
+            putStrLn "invalid keys.json, loading default config"
+            -- This is duplicated but not sure how to reduce
+            return defaultKeyConfigSDL
+    else do
+        putStrLn "No keys.json found, loading default config"
+        return defaultKeyConfigSDL
+
+getSdlScancode :: Int -> SDL.Scancode
+getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode

src/Dodge/Menu.hs

@@ -1,104 +0,0 @@
-module Dodge.Menu where
--- imports {{{
-import Dodge.Data
-import Dodge.Rooms
-import Dodge.Floor
-import Dodge.Initialisation
-import Dodge.SoundLogic
-
-import Data.Tree
-import Data.Maybe
-import qualified Data.Set as S
-
-import Control.Lens
-import Control.Monad
-import Control.Monad.State
-
-
-import System.Exit
-import System.Random
-
---import Graphics.Gloss.Interface.IO.Game
-import SDL
--- }}}
-
-keyPressedDown :: Event -> Maybe Scancode
-keyPressedDown e = case eventPayload e of
-    KeyboardEvent (KeyboardEventData _ Pressed False keysym) -> Just $ keysymScancode keysym
-    _ -> Nothing
-
-menuEvents :: (Event -> World -> Maybe World) -> Event -> World -> Maybe World
-menuEvents f e w = case _menuState w of
-    LevelMenu _ -> case keyPressedDown e of
-            Just ScancodeEscape -> Nothing
-            Just _             -> startLevel w >>= f e
-            _                  -> Just w
-    PauseMenu -> case keyPressedDown e of
-            Just ScancodeEscape -> Nothing
-            Just ScancodeR      -> return $ fromMaybe w $ _storedLevel w
-            Just ScancodeN      -> Just $ putSound $ generateLevel 1 
-                                           $ initialWorld {_randGen = _randGen w}
-            Just _             -> unpause w >>= f e
-            _                  -> Just w
-    GameOverMenu -> case keyPressedDown e of
-            Just ScancodeEscape -> Nothing
-            Just ScancodeR      -> Just $ fromMaybe w $ _storedLevel w
-            Just ScancodeN      -> Just $ putSound $ generateLevel 1 
-                                                            $ initialWorld
-                                                                {_randGen = _randGen w}
-            _                              -> return w
-    _ -> f e w
-    where unpause w' = Just $ resumeSound $
-                        w' {_menuState = InGame,_keys = S.empty}
-          startLevel = unpause . storeLevel
-          putSound = id -- set loadedSounds (_loadedSounds w)
-    
-
----  menuCheckKeyEvents :: (Event -> World -> IO World) -> Event -> World -> IO World
----  menuCheckKeyEvents f e w = case _menuState w of
----      LevelMenu _ -> case e of
----              (EventKey (SpecialKey KeyEsc) Down _ _) 
----                                             -> exitSuccess
----              (EventKey _ Down _ _) -> startLevel w >>= f e
----              _                              -> return w
----      PauseMenu -> case e of
----              (EventKey (SpecialKey KeyEsc) Down _ _) 
----                                             -> exitSuccess
----              (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w
----              (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1 
----                                                              $ initialWorld 
----                                                                  {_randGen = _randGen w}
----  --            (EventKey (Char 'c') Down _ _) -> unpaused
----  --            (EventKey (Char 'p') Down _ _) -> unpaused
----  --            (EventKey (SpecialKey KeySpace) Down _ _) -> unpaused
----              (EventKey _ Down _ _) -> unpause w >>= f e
----              _                              -> return w
----      GameOverMenu -> case e of
----              (EventKey (SpecialKey KeyEsc) Down _ _) 
----                                             -> exitSuccess
----              (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w
----              (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1 
----                                                              $ initialWorld
----                                                                  {_randGen = _randGen w}
----  --            (EventKey (Char 'c') Down _ _) -> unpaused
----              _                              -> return w
----      _ -> f e w
----      where unpause w' = do Mix.resume (-1)
----                            return w' {_menuState = InGame,_keys = S.empty}
----            startLevel = unpause . storeLevel
----            putSound = set loadedSounds (_loadedSounds w)
----  -- there might be a better way to pass the loaded sounds around
-
-updateRandGen :: World -> World
-updateRandGen = over randGen (fst . split)
-
-menuCheckUpdate :: (Float -> World -> IO World) -> Float -> World -> IO World
-menuCheckUpdate f t w = case _menuState w of
-    InGame -> f t w
-    _      -> return w
-
-storeLevel :: World -> World
-storeLevel w = case _storedLevel w of
-                 Nothing -> set storedLevel (Just w) w
-                 _       -> w
-

src/Dodge/Render/MenuScreen.hs

@@ -3,52 +3,78 @@ 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
+        ]
-                            ]
+    (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"
-                                    , controlsList
+        ,tst (-100) (-100) 0.2 "c - controls"
-                                    ]
+        ]
-                        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"
-                                    ,controlsList
+        ,tst (-100) 0 0.2 "r - restart"
-                                    ]
+        ,tst (-100) (-50) 0.2 "o - options"
-                where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
+        ,tst (-100) (-100) 0.2 "c - controls"
+        ]
+    (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
+        ]
+    (ControlList : _) -> pictures 
+        [color (withAlpha 0.5 black) $ polygon $ screenBox w
+        ,tst (-100) 100 0.4 "CONTROLS"
+        ,controlsList
+        ]
+    (ConfigSaveScreen : _) -> 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
+        ]
+    _ -> 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:"
+controlsList = pictures $ concat $ zipWith butAndEff
-               ,tst (-150) (-130) 0.15 "wasd"
+    [("wasd",           "movement")
-               ,tst  0   (-130) 0.15 "movement"
+    ,("[rmb]",          "aim")
-               ,tst (-150) (-160) 0.15 "[rmb]"
+    ,("[rmb+lmb]",      "shoot or use item")
-               ,tst  0     (-160) 0.15 "aim"
+    ,("[wheelscroll]" , "select item"  )
-               ,tst (-150) (-190) 0.15 "[rmb+lmb]"
+    ,("[space]" ,       "pickup item"  )
-               ,tst  0     (-190) 0.15 "shoot or use item"
+    ,("m" ,             "display map"    )
-               ,tst (-150) (-220) 0.15 "[wheelscroll]"
+    ,("f" ,             "drop item"    )
-               ,tst  0     (-220) 0.15 "select item"
+    ,("c[esc]" ,        "pause"        )
-               ,tst (-150) (-250) 0.15 "[space]"
+    ,("qe" ,       "rotate camera")
-               ,tst 0      (-250) 0.15 "pickup item"
+    ]
-               ,tst (-150) (-280) 0.15 "f"
+    [60,30..]
-               ,tst 0      (-280) 0.15 "drop item"
+  where
-               ,tst (-150) (-310) 0.15 "cp[esc]"
+    butAndEff (btext,etext) y = 
-               ,tst 0      (-310) 0.15 "pause"
+        [translate (-250) y $ scale 0.15 0.15 $ color white $ text btext
-               ,tst (-150) (-340) 0.15 "qe[lmb]"
+        ,translate     0  y $ scale 0.15 0.15 $ color white $ text etext
-               ,tst 0      (-340) 0.15 "rotate camera"
+        ]
-               ]
-                where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
 
 screenBox w = [  (halfWidth w, halfHeight w)
               , (-halfWidth w, halfHeight w)

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/SoundLogic.hs

@@ -65,7 +65,7 @@ resumeSound :: World -> World
 resumeSound w = w
 
 {-| Add a sound to the queue for playback.
-Consider replacing with 'soundOncePos'.
+Consider replacing instances with 'soundOncePos'.
  -}
 soundOnce :: Int -> World -> World
 soundOnce i = over soundQueue ((:) (i,0))

src/Dodge/Update.hs

@@ -1,5 +1,10 @@
-module Dodge.Update where
+{- |
--- imports {{{
+Module      : Dodge.Update
+Description : Simulation update
+-}
+module Dodge.Update 
+    ( update
+    ) where
 import Dodge.Data
 import Dodge.Base
 import Dodge.WallCreatureCollisions
@@ -8,7 +13,6 @@ import Dodge.Update.Camera
 import Dodge.Update.UsingInput
 import Dodge.SoundLogic
 import Dodge.Inventory
-
 import Geometry
 
 import Data.List
@@ -17,17 +21,24 @@ import Data.Function
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
-
 import Control.Lens
 
+update = update' . pushSideEffects
 
--- }}}
+pushSideEffects :: World -> World
+pushSideEffects w = w 
+    & sideEffects .~ []
+    & doneSideEffects .~ _sideEffects w
 
-update :: World -> World
+{- | The update step.
-update w 
+If '_menuLayers' is not empty, or the saving screen, this is the identity.
-    | _menuState w /= InGame = w
+In such menus, the only way to change the world is using event handling.
-    | otherwise = 
+ -}
-            let w1 = updateParticles' . updateProjectiles 
+update' :: World -> World
+update' w = case _menuLayers w of
+    (ConfigSaveScreen : ls) -> w & menuLayers .~ ls
+    (_ : _) -> w    
+    []  ->  let w1 = updateParticles' . updateProjectiles 
                                       . updateLightSources
                                       . zoneClouds
                                       . updateClouds
@@ -35,7 +46,6 @@ update w
                                       . updateBlocks -- . zoning 
                                       . updateSeenWalls 
                                       . updateSoundQueue
---                                      . updateUsingInput
                                       $ updateCloseObjects w
             in  checkEndGame . ppEvents 
                              . updateCamera
@@ -45,22 +55,15 @@ update w
                              . wallEvents
                              . set worldEvents id 
                              $ _worldEvents w1 w1
-  where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
+  where 
-          --               w
+    zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
-          -- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
+    creatureInZone cr = insertIMInZone x y cid cr
-          --                   = insertIMInZone x y wlid wl
+      where (x,y) = zoneOfPoint $ _crPos cr
-          --               | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
+            cid = _crID cr
-          --   where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
+    zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w))
-          --         wlid  = _wlID wl
+    cloudInZone cr = insertIMInZone x y cid cr
-          --         ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
+      where (x,y) = zoneOfPoint $ _clPos cr
-          zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
+            cid = _clID cr
-          creatureInZone cr = insertIMInZone x y cid cr
-            where (x,y) = zoneOfPoint $ _crPos cr
-                  cid = _crID cr
-          zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w))
-          cloudInZone cr = insertIMInZone x y cid cr
-            where (x,y) = zoneOfPoint $ _clPos cr
-                  cid = _clID cr
 
 updateSoundQueue = set soundQueue []
                     . set sounds M.empty
@@ -72,7 +75,6 @@ updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
 
 updateParticles' :: World -> World
 updateParticles' w = 
-    --set particles' [] w
     set particles' (catMaybes ps) w'
   where 
     (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
@@ -107,7 +109,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

src/Loop.hs

@@ -1,4 +1,4 @@
-{-|
+{- |
 Module      : Loop
 Description : Minimal game loop
 
@@ -7,14 +7,14 @@ This module sets up an SDL window which may be updated using a simple game loop.
 module Loop
     ( setupLoop
     ) where
-import SDL
 import qualified Data.Text as T
 import Control.Concurrent
 import Control.Exception
-import qualified Graphics.Rendering.OpenGL as GL
 import Control.Monad
 import System.Mem
 import Foreign.C
+import SDL
+import qualified Graphics.Rendering.OpenGL as GL
 
 import Control.Lens ((.~),(&),(+~))
 

src/Preload.hs

@@ -6,15 +6,18 @@ module Preload
   where
 import Preload.Data
 import Preload.Update
-
 import Picture.Preload
 import Sound.Data
-import Control.Lens
 
+import Control.Lens
 import GHC.Word (Word32)
+import qualified SDL.Mixer as Mix
 
 
 cleanUpPreload :: PreloadData a -> IO ()
 cleanUpPreload pd = do
     cleanUpRenderPreload $ _renderData pd
     cleanUpSoundPreload $ _soundData pd
+
+cleanUpSoundPreload :: SoundData a -> IO ()
+cleanUpSoundPreload sd = Mix.closeAudio

src/Sound.hs

@@ -14,6 +14,9 @@ module Sound (
     , playPositionalSoundQueue
     -- * Complex Playback
     , playAndUpdate
+    -- * Volume Control
+    , setSoundVolume
+    , setMusicVolume
     ) where
 import Sound.Data
 
@@ -32,17 +35,18 @@ then sounds in the merged Map are updated.
 The Map of updated sound specifications is returned.
 
 New sounds with the same keys as 
-already playing sounds are merged in the following manner:
+already playing sounds are merged as follows:
 
-    * the '_soundChannel' is set to the old value
+    * '_soundChannel' is set to the old value
-    * if the old '_soundStatus' was 'FadingOut', it is replaced with the new status (allowing playback to be restarted using 'ToStart')
+    * if the old '_soundStatus' was 'FadingOut', it set to the new value (can restart playback with 'ToStart')
-    * all other fields are set to the new value.
+    * other fields are set to the new value.
 
 In the update: 
     
-    1. sounds with a value 'ToStart' commence playing
+    1. commence playing sounds with 'ToStart' status
-    2. timers are decremented and any fading status is set
+    2. decrement timers, set any fading status
-    3. sounds that have stopped playing are removed from the map.
+    3. apply 'Just' sound position effects, set value to 'Nothing'
+    4. remove sounds that have stopped playing from the map.
  -}
 playAndUpdate :: Ord a => SoundData a -> M.Map a Sound -> IO (M.Map a Sound)
 playAndUpdate sData newSounds 
@@ -148,3 +152,18 @@ setChannelPos :: Int16 -> Mix.Channel -> MaybeT IO Mix.Channel
 setChannelPos a i = do
     liftIO $ Mix.effectPosition i a 0 
     return i
+
+
+-----------------------------------------------------------------
+{- | Set the volume for all sound channels.
+Behind the scenes, scales a float [0,1] to an Int [0..128].
+ -}
+setSoundVolume :: Float -> IO ()
+setSoundVolume x = Mix.setVolume (round (x * 128)) Mix.AllChannels
+
+{- | Set the music volume.
+Behind the scenes, scales a float [0,1] to an Int [0..128].
+ -}
+setMusicVolume :: Float -> IO ()
+setMusicVolume x = Mix.setMusicVolume (round (x * 128))
+

src/Sound/Data.hs

@@ -32,5 +32,3 @@ data Sound = Sound
 makeLenses ''SoundData
 makeLenses ''Sound
 
-cleanUpSoundPreload :: SoundData a -> IO ()
-cleanUpSoundPreload sd = Mix.closeAudio