From 294f2509d0fac89efd305b6593ba272176e6956f Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 7 Apr 2021 21:59:44 +0200 Subject: [PATCH] Refactor event handling. Allow mouse movement in menus --- app/Main.hs | 6 +- src/Dodge/AIs.hs | 2 - src/Dodge/Creature/YourControl.hs | 10 +- src/Dodge/Default.hs | 1 - src/Dodge/Event.hs | 52 +++++----- src/Dodge/Event/Keyboard.hs | 41 ++++---- src/Dodge/Event/Menu.hs | 45 +++++++++ src/Dodge/LoadConfig.hs | 159 +++++------------------------- src/Dodge/LoadConfig/KeyConfig.hs | 152 ++++++++++++++++++++++++++++ src/Dodge/Menu.hs | 104 ------------------- src/Dodge/Update.hs | 46 ++++----- src/Sound.hs | 18 ++++ 12 files changed, 319 insertions(+), 317 deletions(-) create mode 100644 src/Dodge/Event/Menu.hs create mode 100644 src/Dodge/LoadConfig/KeyConfig.hs delete mode 100644 src/Dodge/Menu.hs diff --git a/app/Main.hs b/app/Main.hs index e76dc8e07..e7237e107 100644 --- a/app/Main.hs +++ b/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 diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs index 0824f1058..258b07a6a 100644 --- a/src/Dodge/AIs.hs +++ b/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 diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index ba1d34616..9b2284c3c 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/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 + diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index e500485ea..a8a50d63c 100644 --- a/src/Dodge/Default.hs +++ b/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 diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 993a2dada..5f8b09b11 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -1,6 +1,20 @@ -module Dodge.Event where -import Dodge.Event.Keyboard +module Dodge.Event +{- | +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 e = case eventPayload e of +handleEvent :: World -> Event -> Maybe World +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 = - case mouseWheelEventPos mwev of - V2 x y | y > 0 -> Just . wheelUpEvent - | y < 0 -> Just . wheelDownEvent - | otherwise -> Just +handleMouseWheelEvent mwev w = case _menuState w of + InGame -> case mouseWheelEventPos mwev of + V2 x y | y > 0 -> Just (wheelUpEvent w) + | y < 0 -> Just (wheelDownEvent w) + | 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 - diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 63455b5b3..302c3f66b 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/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 - | scancode == escapeKey (_keyConfig w) = Nothing - | scancode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w - | scancode == dropItemKey (_keyConfig w) = Just $ dropItem 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 _ scode w + | _menuState w == InGame + = handlePressedKeyInGame scode w + | otherwise = handlePressedKeyInMenu (_menuState w) scode 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) \ No newline at end of file + pos = _crPos(you w) diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs new file mode 100644 index 000000000..12d68a103 --- /dev/null +++ b/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 diff --git a/src/Dodge/LoadConfig.hs b/src/Dodge/LoadConfig.hs index e4b61a7a8..16daa9bcd 100644 --- a/src/Dodge/LoadConfig.hs +++ b/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 - { 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 +data Configuration = Configuration + { volume_master :: Int + , volume_sound :: Int + , volume_music :: 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 +instance ToJSON Configuration 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 - } +instance FromJSON Configuration -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 +loadConfig :: IO Configuration +loadConfig = do + mayConfig <- decodeFileStrict "data/dodge.config.json" + case mayConfig of + Just config -> return config + Nothing -> do + putStrLn "invalid data/dodge.config.json, loading default config" + return defaultConfiguration -getSdlScancode :: Int -> SDL.Scancode -getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode +defaultConfiguration = Configuration + { volume_master = 128 + , volume_sound = 128 + , volume_music = 128 + } + diff --git a/src/Dodge/LoadConfig/KeyConfig.hs b/src/Dodge/LoadConfig/KeyConfig.hs new file mode 100644 index 000000000..f2596b19b --- /dev/null +++ b/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 diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs deleted file mode 100644 index 7bc784a3b..000000000 --- a/src/Dodge/Menu.hs +++ /dev/null @@ -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 - diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 4faa832be..2d4741a8a 100644 --- a/src/Dodge/Update.hs +++ b/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)) - -- w - -- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize - -- = insertIMInZone x y wlid wl - -- | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips - -- where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1)) - -- wlid = _wlID wl - -- ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1) - zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w)) - 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 + where + zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w)) + 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 diff --git a/src/Sound.hs b/src/Sound.hs index 1e23ac03a..29d981c1f 100644 --- a/src/Sound.hs +++ b/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)) +