Move universe IO effects outside of world

appDodge/Main.hs

@@ -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

src/Dodge/Config/Update.hs

@@ -5,6 +5,7 @@ module Dodge.Config.Update
     ( saveConfig
     , setVolThen
     , applyWorldConfig
+    , setVol
     ) where
 --import Dodge.Data.SoundOrigin
 import Dodge.Config.Data

src/Dodge/Data.hs

@@ -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

src/Dodge/Default/World.hs

@@ -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 = []

src/Dodge/Event.hs

@@ -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'

src/Dodge/Event/Keyboard.hs

@@ -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 :: Scancode -> Universe -> Universe
-handlePressedKeyInGame scode w = case scode of
+handlePressedKeyInGame scode uv = case scode of
-    ScancodeEscape  -> pauseGame $ escapeMap w
+    ScancodeEscape  -> pauseGame $ over uvWorld escapeMap uv
-    ScancodeSpace   -> spaceAction w
+    ScancodeSpace   -> over uvWorld spaceAction uv
-    ScancodeP       -> pauseGame $ escapeMap w
+    ScancodeP       -> pauseGame $ over uvWorld escapeMap uv
-    ScancodeF       -> youDropItem w
+    ScancodeF       -> over uvWorld youDropItem uv
-    ScancodeM       -> toggleMap w
+    ScancodeM       -> over uvWorld toggleMap uv
-    ScancodeR       -> crToggleReloading (you w) w
+    ScancodeR       -> over uvWorld (crToggleReloading (you w)) uv
-    ScancodeT       -> testEvent w
+    ScancodeT       -> over uvWorld testEvent uv
-    ScancodeX       -> w & hud . hudElement %~ toggleTweakInv
+    ScancodeX       -> uv & uvWorld . hud . hudElement %~ toggleTweakInv
-    ScancodeC       -> toggleCombineInv w
+    ScancodeC       -> over uvWorld toggleCombineInv uv
-    ScancodeI       -> w & hud . hudElement %~ toggleInspectInv
+    ScancodeI       -> uv & uvWorld . hud . hudElement %~ toggleInspectInv
-    _               -> w
+    _               -> 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 :: Universe -> Universe
-pauseGame w = w & sideEffects %~ (. (menuLayers .~ [pauseMenu]))
+pauseGame = menuLayers .~ [pauseMenu]
 
 toggleMap :: World -> World
 toggleMap w = case _hudElement $ _hud w of

src/Dodge/Initialisation.hs

@@ -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

src/Dodge/LevelGen.hs

@@ -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

src/Dodge/Menu.hs

@@ -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

src/Dodge/Save.hs

@@ -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) . )

src/Dodge/StartNewGame.hs

@@ -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

src/Dodge/Update.hs

@@ -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 :: Universe -> Universe
-checkEndGame w = case _deathDelay w of
+checkEndGame uv = case _deathDelay w of
-    Just x | x < 0 -> w & sideEffects %~ ( . (menuLayers .~ [gameOverMenu]))
+    Just x | x < 0 -> uv & menuLayers .~ [gameOverMenu]
-        & deathDelay .~ Nothing
+        & uvWorld . deathDelay .~ Nothing
-    Just _ -> w & deathDelay . _Just -~ 1
+    Just _ -> uv & uvWorld . deathDelay . _Just -~ 1
-    _ | _crHP (you w) < 1 -> w & deathDelay ?~ 50
+    _ | _crHP (you w) < 1 -> uv & uvWorld . deathDelay ?~ 50
-    _ -> w
+    _ -> uv
+  where
+    w = _uvWorld uv
 
 updateGusts :: World -> World
 updateGusts w = w