justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Improve configuration handling

Browse Source
This commit is contained in:
jgk
2021-04-08 02:48:25 +02:00
parent ddb1171e2e
commit f1214c0584
14 changed files with 118 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+2
View File
@@ -9,6 +9,7 @@ import Dodge.Update
import Dodge.Event
import Dodge.Render
import Dodge.LoadConfig
import Dodge.Config.Update
import Dodge.LoadSound
import Picture
import Picture.Render
@@ -55,6 +56,7 @@ main = do
(fmap (setWindowSize sizex sizey keyConfig) firstWorld)
( \preData w -> do
startTicks <- SDL.ticks
updateDodgeConfig w
void $ doDrawing (_renderData preData) w
playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
src/Dodge/Base.hs
+1 -1
View File
@@ -770,7 +770,7 @@ levLayer HPtLayer = 73
levLayer ShadowLayer = 75
levLayer LabelLayer = 80
levLayer InvLayer = 85
levLayer MenuLayer = 90
levLayer MenuDepth = 90
{- | Transform coordinates from world position to normalised screen coordinates.
-}
src/Dodge/Config/Update.hs
+22
View File
@@ -0,0 +1,22 @@
{-|
IO actions that apply config side effects and save it to disk.
-}
module Dodge.Config.Update
where
import Dodge.Data
import Dodge.LoadConfig
import Sound
import Data.Aeson (encodeFile)
import Control.Monad (when)
updateDodgeConfig :: World -> IO ()
updateDodgeConfig w = case _menuLayers w of
(ConfigSaveScreen _: _) -> do
putStrLn "Saving config"
encodeFile "data/dodge.config.json" cfig
_ -> when (_configNeedsUpdate w) $ do
setSoundVolume ( _volume_master cfig * _volume_sound cfig)
setMusicVolume ( _volume_master cfig * _volume_music cfig)
where
cfig = _config w
src/Dodge/Data.hs
+3 -2
View File
@@ -65,7 +65,7 @@ data World = World
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
, _pathInc :: ~(M.Map Point2 [Point2])
, _storedLevel :: Maybe World
, _menuState :: MenuState
, _menuLayers :: [MenuLayer]
, _worldState :: M.Map WorldState Bool
, _windowX :: !Float
, _windowY :: !Float
@@ -83,6 +83,7 @@ data World = World
, _varMovementStrafeSpeedModifier :: Float
, _debugMode :: Bool
, _config :: Configuration
, _configNeedsUpdate :: Bool
}
data Corpse = Corpse
@@ -100,7 +101,7 @@ data Layer
| FlItLayer
| LabelLayer
| InvLayer
| MenuLayer
| MenuDepth
| PressPlateLayer
| CorpseLayer
| UPtLayer
src/Dodge/Data/Menu.hs
+2 -2
View File
@@ -1,11 +1,11 @@
{-# LANGUAGE StrictData #-}
module Dodge.Data.Menu
where
data MenuState
data MenuLayer
= LevelMenu Int
| PauseMenu
| GameOverMenu
| OptionMenu
| InGame
| ConfigSaveScreen Int
deriving (Eq,Ord)
src/Dodge/Default.hs
+2 -1
View File
@@ -210,7 +210,7 @@ defaultWorld = World
, _corpses = IM.empty
, _decorations = IM.empty
, _storedLevel = Nothing
, _menuState = LevelMenu 1
, _menuLayers = [LevelMenu 1]
, _worldState = M.empty
, _clickMousePos = (0,0)
, _pathGraph = Data.Graph.Inductive.Graph.empty
@@ -236,6 +236,7 @@ defaultWorld = World
, _varMovementStrafeSpeedModifier = 3
, _debugMode = True
, _config = defaultConfig
, _configNeedsUpdate = False
}
youLight =
TLS { _tlsPos = (0,0)
src/Dodge/Event.hs
+2 -2
View File
@@ -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
src/Dodge/Event/Keyboard.hs
+3 -4
View File
@@ -57,9 +57,9 @@ handlePressedKeyInGame _ w = Just w
handlePressedKey :: Bool -> Scancode -> World -> Maybe World
handlePressedKey True _ w = Just w
handlePressedKey _ scode w
| _menuState w == InGame
| _menuLayers w == []
= handlePressedKeyInGame scode w
| otherwise = handlePressedKeyInMenu (_menuState w) scode w
| otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w
handlePressedKey _ _ w = Just w
debugKey :: Scancode -> World -> Maybe World
@@ -70,7 +70,6 @@ debugKey scancode w
| scancode == ScancodeF6 = Just $ dropLight' w
debugKey _ w = Just w
spaceAction :: World -> World
spaceAction w = case listToMaybe $ _closeActiveObjects w of
Just (Left flit) -> pickUpItem' flit w
@@ -78,7 +77,7 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of
Nothing -> w
pauseGame :: World -> World
pauseGame w = w {_menuState = PauseMenu}
pauseGame w = w {_menuLayers = [PauseMenu]}
toggleMap w = w & carteDisplay %~ not
escapeMap w = w & carteDisplay .~ False
src/Dodge/Event/Menu.hs
+19 -4
View File
@@ -7,24 +7,25 @@ import Dodge.Rooms
import Dodge.Floor
import Dodge.Initialisation
import Dodge.SoundLogic
import Dodge.LoadConfig
import Data.Maybe
import qualified Data.Set as S
import Control.Lens
import SDL
handlePressedKeyInMenu :: MenuState -> Scancode -> World -> Maybe World
handlePressedKeyInMenu :: MenuLayer -> Scancode -> World -> Maybe World
handlePressedKeyInMenu mState scode w = case mState of
LevelMenu _ -> case scode of
ScancodeEscape -> Nothing
ScancodeO -> goToOptionMenu w
_ -> startLevel w
PauseMenu -> case scode of
ScancodeEscape -> Nothing
ScancodeR -> return $ fromMaybe w $ _storedLevel w
ScancodeN -> Just $ putSound $ generateLevel 1
$ initialWorld {_randGen = _randGen w}
ScancodeO -> goToOptionMenu w
_ -> unpause w
GameOverMenu -> case scode of
ScancodeEscape -> Nothing
@@ -32,13 +33,27 @@ handlePressedKeyInMenu mState scode w = case mState of
ScancodeN -> Just $ putSound $ generateLevel 1
$ initialWorld
{_randGen = _randGen w}
ScancodeO -> goToOptionMenu w
_ -> Just w
OptionMenu -> case scode of
ScancodeY -> Just $ w & config . volume_master %~ dec
ScancodeU -> Just $ w & config . volume_master %~ inc
ScancodeH -> Just $ w & config . volume_sound %~ dec
ScancodeJ -> Just $ w & config . volume_sound %~ inc
ScancodeN -> Just $ w & config . volume_music %~ dec
ScancodeM -> Just $ w & config . volume_music %~ inc
_ -> Just $ w & menuLayers %~ (ConfigSaveScreen 1:) . tail
& configNeedsUpdate .~ False
_ -> Just w
where
unpause w' = Just . resumeSound $
w' {_menuState = InGame}
w' {_menuLayers = []}
startLevel = unpause . storeLevel
putSound = id -- set loadedSounds (_loadedSounds w)
dec x = max 0 (x - 0.1)
inc x = min 1 (x + 0.1)
goToOptionMenu w = Just $ w & menuLayers %~ (OptionMenu :)
& configNeedsUpdate .~ True
storeLevel :: World -> World
storeLevel w = case _storedLevel w of
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -47,7 +47,7 @@ initialWorld = defaultWorld
, _sounds = M.empty
, _decorations = IM.empty
, _storedLevel = Nothing
, _menuState = LevelMenu 1
, _menuLayers = [LevelMenu 1]
, _worldState = M.empty
, _windowX = 800
, _windowY = 600
src/Dodge/LoadConfig.hs
+13 -6
View File
@@ -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
}
src/Dodge/Render/MenuScreen.hs
+39 -23
View File
@@ -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"
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -29,7 +29,7 @@ worldPictures w = pictures $ concat
fixedCoordPictures :: World -> Picture
fixedCoordPictures w = pictures
[ hudDrawings w
, scaler . onLayer MenuLayer $ menuScreen w
, scaler . onLayer MenuDepth $ menuScreen w
, customMouseCursor w
]
where
src/Dodge/Update.hs
+8 -7
View File
@@ -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