From 89a6eec561ddb66b59edc6452487cd77f168e091 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 7 Apr 2021 18:26:16 +0200 Subject: [PATCH 1/9] Commit before merge --- src/Dodge/SoundLogic.hs | 2 +- src/Sound.hs | 15 ++++++++------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index f6069cf7c..427c54c42 100644 --- a/src/Dodge/SoundLogic.hs +++ b/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)) diff --git a/src/Sound.hs b/src/Sound.hs index d22d67254..1e23ac03a 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -32,17 +32,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 - * if the old '_soundStatus' was 'FadingOut', it is replaced with the new status (allowing playback to be restarted using 'ToStart') - * all other fields are set to the new value. + * '_soundChannel' is set to the old value + * if the old '_soundStatus' was 'FadingOut', it set to the new value (can restart playback with 'ToStart') + * other fields are set to the new value. In the update: - 1. sounds with a value 'ToStart' commence playing - 2. timers are decremented and any fading status is set - 3. sounds that have stopped playing are removed from the map. + 1. commence playing sounds with 'ToStart' status + 2. decrement timers, set any fading status + 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 From d42cb89dd2e41bff00e6a9c9144cd5f3c1126c82 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 7 Apr 2021 18:52:51 +0200 Subject: [PATCH 2/9] Turn on debug mode by default --- app/Main.hs | 14 +++++--------- src/Dodge/Default.hs | 2 +- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 8f6c67879..e76dc8e07 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -22,18 +22,14 @@ import Preload import Sound.Data import Music -import Control.Concurrent -import Control.Lens -import Foreign (Word32) - +import Control.Concurrent +import Control.Lens +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, - translate) +import qualified Data.IntMap as IM +import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) import qualified SDL import qualified SDL.Mixer as Mix diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index b597e786a..e500485ea 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -234,7 +234,7 @@ defaultWorld = World , _keyConfig = defaultKeyConfigSDL , _varMovementSpeedModifier = 3 , _varMovementStrafeSpeedModifier = 3 - , _debugMode = False + , _debugMode = True } youLight = -- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) From 294f2509d0fac89efd305b6593ba272176e6956f Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 7 Apr 2021 21:59:44 +0200 Subject: [PATCH 3/9] 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)) + From ddb1171e2ebd0cd71a484ad5d8b9adfc243cc395 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 8 Apr 2021 00:44:02 +0200 Subject: [PATCH 4/9] Refactor menu --- src/Dodge/Data.hs | 13 +++++-------- src/Dodge/Data/Menu.hs | 11 +++++++++++ src/Dodge/Default.hs | 15 ++++++++------- src/Dodge/Event.hs | 4 ++-- src/Dodge/Event/Keyboard.hs | 23 +++++++++++++++-------- src/Dodge/Event/Menu.hs | 17 +++++++++-------- src/Dodge/LoadConfig.hs | 27 ++++++++++++++++----------- src/Dodge/Render/MenuScreen.hs | 6 ++++-- src/Loop.hs | 6 +++--- 9 files changed, 73 insertions(+), 49 deletions(-) create mode 100644 src/Dodge/Data/Menu.hs diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 7cb91d76d..ddc3277c0 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -3,11 +3,14 @@ {-# LANGUAGE StrictData #-} module Dodge.Data ( module Dodge.Data + , module Dodge.Data.Menu , Point2 (..) , Sound (..) , soundTime ) where +import Dodge.Data.Menu + import Picture.Data import Geometry.Data import Sound.Data @@ -78,7 +81,8 @@ data World = World , _keyConfig :: KeyConfigSDL , _varMovementSpeedModifier :: Float , _varMovementStrafeSpeedModifier :: Float - , _debugMode :: Bool + , _debugMode :: Bool + , _config :: Configuration } data Corpse = Corpse @@ -242,13 +246,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 diff --git a/src/Dodge/Data/Menu.hs b/src/Dodge/Data/Menu.hs new file mode 100644 index 000000000..61abc4719 --- /dev/null +++ b/src/Dodge/Data/Menu.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE StrictData #-} +module Dodge.Data.Menu + where +data MenuState + = LevelMenu Int + | PauseMenu + | GameOverMenu + | OptionMenu + | InGame + deriving (Eq,Ord) + diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index a8a50d63c..2f5131423 100644 --- a/src/Dodge/Default.hs +++ b/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 @@ -235,6 +235,7 @@ defaultWorld = World , _varMovementSpeedModifier = 3 , _varMovementStrafeSpeedModifier = 3 , _debugMode = True + , _config = defaultConfig } youLight = TLS { _tlsPos = (0,0) diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 5f8b09b11..811f9835e 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -1,16 +1,16 @@ -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. +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 diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 302c3f66b..61900fc61 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -1,3 +1,6 @@ +{- | +Deals with keyboard events. +-} module Dodge.Event.Keyboard ( handleKeyboardEvent ) @@ -21,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 @@ -40,9 +48,8 @@ handlePressedKeyInGame scode 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 == 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 @@ -57,10 +64,10 @@ handlePressedKey _ _ w = Just w debugKey :: Scancode -> World -> Maybe World debugKey scancode w - | scancode == ScancodeF7 = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w - 1} - | scancode == ScancodeF8 = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w + 1} - | scancode == ScancodeF5 = Just $ dropLight w - | scancode == ScancodeF6 = Just $ dropLight' w + | scancode == ScancodeF7 = Just $ w & varMovementSpeedModifier -~ 1 + | scancode == ScancodeF8 = Just $ w & varMovementSpeedModifier +~ 1 + | scancode == ScancodeF5 = Just $ dropLight w + | scancode == ScancodeF6 = Just $ dropLight' w debugKey _ w = Just w @@ -78,7 +85,7 @@ 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 diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 12d68a103..7b8dc3acc 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -18,20 +18,21 @@ import SDL handlePressedKeyInMenu :: MenuState -> Scancode -> World -> Maybe World handlePressedKeyInMenu mState scode w = case mState of LevelMenu _ -> case scode of - ScancodeEscape -> Nothing + ScancodeEscape -> Nothing _ -> startLevel w PauseMenu -> case scode of - ScancodeEscape -> Nothing - ScancodeR -> return $ fromMaybe w $ _storedLevel w - ScancodeN -> Just $ putSound $ generateLevel 1 + ScancodeEscape -> Nothing + ScancodeR -> return $ fromMaybe w $ _storedLevel w + ScancodeN -> Just $ putSound $ generateLevel 1 $ initialWorld {_randGen = _randGen w} - _ -> unpause w + _ -> unpause w GameOverMenu -> case scode of - ScancodeEscape -> Nothing - ScancodeR -> Just $ fromMaybe w $ _storedLevel w - ScancodeN -> Just $ putSound $ generateLevel 1 + ScancodeEscape -> Nothing + ScancodeR -> Just $ fromMaybe w $ _storedLevel w + ScancodeN -> Just $ putSound $ generateLevel 1 $ initialWorld {_randGen = _randGen w} + _ -> Just w _ -> Just w where unpause w' = Just . resumeSound $ diff --git a/src/Dodge/LoadConfig.hs b/src/Dodge/LoadConfig.hs index 16daa9bcd..6b6126859 100644 --- a/src/Dodge/LoadConfig.hs +++ b/src/Dodge/LoadConfig.hs @@ -1,7 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} module Dodge.LoadConfig - ( module Dodge.LoadConfig.KeyConfig + ( + Configuration (..) + , loadDodgeConfig + , defaultConfig + , module Dodge.LoadConfig.KeyConfig ) where import Dodge.LoadConfig.KeyConfig @@ -13,9 +18,9 @@ import qualified SDL import System.Directory data Configuration = Configuration - { volume_master :: Int - , volume_sound :: Int - , volume_music :: Int + { volume_master :: Float + , volume_sound :: Float + , volume_music :: Float } deriving (Generic, Show) @@ -24,18 +29,18 @@ instance ToJSON Configuration where instance FromJSON Configuration -loadConfig :: IO Configuration -loadConfig = do +loadDodgeConfig :: IO Configuration +loadDodgeConfig = 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 + return defaultConfig -defaultConfiguration = Configuration - { volume_master = 128 - , volume_sound = 128 - , volume_music = 128 +defaultConfig = Configuration + { volume_master = 1 + , volume_sound = 1 + , volume_music = 1 } diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index b27ea3a43..95435a1c2 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -16,16 +16,18 @@ menuScreen w = case _menuState w of ,controlsList ] PauseMenu -> pictures - [--color (withAlpha 0.5 black) $ polygon $ screenBox w - tst (-100) 100 0.4 "PAUSED" + [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 "PAUSED" ,tst (-100) 50 0.2 "n - new level" ,tst (-100) 0 0.2 "r - restart" + ,tst (-100) (-50) 0.2 "o - options" , controlsList ] GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w ,tst (-100) 100 0.4 "GAME OVER" ,tst (-100) 50 0.2 "n - new level" ,tst (-100) 0 0.2 "r - restart" + ,tst (-100) (-50) 0.2 "o - options" ,controlsList ] where tst x y sc t = translate x y $ scale sc sc $ color white $ text t diff --git a/src/Loop.hs b/src/Loop.hs index b202638ef..3c5dcd519 100644 --- a/src/Loop.hs +++ b/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 ((.~),(&),(+~)) From f1214c058477a48eafdcd90ed9bcbd7963145c46 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 8 Apr 2021 02:48:25 +0200 Subject: [PATCH 5/9] Improve configuration handling --- app/Main.hs | 2 ++ src/Dodge/Base.hs | 2 +- src/Dodge/Config/Update.hs | 22 ++++++++++++ src/Dodge/Data.hs | 5 +-- src/Dodge/Data/Menu.hs | 4 +-- src/Dodge/Default.hs | 3 +- src/Dodge/Event.hs | 4 +-- src/Dodge/Event/Keyboard.hs | 7 ++-- src/Dodge/Event/Menu.hs | 23 ++++++++++--- src/Dodge/Initialisation.hs | 2 +- src/Dodge/LoadConfig.hs | 19 +++++++---- src/Dodge/Render/MenuScreen.hs | 62 +++++++++++++++++++++------------- src/Dodge/Render/Picture.hs | 2 +- src/Dodge/Update.hs | 15 ++++---- 14 files changed, 118 insertions(+), 54 deletions(-) create mode 100644 src/Dodge/Config/Update.hs diff --git a/app/Main.hs b/app/Main.hs index e7237e107..c9a6ca059 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,6 +9,7 @@ import Dodge.Update import Dodge.Event import Dodge.Render import Dodge.LoadConfig +import Dodge.Config.Update import Dodge.LoadSound import Picture import Picture.Render @@ -55,6 +56,7 @@ main = do (fmap (setWindowSize sizex sizey keyConfig) firstWorld) ( \preData w -> do startTicks <- SDL.ticks + updateDodgeConfig w void $ doDrawing (_renderData preData) w playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w) newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 0c0380c44..d72a1a4b2 100644 --- a/src/Dodge/Base.hs +++ b/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. -} diff --git a/src/Dodge/Config/Update.hs b/src/Dodge/Config/Update.hs new file mode 100644 index 000000000..ca70e8517 --- /dev/null +++ b/src/Dodge/Config/Update.hs @@ -0,0 +1,22 @@ +{-| +IO actions that apply config side effects and save it to disk. +-} +module Dodge.Config.Update + where +import Dodge.Data +import Dodge.LoadConfig +import Sound + +import Data.Aeson (encodeFile) +import Control.Monad (when) + +updateDodgeConfig :: World -> IO () +updateDodgeConfig w = case _menuLayers w of + (ConfigSaveScreen _: _) -> do + putStrLn "Saving config" + encodeFile "data/dodge.config.json" cfig + _ -> when (_configNeedsUpdate w) $ do + setSoundVolume ( _volume_master cfig * _volume_sound cfig) + setMusicVolume ( _volume_master cfig * _volume_music cfig) + where + cfig = _config w diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index ddc3277c0..85b8f0e59 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -65,7 +65,7 @@ data World = World , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) , _pathInc :: ~(M.Map Point2 [Point2]) , _storedLevel :: Maybe World - , _menuState :: MenuState + , _menuLayers :: [MenuLayer] , _worldState :: M.Map WorldState Bool , _windowX :: !Float , _windowY :: !Float @@ -83,6 +83,7 @@ data World = World , _varMovementStrafeSpeedModifier :: Float , _debugMode :: Bool , _config :: Configuration + , _configNeedsUpdate :: Bool } data Corpse = Corpse @@ -100,7 +101,7 @@ data Layer | FlItLayer | LabelLayer | InvLayer - | MenuLayer + | MenuDepth | PressPlateLayer | CorpseLayer | UPtLayer diff --git a/src/Dodge/Data/Menu.hs b/src/Dodge/Data/Menu.hs index 61abc4719..b72710854 100644 --- a/src/Dodge/Data/Menu.hs +++ b/src/Dodge/Data/Menu.hs @@ -1,11 +1,11 @@ {-# LANGUAGE StrictData #-} module Dodge.Data.Menu where -data MenuState +data MenuLayer = LevelMenu Int | PauseMenu | GameOverMenu | OptionMenu - | InGame + | ConfigSaveScreen Int deriving (Eq,Ord) diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 2f5131423..0abd1fc67 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -210,7 +210,7 @@ defaultWorld = World , _corpses = IM.empty , _decorations = IM.empty , _storedLevel = Nothing - , _menuState = LevelMenu 1 + , _menuLayers = [LevelMenu 1] , _worldState = M.empty , _clickMousePos = (0,0) , _pathGraph = Data.Graph.Inductive.Graph.empty @@ -236,6 +236,7 @@ defaultWorld = World , _varMovementStrafeSpeedModifier = 3 , _debugMode = True , _config = defaultConfig + , _configNeedsUpdate = False } youLight = TLS { _tlsPos = (0,0) diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 811f9835e..b780d9757 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -57,8 +57,8 @@ handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of where but = mouseButtonEventButton mbev handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World -handleMouseWheelEvent mwev w = case _menuState w of - InGame -> case mouseWheelEventPos mwev of +handleMouseWheelEvent mwev w = case _menuLayers w of + [] -> case mouseWheelEventPos mwev of V2 x y | y > 0 -> Just (wheelUpEvent w) | y < 0 -> Just (wheelDownEvent w) | otherwise -> Just w diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 61900fc61..03c83163c 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -57,9 +57,9 @@ handlePressedKeyInGame _ w = Just w handlePressedKey :: Bool -> Scancode -> World -> Maybe World handlePressedKey True _ w = Just w handlePressedKey _ scode w - | _menuState w == InGame + | _menuLayers w == [] = handlePressedKeyInGame scode w - | otherwise = handlePressedKeyInMenu (_menuState w) scode w + | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w handlePressedKey _ _ w = Just w debugKey :: Scancode -> World -> Maybe World @@ -70,7 +70,6 @@ debugKey scancode w | scancode == ScancodeF6 = Just $ dropLight' w debugKey _ w = Just w - spaceAction :: World -> World spaceAction w = case listToMaybe $ _closeActiveObjects w of Just (Left flit) -> pickUpItem' flit w @@ -78,7 +77,7 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of Nothing -> w pauseGame :: World -> World -pauseGame w = w {_menuState = PauseMenu} +pauseGame w = w {_menuLayers = [PauseMenu]} toggleMap w = w & carteDisplay %~ not escapeMap w = w & carteDisplay .~ False diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 7b8dc3acc..64a7a6de2 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -7,24 +7,25 @@ import Dodge.Rooms import Dodge.Floor import Dodge.Initialisation import Dodge.SoundLogic +import Dodge.LoadConfig import Data.Maybe import qualified Data.Set as S - import Control.Lens - import SDL -handlePressedKeyInMenu :: MenuState -> Scancode -> World -> Maybe World +handlePressedKeyInMenu :: MenuLayer -> Scancode -> World -> Maybe World handlePressedKeyInMenu mState scode w = case mState of LevelMenu _ -> case scode of ScancodeEscape -> Nothing + ScancodeO -> goToOptionMenu w _ -> startLevel w PauseMenu -> case scode of ScancodeEscape -> Nothing ScancodeR -> return $ fromMaybe w $ _storedLevel w ScancodeN -> Just $ putSound $ generateLevel 1 $ initialWorld {_randGen = _randGen w} + ScancodeO -> goToOptionMenu w _ -> unpause w GameOverMenu -> case scode of ScancodeEscape -> Nothing @@ -32,13 +33,27 @@ handlePressedKeyInMenu mState scode w = case mState of ScancodeN -> Just $ putSound $ generateLevel 1 $ initialWorld {_randGen = _randGen w} + ScancodeO -> goToOptionMenu w _ -> Just w + OptionMenu -> case scode of + ScancodeY -> Just $ w & config . volume_master %~ dec + ScancodeU -> Just $ w & config . volume_master %~ inc + ScancodeH -> Just $ w & config . volume_sound %~ dec + ScancodeJ -> Just $ w & config . volume_sound %~ inc + ScancodeN -> Just $ w & config . volume_music %~ dec + ScancodeM -> Just $ w & config . volume_music %~ inc + _ -> Just $ w & menuLayers %~ (ConfigSaveScreen 1:) . tail + & configNeedsUpdate .~ False _ -> Just w where unpause w' = Just . resumeSound $ - w' {_menuState = InGame} + w' {_menuLayers = []} startLevel = unpause . storeLevel putSound = id -- set loadedSounds (_loadedSounds w) + dec x = max 0 (x - 0.1) + inc x = min 1 (x + 0.1) + goToOptionMenu w = Just $ w & menuLayers %~ (OptionMenu :) + & configNeedsUpdate .~ True storeLevel :: World -> World storeLevel w = case _storedLevel w of diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 6fd6f79bc..e90ef110b 100644 --- a/src/Dodge/Initialisation.hs +++ b/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 diff --git a/src/Dodge/LoadConfig.hs b/src/Dodge/LoadConfig.hs index 6b6126859..1dcb4584d 100644 --- a/src/Dodge/LoadConfig.hs +++ b/src/Dodge/LoadConfig.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -6,6 +7,9 @@ module Dodge.LoadConfig Configuration (..) , loadDodgeConfig , defaultConfig + , volume_master + , volume_sound + , volume_music , module Dodge.LoadConfig.KeyConfig ) where import Dodge.LoadConfig.KeyConfig @@ -16,14 +20,17 @@ import GHC.Generics import qualified GHC.Int import qualified SDL import System.Directory +import Control.Lens data Configuration = Configuration - { volume_master :: Float - , volume_sound :: Float - , volume_music :: Float + { _volume_master :: Float + , _volume_sound :: Float + , _volume_music :: Float } deriving (Generic, Show) +makeLenses ''Configuration + instance ToJSON Configuration where toEncoding = genericToEncoding defaultOptions @@ -39,8 +46,8 @@ loadDodgeConfig = do return defaultConfig defaultConfig = Configuration - { volume_master = 1 - , volume_sound = 1 - , volume_music = 1 + { _volume_master = 1 + , _volume_sound = 1 + , _volume_music = 1 } diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 95435a1c2..3eaff5990 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -3,34 +3,50 @@ module Dodge.Render.MenuScreen ) where import Dodge.Data +import Dodge.LoadConfig import Dodge.Base (halfWidth,halfHeight) import Picture menuScreen :: World -> Picture -menuScreen w = case _menuState w of - InGame -> blank - LevelMenu x -> - pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w - tst (-100) 100 0.4 ("LEVEL "++show x) - ,controlsList - ] - PauseMenu -> pictures - [color (withAlpha 0.5 black) $ polygon $ screenBox w - ,tst (-100) 100 0.4 "PAUSED" - ,tst (-100) 50 0.2 "n - new level" - ,tst (-100) 0 0.2 "r - restart" - ,tst (-100) (-50) 0.2 "o - options" - , controlsList - ] - GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w - ,tst (-100) 100 0.4 "GAME OVER" - ,tst (-100) 50 0.2 "n - new level" - ,tst (-100) 0 0.2 "r - restart" - ,tst (-100) (-50) 0.2 "o - options" - ,controlsList - ] - where tst x y sc t = translate x y $ scale sc sc $ color white $ text t +menuScreen w = case _menuLayers w of + [] -> blank + (LevelMenu x:_) -> pictures + [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 ("LEVEL "++show x) + ,controlsList + ] + (PauseMenu:_) -> pictures + [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 "PAUSED" + ,tst (-100) 50 0.2 "n - new level" + ,tst (-100) 0 0.2 "r - restart" + ,tst (-100) (-50) 0.2 "o - options" + , controlsList + ] + (GameOverMenu:_) -> pictures + [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 "GAME OVER" + ,tst (-100) 50 0.2 "n - new level" + ,tst (-100) 0 0.2 "r - restart" + ,tst (-100) (-50) 0.2 "o - options" + ,controlsList + ] + (OptionMenu : _) -> pictures + [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 "OPTIONS" + ,tst (-180) 50 0.2 $ "y - master volume + u : " ++ mavol + ,tst (-180) 0 0.2 $ "h - sound volume + j : " ++ snvol + ,tst (-180) (-50) 0.2 $ "n - music volume + m : " ++ muvol + ,controlsList + ] + _ -> blank + where + tst x y sc t = translate x y $ scale sc sc $ color white $ text t + mavol = f $ _volume_master $ _config w + snvol = f $ _volume_sound $ _config w + muvol = f $ _volume_music $ _config w + f x = show $ round $ 10 * x controlsList = pictures [tst (-250) (-130) 0.15 "controls:" ,tst (-150) (-130) 0.15 "wasd" diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index a1f400d96..3f95003db 100644 --- a/src/Dodge/Render/Picture.hs +++ b/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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 2d4741a8a..493d65233 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -23,14 +23,15 @@ import qualified Data.IntMap.Strict as IM import qualified Data.Map as M import Control.Lens {- | The update step. -If the '_menuState' is not 'InGame', this is the identity. -This means that the only way to change the world is using event handling. +If '_menuLayers' is not empty, or the saving screen, this is the identity. +In such menus, the only way to change the world is using event handling. -} update :: World -> World -update w - | _menuState w /= InGame = w - | otherwise = - let w1 = updateParticles' . updateProjectiles +update w = case _menuLayers w of + (ConfigSaveScreen x: ls) -> w & menuLayers .~ (ConfigSaveScreen (x-1) : ls) + (ConfigSaveScreen 0: ls) -> w & menuLayers .~ ls + (_ : _) -> w + [] -> let w1 = updateParticles' . updateProjectiles . updateLightSources . zoneClouds . updateClouds @@ -101,7 +102,7 @@ setTestStringIO = fmap (\ w -> set testString (show $ s w) w) where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos) checkEndGame :: World -> World -checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuState = GameOverMenu} +checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]} | otherwise = w updateClouds :: World -> World From ea0dfbe1df0b63e89d32916d7c575a37aedce688 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 8 Apr 2021 11:06:02 +0200 Subject: [PATCH 6/9] Add (persistent) volume control --- app/Main.hs | 10 ++++--- src/Dodge/Config/Data.hs | 39 +++++++++++++++++++++++++++ src/Dodge/Config/Update.hs | 17 +++++++----- src/Dodge/Data.hs | 3 ++- src/Dodge/Data/Menu.hs | 2 +- src/Dodge/Event/Menu.hs | 2 +- src/Dodge/LoadConfig.hs | 54 +++++++++++--------------------------- src/Dodge/Update.hs | 3 +-- 8 files changed, 76 insertions(+), 54 deletions(-) create mode 100644 src/Dodge/Config/Data.hs diff --git a/app/Main.hs b/app/Main.hs index c9a6ca059..74cdf0f16 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -30,13 +30,14 @@ import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) import qualified SDL import qualified SDL.Mixer as Mix -doPreload' :: IO (PreloadData a) -doPreload' = do +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 @@ -49,11 +50,12 @@ main :: IO () main = do (sizex,sizey) <- loadConfig keyConfig <- loadKeyConfig + dodgeConfig <- loadDodgeConfig setupLoop (sizex,sizey) - (SDL.cursorVisible $= False >> doPreload' >>= resizeSpareFBO sizex sizey) + (SDL.cursorVisible $= False >> doPreload' dodgeConfig >>= resizeSpareFBO sizex sizey) (\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x) - (fmap (setWindowSize sizex sizey keyConfig) firstWorld) + (fmap (setWindowSize sizex sizey keyConfig . (config .~ dodgeConfig)) firstWorld) ( \preData w -> do startTicks <- SDL.ticks updateDodgeConfig w diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs new file mode 100644 index 000000000..be509d4b2 --- /dev/null +++ b/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 + } + diff --git a/src/Dodge/Config/Update.hs b/src/Dodge/Config/Update.hs index ca70e8517..1a61d6818 100644 --- a/src/Dodge/Config/Update.hs +++ b/src/Dodge/Config/Update.hs @@ -1,10 +1,10 @@ {-| -IO actions that apply config side effects and save it to disk. +IO actions that apply config side effects and save configuration settings to disk. -} module Dodge.Config.Update where import Dodge.Data -import Dodge.LoadConfig +import Dodge.Config.Data import Sound import Data.Aeson (encodeFile) @@ -12,11 +12,14 @@ import Control.Monad (when) updateDodgeConfig :: World -> IO () updateDodgeConfig w = case _menuLayers w of - (ConfigSaveScreen _: _) -> do - putStrLn "Saving config" + (ConfigSaveScreen : _) -> do + putStrLn "Saving config to data/dodge.config.json" encodeFile "data/dodge.config.json" cfig - _ -> when (_configNeedsUpdate w) $ do - setSoundVolume ( _volume_master cfig * _volume_sound cfig) - setMusicVolume ( _volume_master cfig * _volume_music 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) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 85b8f0e59..bb619fe40 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -26,7 +26,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) diff --git a/src/Dodge/Data/Menu.hs b/src/Dodge/Data/Menu.hs index b72710854..fdaf85252 100644 --- a/src/Dodge/Data/Menu.hs +++ b/src/Dodge/Data/Menu.hs @@ -6,6 +6,6 @@ data MenuLayer | PauseMenu | GameOverMenu | OptionMenu - | ConfigSaveScreen Int + | ConfigSaveScreen deriving (Eq,Ord) diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 64a7a6de2..2b348b655 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -42,7 +42,7 @@ handlePressedKeyInMenu mState scode w = case mState of ScancodeJ -> Just $ w & config . volume_sound %~ inc ScancodeN -> Just $ w & config . volume_music %~ dec ScancodeM -> Just $ w & config . volume_music %~ inc - _ -> Just $ w & menuLayers %~ (ConfigSaveScreen 1:) . tail + _ -> Just $ w & menuLayers %~ ([ConfigSaveScreen , ConfigSaveScreen] ++) . tail & configNeedsUpdate .~ False _ -> Just w where diff --git a/src/Dodge/LoadConfig.hs b/src/Dodge/LoadConfig.hs index 1dcb4584d..efb8bc2ec 100644 --- a/src/Dodge/LoadConfig.hs +++ b/src/Dodge/LoadConfig.hs @@ -4,50 +4,28 @@ {-# LANGUAGE StrictData #-} module Dodge.LoadConfig ( - Configuration (..) - , loadDodgeConfig - , defaultConfig - , volume_master - , volume_sound - , volume_music + loadDodgeConfig , module Dodge.LoadConfig.KeyConfig + , module Dodge.Config.Data ) where import Dodge.LoadConfig.KeyConfig +import Dodge.Config.Data +import Dodge.Config.Update 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 loadDodgeConfig :: IO Configuration loadDodgeConfig = 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 defaultConfig - -defaultConfig = Configuration - { _volume_master = 1 - , _volume_sound = 1 - , _volume_music = 1 - } - + fExists <- doesFileExist "data/dodge.config.json" + if fExists + then do + mayConfig <- decodeFileStrict "data/dodge.config.json" + case mayConfig of + Just config -> setVolume config >> return config + Nothing -> do + putStrLn "invalid data/dodge.config.json, loading default config" + return defaultConfig + else do + putStrLn "No data/data/dodge.config.json found, loading defaults" + return defaultConfig diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 493d65233..42f46186d 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -28,8 +28,7 @@ In such menus, the only way to change the world is using event handling. -} update :: World -> World update w = case _menuLayers w of - (ConfigSaveScreen x: ls) -> w & menuLayers .~ (ConfigSaveScreen (x-1) : ls) - (ConfigSaveScreen 0: ls) -> w & menuLayers .~ ls + (ConfigSaveScreen : ls) -> w & menuLayers .~ ls (_ : _) -> w [] -> let w1 = updateParticles' . updateProjectiles . updateLightSources From 28c1f3d23b10475857c456ca16cbd6d925c51e96 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 8 Apr 2021 11:18:10 +0200 Subject: [PATCH 7/9] Cleanup --- app/Main.hs | 66 +++++++++++++++++++++++------------------------ src/Preload.hs | 7 +++-- src/Sound/Data.hs | 2 -- 3 files changed, 38 insertions(+), 37 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 74cdf0f16..c75aff5ed 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -30,6 +30,39 @@ import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) import qualified SDL import qualified SDL.Mixer as Mix +main :: IO () +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) + ) + return $ preData & soundData . playingSounds .~ newPlayingSounds + & frameTimer .~ endTicks + doPreload' :: Dodge.LoadConfig.Configuration -> IO (PreloadData a) doPreload' config = do lChunks <- loadSounds @@ -46,39 +79,6 @@ doPreload' config = do , _frameTimer = 0 } -main :: IO () -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) - ( \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) - ) - - - return $ preData & soundData . playingSounds .~ newPlayingSounds - & frameTimer .~ endTicks - ) - handleEvent - (Just . update) - Mix.closeAudio checkForGlErrors :: IO () checkForGlErrors = do diff --git a/src/Preload.hs b/src/Preload.hs index e642f3e64..e43222568 100644 --- a/src/Preload.hs +++ b/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 diff --git a/src/Sound/Data.hs b/src/Sound/Data.hs index 758a0cc7b..dbc415a31 100644 --- a/src/Sound/Data.hs +++ b/src/Sound/Data.hs @@ -32,5 +32,3 @@ data Sound = Sound makeLenses ''SoundData makeLenses ''Sound -cleanUpSoundPreload :: SoundData a -> IO () -cleanUpSoundPreload sd = Mix.closeAudio From 7969c3f9e829b39d0263d88eaf21b46eac1bbe59 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 8 Apr 2021 12:34:10 +0200 Subject: [PATCH 8/9] Put controls on separate menu screen --- src/Dodge/Data/Menu.hs | 1 + src/Dodge/Event/Menu.hs | 5 ++++ src/Dodge/Render/MenuScreen.hs | 52 ++++++++++++++++++++-------------- 3 files changed, 36 insertions(+), 22 deletions(-) diff --git a/src/Dodge/Data/Menu.hs b/src/Dodge/Data/Menu.hs index fdaf85252..f24747294 100644 --- a/src/Dodge/Data/Menu.hs +++ b/src/Dodge/Data/Menu.hs @@ -7,5 +7,6 @@ data MenuLayer | GameOverMenu | OptionMenu | ConfigSaveScreen + | ControlList deriving (Eq,Ord) diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 2b348b655..881336b45 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -19,6 +19,7 @@ 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 @@ -26,6 +27,7 @@ handlePressedKeyInMenu mState scode w = case mState of ScancodeN -> Just $ putSound $ generateLevel 1 $ initialWorld {_randGen = _randGen w} ScancodeO -> goToOptionMenu w + ScancodeC -> goToControls w _ -> unpause w GameOverMenu -> case scode of ScancodeEscape -> Nothing @@ -34,6 +36,7 @@ handlePressedKeyInMenu mState scode w = case mState of $ initialWorld {_randGen = _randGen w} ScancodeO -> goToOptionMenu w + ScancodeC -> goToControls w _ -> Just w OptionMenu -> case scode of ScancodeY -> Just $ w & config . volume_master %~ dec @@ -44,6 +47,7 @@ handlePressedKeyInMenu mState scode w = case mState of 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 $ @@ -54,6 +58,7 @@ handlePressedKeyInMenu mState scode w = case mState of 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 diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 3eaff5990..aa3803dba 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -14,7 +14,6 @@ menuScreen w = case _menuLayers w of (LevelMenu x:_) -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w ,tst (-100) 100 0.4 ("LEVEL "++show x) - ,controlsList ] (PauseMenu:_) -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w @@ -22,7 +21,7 @@ menuScreen w = case _menuLayers w of ,tst (-100) 50 0.2 "n - new level" ,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 @@ -30,7 +29,7 @@ menuScreen w = case _menuLayers w of ,tst (-100) 50 0.2 "n - new level" ,tst (-100) 0 0.2 "r - restart" ,tst (-100) (-50) 0.2 "o - options" - ,controlsList + ,tst (-100) (-100) 0.2 "c - controls" ] (OptionMenu : _) -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w @@ -38,8 +37,19 @@ menuScreen w = case _menuLayers w of ,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 @@ -48,25 +58,23 @@ menuScreen w = case _menuLayers w of muvol = f $ _volume_music $ _config w f x = show $ round $ 10 * x -controlsList = pictures [tst (-250) (-130) 0.15 "controls:" - ,tst (-150) (-130) 0.15 "wasd" - ,tst 0 (-130) 0.15 "movement" - ,tst (-150) (-160) 0.15 "[rmb]" - ,tst 0 (-160) 0.15 "aim" - ,tst (-150) (-190) 0.15 "[rmb+lmb]" - ,tst 0 (-190) 0.15 "shoot or use item" - ,tst (-150) (-220) 0.15 "[wheelscroll]" - ,tst 0 (-220) 0.15 "select item" - ,tst (-150) (-250) 0.15 "[space]" - ,tst 0 (-250) 0.15 "pickup item" - ,tst (-150) (-280) 0.15 "f" - ,tst 0 (-280) 0.15 "drop item" - ,tst (-150) (-310) 0.15 "cp[esc]" - ,tst 0 (-310) 0.15 "pause" - ,tst (-150) (-340) 0.15 "qe[lmb]" - ,tst 0 (-340) 0.15 "rotate camera" - ] - where tst x y sc t = translate x y $ scale sc sc $ color white $ text t +controlsList = pictures $ concat $ zipWith butAndEff + [("wasd", "movement") + ,("[rmb]", "aim") + ,("[rmb+lmb]", "shoot or use item") + ,("[wheelscroll]" , "select item" ) + ,("[space]" , "pickup item" ) + ,("m" , "display map" ) + ,("f" , "drop item" ) + ,("c[esc]" , "pause" ) + ,("qe" , "rotate camera") + ] + [60,30..] + where + butAndEff (btext,etext) y = + [translate (-250) y $ scale 0.15 0.15 $ color white $ text btext + ,translate 0 y $ scale 0.15 0.15 $ color white $ text etext + ] screenBox w = [ (halfWidth w, halfHeight w) , (-halfWidth w, halfHeight w) From feec924d5dcc27da4db7b8e561a50fa33e6960d4 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 8 Apr 2021 13:21:40 +0200 Subject: [PATCH 9/9] Allow for real time window resize --- app/Main.hs | 5 ++--- src/Dodge/Data.hs | 3 +++ src/Dodge/Default.hs | 2 ++ src/Dodge/Event.hs | 11 ++++++++--- src/Dodge/Update.hs | 12 ++++++++++-- 5 files changed, 25 insertions(+), 8 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c75aff5ed..76b8a9c68 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -60,8 +60,8 @@ doSideEffects preData w = do . translate (-0.5) (-0.8) . scale 0.0005 0.0005 . text $ "ms/frame " ++ show (endTicks - lastFrameTicks) ) - return $ preData & soundData . playingSounds .~ newPlayingSounds - & frameTimer .~ endTicks + foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds + & frameTimer .~ endTicks)) (_doneSideEffects w) doPreload' :: Dodge.LoadConfig.Configuration -> IO (PreloadData a) doPreload' config = do @@ -79,7 +79,6 @@ doPreload' config = do , _frameTimer = 0 } - checkForGlErrors :: IO () checkForGlErrors = do errs <- errors diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index bb619fe40..7723de9cc 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -10,6 +10,7 @@ module Dodge.Data ) where import Dodge.Data.Menu +import Preload.Data import Picture.Data import Geometry.Data @@ -85,6 +86,8 @@ data World = World , _debugMode :: Bool , _config :: Configuration , _configNeedsUpdate :: Bool + , _sideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)] + , _doneSideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)] } data Corpse = Corpse diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 0abd1fc67..3de64d618 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -237,6 +237,8 @@ defaultWorld = World , _debugMode = True , _config = defaultConfig , _configNeedsUpdate = False + , _sideEffects = [] + , _doneSideEffects = [] } youLight = TLS { _tlsPos = (0,0) diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index b780d9757..05004587e 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -21,6 +21,8 @@ import Dodge.CreatureAction import Dodge.SoundLogic import Dodge.Inventory import Geometry +import Preload.Update + import Control.Lens import Data.Maybe import Data.Char @@ -65,9 +67,12 @@ handleMouseWheelEvent mwev w = case _menuLayers w of _ -> Just w handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World -handleResizeEvent sev = Just . set windowX (fromIntegral x) - . set windowY (fromIntegral y) - where V2 x y = windowSizeChangedEventSize sev +handleResizeEvent sev = Just + . set windowX (fromIntegral x) + . 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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 42f46186d..667575b42 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -22,12 +22,20 @@ 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 + {- | The update step. If '_menuLayers' is not empty, or the saving screen, this is the identity. In such menus, the only way to change the world is using event handling. -} -update :: World -> World -update w = case _menuLayers w of +update' :: World -> World +update' w = case _menuLayers w of (ConfigSaveScreen : ls) -> w & menuLayers .~ ls (_ : _) -> w [] -> let w1 = updateParticles' . updateProjectiles