Refactor event handling. Allow mouse movement in menus

app/Main.hs

@@ -5,13 +5,9 @@ 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.LoadSound
 import Picture
@@ -76,7 +72,7 @@ main = do
             return $ preData & soundData . playingSounds .~ newPlayingSounds
                              & frameTimer .~ endTicks
         )
-        (flip $ menuEvents handleEvent)
+        handleEvent
         (Just . update)
     Mix.closeAudio
 

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

@@ -237,7 +237,6 @@ defaultWorld = World
     , _debugMode = True
     }
 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,6 +1,20 @@
-module Dodge.Event where
+module Dodge.Event 
-import Dodge.Event.Keyboard
+{- |
+Module      : Dodge.Event
+Description : Direct event handling
 
+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
+"Dodge.Update".
+-}
+    ( handleEvent
+    ) where
+import Dodge.Event.Keyboard
+import Dodge.Event.Menu
 import Dodge.Data
 import Dodge.Base
 import Dodge.CreatureAction
@@ -15,16 +29,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,11 +57,12 @@ handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of
     where but = mouseButtonEventButton mbev
 
 handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World
-handleMouseWheelEvent mwev = 
+handleMouseWheelEvent mwev w = case _menuState w of
-    case mouseWheelEventPos mwev of
+   InGame -> 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)
@@ -113,12 +124,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

@@ -12,6 +12,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
@@ -30,25 +31,28 @@ 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
+    -- Rotation seems to be duplicated here and in Camera.hs ? why
+    |  scode == rotateCameraPlusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w + 0.01}
+    |  scode == rotateCameraMinusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w - 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
+    | _menuState w == InGame 
-    |  scancode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w
+                = handlePressedKeyInGame scode w
-    |  scancode == dropItemKey (_keyConfig w) = Just $ dropItem w
+    | otherwise = handlePressedKeyInMenu (_menuState 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 
@@ -59,6 +63,7 @@ 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
@@ -90,4 +95,4 @@ dropLight w = placeLS ls dec pos 0
 dropLight' :: World -> World
 dropLight' w = placeCr lamp pos 0 w
         where
-            pos = _crPos(you w)
+            pos = _crPos(you w)

src/Dodge/Event/Menu.hs

@@ -0,0 +1,45 @@
+module Dodge.Event.Menu
+    ( handlePressedKeyInMenu
+    )
+    where
+import Dodge.Data
+import Dodge.Rooms
+import Dodge.Floor
+import Dodge.Initialisation
+import Dodge.SoundLogic
+
+import Data.Maybe
+import qualified Data.Set as S
+
+import Control.Lens
+
+import SDL
+
+handlePressedKeyInMenu :: MenuState -> Scancode -> World -> Maybe World
+handlePressedKeyInMenu mState scode w = case mState of
+    LevelMenu _ -> case scode of
+            ScancodeEscape -> Nothing
+            _               -> startLevel w
+    PauseMenu   -> case scode of
+            ScancodeEscape -> Nothing
+            ScancodeR      -> return $ fromMaybe w $ _storedLevel w
+            ScancodeN      -> Just $ putSound $ generateLevel 1 
+                                      $ initialWorld {_randGen = _randGen w}
+            _              -> unpause w
+    GameOverMenu -> case scode of
+            ScancodeEscape -> Nothing
+            ScancodeR      -> Just $ fromMaybe w $ _storedLevel w
+            ScancodeN      -> Just $ putSound $ generateLevel 1 
+                                                       $ initialWorld
+                                                           {_randGen = _randGen w}
+    _ -> Just w
+  where 
+    unpause w' = Just . resumeSound $
+                        w' {_menuState = InGame}
+    startLevel = unpause . storeLevel
+    putSound = id -- set loadedSounds (_loadedSounds w)
+
+storeLevel :: World -> World
+storeLevel w = case _storedLevel w of
+                 Nothing -> w & storedLevel ?~ w
+                 _       -> w

src/Dodge/LoadConfig.hs

@@ -1,152 +1,41 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Dodge.LoadConfig
-  where
+    ( module Dodge.LoadConfig.KeyConfig
+    ) where
+import Dodge.LoadConfig.KeyConfig
+
 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
+data Configuration = Configuration
-  { moveUpBinding :: Int,
+  { volume_master   :: Int
-    moveDownBinding :: Int,
+  , volume_sound    :: Int
-    moveLeftBinding :: Int,
+  , volume_music    :: 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
+instance ToJSON Configuration where
-  { 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
+instance FromJSON Configuration
-  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
+loadConfig :: IO Configuration
-loadKeyConfig = do
+loadConfig = do
-    fExists <- doesFileExist "keys.json"
+  mayConfig <- decodeFileStrict "data/dodge.config.json"
-    if fExists
+  case mayConfig of
-    then do
+    Just config -> return config
-        mayConfig <- decodeFileStrict "keys.json"
+    Nothing -> do
-        print mayConfig
+      putStrLn "invalid data/dodge.config.json, loading default config"
-        case mayConfig of
+      return defaultConfiguration
-          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
+defaultConfiguration = Configuration
-getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode
+    { volume_master = 128
+    , volume_sound  = 128
+    , volume_music  = 128
+    }
+ 

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/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,12 +21,11 @@ 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
-
+{- | The update step.
-
+If the '_menuState' is not 'InGame', this is the identity.
--- }}}
+This means that the only way to change the world is using event handling.
-
+ -}
 update :: World -> World
 update w 
     | _menuState w /= InGame = w
@@ -35,7 +38,6 @@ update w
                                       . updateBlocks -- . zoning 
                                       . updateSeenWalls 
                                       . updateSoundQueue
---                                      . updateUsingInput
                                       $ updateCloseObjects w
             in  checkEndGame . ppEvents 
                              . updateCamera
@@ -45,22 +47,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 +67,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

src/Sound.hs

@@ -14,6 +14,9 @@ module Sound (
     , playPositionalSoundQueue
     -- * Complex Playback
     , playAndUpdate
+    -- * Volume Control
+    , setSoundVolume
+    , setMusicVolume
     ) where
 import Sound.Data
 
@@ -149,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))
+