Move universe IO effects outside of world
This commit is contained in:
+3
-3
@@ -82,6 +82,7 @@ firstWorldLoad theConfig = do
|
||||
,_menuLayers = []
|
||||
,_savedWorlds = M.empty
|
||||
,_keyConfig = theKeyConfig
|
||||
, _uvIOEffects = return
|
||||
, _uvTestString = testStringInit
|
||||
}
|
||||
|
||||
@@ -103,10 +104,9 @@ playSoundUnlessRewinding u
|
||||
|
||||
doSideEffects :: Universe -> IO Universe
|
||||
doSideEffects u = do
|
||||
let w = _uvWorld u
|
||||
let preData = _preloadData u
|
||||
newPlayingSounds <- playSoundUnlessRewinding u
|
||||
u' <- _sideEffects w u
|
||||
u' <- _uvIOEffects u u
|
||||
endTicks <- SDL.ticks
|
||||
let lastFrameTicks = _frameTimer preData
|
||||
when (debugOn Show_ms_frame $ _uvConfig u) $ void $ renderFoldable
|
||||
@@ -119,7 +119,7 @@ doSideEffects u = do
|
||||
& preloadData . frameTimer .~ endTicks
|
||||
& uvWorld . playingSounds .~ newPlayingSounds
|
||||
& uvWorld . toPlaySounds .~ M.empty
|
||||
& uvWorld . sideEffects .~ return
|
||||
& uvIOEffects .~ return
|
||||
|
||||
fpsText :: (Show a, Ord a, Num a) => a -> Picture
|
||||
fpsText x = color col $ text $ "ms/frame " ++ show x
|
||||
|
||||
@@ -5,6 +5,7 @@ module Dodge.Config.Update
|
||||
( saveConfig
|
||||
, setVolThen
|
||||
, applyWorldConfig
|
||||
, setVol
|
||||
) where
|
||||
--import Dodge.Data.SoundOrigin
|
||||
import Dodge.Config.Data
|
||||
|
||||
+1
-1
@@ -169,6 +169,7 @@ data Universe = Universe
|
||||
, _menuLayers :: [ScreenLayer]
|
||||
, _savedWorlds :: M.Map SaveSlot World
|
||||
, _keyConfig :: KeyConfigSDL
|
||||
, _uvIOEffects :: Universe -> IO Universe
|
||||
, _uvConfig :: Configuration
|
||||
, _uvTestString :: Universe -> [String]
|
||||
}
|
||||
@@ -244,7 +245,6 @@ data World = World
|
||||
, _rbOptions :: RightButtonOptions
|
||||
, _seenLocations :: IM.IntMap (WdP2,String)
|
||||
, _selLocation :: Int
|
||||
, _sideEffects :: Universe -> IO Universe
|
||||
, _distortions :: [Distortion]
|
||||
, _worldBounds :: Bounds
|
||||
, _gameRooms :: [GameRoom] -- consider using an IntMap
|
||||
|
||||
@@ -93,9 +93,6 @@ defaultWorld = World
|
||||
,(1, (WdP2Const (V2 0 0) , "START POSITION"))
|
||||
]
|
||||
, _selLocation = 0
|
||||
--, _keyConfig = defaultKeyConfigSDL
|
||||
-- , _config = defaultConfig
|
||||
, _sideEffects = return
|
||||
, _foregroundShapes = mempty
|
||||
, _distortions = []
|
||||
, _gameRooms = []
|
||||
|
||||
+1
-1
@@ -74,7 +74,7 @@ handleResizeEvent :: WindowSizeChangedEventData -> Universe -> IO (Maybe Univers
|
||||
handleResizeEvent sev u = return . Just $ u
|
||||
& uvConfig . windowX .~ fromIntegral x
|
||||
& uvConfig . windowY .~ fromIntegral y
|
||||
& uvWorld . sideEffects %~ sideEffectUpdatePreload divRes x y
|
||||
& uvIOEffects %~ sideEffectUpdatePreload divRes x y
|
||||
where
|
||||
x = fromIntegral x'
|
||||
y = fromIntegral y'
|
||||
|
||||
+18
-16
@@ -79,22 +79,24 @@ handlePressedKey _ scode u = case scode of
|
||||
_ | null (_menuLayers u) -> case u ^? uvWorld . hud . hudElement . subInventory of
|
||||
Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u)
|
||||
-> return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u
|
||||
_ -> return $ uvWorld (Just . handlePressedKeyInGame scode) u
|
||||
_ -> return $ (Just . handlePressedKeyInGame scode) u
|
||||
_ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u
|
||||
|
||||
handlePressedKeyInGame :: Scancode -> World -> World
|
||||
handlePressedKeyInGame scode w = case scode of
|
||||
ScancodeEscape -> pauseGame $ escapeMap w
|
||||
ScancodeSpace -> spaceAction w
|
||||
ScancodeP -> pauseGame $ escapeMap w
|
||||
ScancodeF -> youDropItem w
|
||||
ScancodeM -> toggleMap w
|
||||
ScancodeR -> crToggleReloading (you w) w
|
||||
ScancodeT -> testEvent w
|
||||
ScancodeX -> w & hud . hudElement %~ toggleTweakInv
|
||||
ScancodeC -> toggleCombineInv w
|
||||
ScancodeI -> w & hud . hudElement %~ toggleInspectInv
|
||||
_ -> w
|
||||
handlePressedKeyInGame :: Scancode -> Universe -> Universe
|
||||
handlePressedKeyInGame scode uv = case scode of
|
||||
ScancodeEscape -> pauseGame $ over uvWorld escapeMap uv
|
||||
ScancodeSpace -> over uvWorld spaceAction uv
|
||||
ScancodeP -> pauseGame $ over uvWorld escapeMap uv
|
||||
ScancodeF -> over uvWorld youDropItem uv
|
||||
ScancodeM -> over uvWorld toggleMap uv
|
||||
ScancodeR -> over uvWorld (crToggleReloading (you w)) uv
|
||||
ScancodeT -> over uvWorld testEvent uv
|
||||
ScancodeX -> uv & uvWorld . hud . hudElement %~ toggleTweakInv
|
||||
ScancodeC -> over uvWorld toggleCombineInv uv
|
||||
ScancodeI -> uv & uvWorld . hud . hudElement %~ toggleInspectInv
|
||||
_ -> uv
|
||||
where
|
||||
w = _uvWorld uv
|
||||
|
||||
|
||||
handlePressedKeyTerminal :: Int -> Scancode -> World -> World
|
||||
@@ -138,8 +140,8 @@ spaceAction w = case _hudElement $ _hud w of
|
||||
theLoc = doWorldPos (fst (_seenLocations w IM.! _selLocation w)) w
|
||||
-- updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail
|
||||
|
||||
pauseGame :: World -> World
|
||||
pauseGame w = w & sideEffects %~ (. (menuLayers .~ [pauseMenu]))
|
||||
pauseGame :: Universe -> Universe
|
||||
pauseGame = menuLayers .~ [pauseMenu]
|
||||
|
||||
toggleMap :: World -> World
|
||||
toggleMap w = case _hudElement $ _hud w of
|
||||
|
||||
@@ -27,7 +27,6 @@ initialWorld = defaultWorld
|
||||
, _randGen = mkStdGen 2
|
||||
, _mousePos = V2 0 0
|
||||
, _yourID = 0
|
||||
, _sideEffects = return
|
||||
, _worldEvents = SoundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing
|
||||
: [MakeStartCloudAt (V3 x y 5) | x <- [-5,-4..5] , y <- [-5,-4..5]]
|
||||
, _pressPlates = IM.empty
|
||||
|
||||
@@ -3,15 +3,11 @@
|
||||
module Dodge.LevelGen where
|
||||
import Dodge.Data
|
||||
import Dodge.Floor
|
||||
import Dodge.Save
|
||||
import Dodge.Layout
|
||||
import Dodge.Initialisation
|
||||
--import Dodge.RandomHelp
|
||||
--import Dodge.LevelGen.Data
|
||||
import Dodge.Tree
|
||||
import Geometry.ConvexPoly
|
||||
import Dodge.Combine.Graph
|
||||
--import Dodge.LevelGen.LevelStructure
|
||||
|
||||
import Data.Foldable
|
||||
import System.Directory
|
||||
@@ -30,7 +26,7 @@ generateWorldFromSeed i = do
|
||||
writeFile "log/aGeneratedRoomLayout" ""
|
||||
generateGraphs
|
||||
(roomList,bounds) <- layoutLevelFromSeed 0 i
|
||||
return $ saveLevelStartSlot
|
||||
return -- $ saveLevelStartSlot
|
||||
$ postGenerationProcessing
|
||||
$ generateLevelFromRoomList roomList initialWorld{_randGen=mkStdGen i}
|
||||
& roomClipping .~ bounds
|
||||
|
||||
+3
-3
@@ -134,13 +134,13 @@ soundMenuOptions =
|
||||
scod2
|
||||
(change inc stype)
|
||||
(\w -> Right (str , leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w)::Int)))
|
||||
change g vt = return . Just . (uvConfig . vt %~ g) . sw
|
||||
change g vt uv = sw uv >> return (Just $ uv & uvConfig . vt %~ g)
|
||||
dec x = max 0 (x - 0.1)
|
||||
inc x = min 1 (x + 0.1)
|
||||
sw w = w & uvWorld . sideEffects %~ setVolThen (_uvConfig w)
|
||||
sw w = setVol (_uvConfig w)
|
||||
|
||||
writeConfig :: Universe -> Universe
|
||||
writeConfig w = w & uvWorld . sideEffects %~ saveConfig (_uvConfig w)
|
||||
writeConfig w = w & uvIOEffects %~ saveConfig (_uvConfig w)
|
||||
|
||||
graphicsMenu :: ScreenLayer
|
||||
graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions
|
||||
|
||||
+2
-2
@@ -30,7 +30,7 @@ doQuicksave = saveWorldInSlot QuicksaveSlot
|
||||
clearKeys :: World -> World
|
||||
clearKeys = (keys .~ mempty) . (mouseButtons .~ mempty)
|
||||
|
||||
saveLevelStartSlot :: World -> World
|
||||
saveLevelStartSlot :: Universe -> Universe
|
||||
--saveLevelStartSlot = id
|
||||
saveLevelStartSlot = sideEffects %~ (fmap (saveWorldInSlot LevelStartSlot) . )
|
||||
saveLevelStartSlot = saveWorldInSlot LevelStartSlot
|
||||
--saveLevelStartSlot = sideEffects %~ (fmap (undefined) . )
|
||||
|
||||
@@ -12,7 +12,7 @@ startNewGame u = startSeedGame i u
|
||||
startSeedGame :: Int -> Universe -> Universe
|
||||
startSeedGame i u = u
|
||||
& menuLayers .~ [WaitScreen (const "GENERATING...") 1]
|
||||
& uvWorld . sideEffects .~ \_ -> do
|
||||
& uvIOEffects .~ \_ -> do
|
||||
w <- generateWorldFromSeed i
|
||||
return $ u & menuLayers .~ [] & uvWorld .~ w
|
||||
& savedWorlds . at LevelStartSlot ?~ w
|
||||
|
||||
+10
-8
@@ -62,7 +62,7 @@ updateUniverse u = case _menuLayers u of
|
||||
|
||||
{- | The update step. -}
|
||||
functionalUpdate :: Universe -> Universe
|
||||
functionalUpdate w = over uvWorld checkEndGame
|
||||
functionalUpdate w = checkEndGame
|
||||
-- . updateRandGen
|
||||
. over uvWorld (mouseButtons . each .~ True) -- to determine if the mouse button is held
|
||||
. over uvWorld (worldClock +~ 1)
|
||||
@@ -364,13 +364,15 @@ markWallSeen !w !i = w { _walls = IM.adjust markSeen i $ _walls w }
|
||||
markSeen :: Wall -> Wall
|
||||
markSeen wl = wl {_wlSeen = True}
|
||||
|
||||
checkEndGame :: World -> World
|
||||
checkEndGame w = case _deathDelay w of
|
||||
Just x | x < 0 -> w & sideEffects %~ ( . (menuLayers .~ [gameOverMenu]))
|
||||
& deathDelay .~ Nothing
|
||||
Just _ -> w & deathDelay . _Just -~ 1
|
||||
_ | _crHP (you w) < 1 -> w & deathDelay ?~ 50
|
||||
_ -> w
|
||||
checkEndGame :: Universe -> Universe
|
||||
checkEndGame uv = case _deathDelay w of
|
||||
Just x | x < 0 -> uv & menuLayers .~ [gameOverMenu]
|
||||
& uvWorld . deathDelay .~ Nothing
|
||||
Just _ -> uv & uvWorld . deathDelay . _Just -~ 1
|
||||
_ | _crHP (you w) < 1 -> uv & uvWorld . deathDelay ?~ 50
|
||||
_ -> uv
|
||||
where
|
||||
w = _uvWorld uv
|
||||
|
||||
updateGusts :: World -> World
|
||||
updateGusts w = w
|
||||
|
||||
Reference in New Issue
Block a user