Work on saving/loading concurrently

appDodge/Main.hs

@@ -1,10 +1,11 @@
 module Main 
     ( main 
     ) where
+import Dodge.Menu
 import Loop
 import Dodge.TestString
 import Dodge.Data
-import Dodge.StartNewGame
+--import Dodge.StartNewGame
 import Dodge.Initialisation
 import Dodge.Concurrent
 --import Dodge.LevelGen
@@ -47,7 +48,7 @@ main = do
         (winConfig sizex sizey (Just (posx,posy)))
         theCleanup
         (firstWorldLoad con)
-        conTest
+        conEffects
         theUpdateStep
         (flip handleEvent)
 
@@ -74,16 +75,17 @@ firstWorldLoad :: Configuration -> IO Universe
 firstWorldLoad theConfig = do
     SDL.cursorVisible $= False
     pdata <- doPreload >>= applyWorldConfig theConfig
-    return $ startNewGame $ Universe 
+    --return $ startNewGame $ Universe 
-        {_uvWorld = initialWorld
+    return $ Universe 
+        --{_uvWorld = initialWorld
+        {_uvWorld = splashScreen
         ,_uvConfig    = theConfig
         ,_preloadData = pdata
-        ,_menuLayers = []
+        ,_uvScreenLayers = [splashMenu]
         , _uvIOEffects  = return
         , _uvTestString = testStringInit
-        , _uvConcMessage = ""
         , _quickSave = Nothing
-        , _uvConcEffects = Nothing
+        , _uvConcEffects = NoConcEffect
         }
 
 theUpdateStep :: Universe -> IO Universe

src/Dodge/Concurrent.hs

@@ -2,9 +2,24 @@ module Dodge.Concurrent where
 
 import Dodge.Data.Universe
 --import qualified Data.Set as S
---import Control.Lens
+import Control.Lens
 --import Control.Concurrent
 --import SDL.Input.Keyboard.Codes
 
-conTest :: Universe -> Maybe (IO (Universe -> Universe))
+conEffects :: Universe -> Maybe (Universe -> Universe,IO (Universe -> Maybe Universe))
-conTest = _uvConcEffects
+conEffects u = case u ^. uvConcEffects of
+    NewConcEffect {_ceFunction = eff} -> Just eff
+    _ -> Nothing
+
+tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
+tryConcEffect bl str eff u = case u ^. uvConcEffects of
+    NoConcEffect -> u & uvConcEffects .~ NewConcEffect (setstr, clearConcEff eff) str bl
+    _ -> u
+  where
+    setstr | bl = uvConcEffects .~ BlockingConcEffect str
+        | otherwise = uvConcEffects .~ BackgroundConcEffect str
+
+clearConcEff :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe)
+clearConcEff eff = do
+    f <- eff
+    return (f . (uvConcEffects .~ NoConcEffect))

src/Dodge/Data/Universe.hs

@@ -21,17 +21,21 @@ import SDL (Scancode)
 data Universe = Universe
     { _uvWorld :: World
     , _preloadData :: PreloadData
-    , _menuLayers :: [ScreenLayer]
+    , _uvScreenLayers :: [ScreenLayer]
     , _quickSave :: Maybe World
     , _uvIOEffects :: Universe -> IO Universe
-    , _uvConcEffects :: Maybe (IO (Universe -> Universe))
+    , _uvConcEffects :: ConcEffect
     , _uvConfig :: Configuration
     , _uvTestString :: Universe -> [String]
-    , _uvConcMessage :: String
     }
 
+data ConcEffect = NoConcEffect
+    | NewConcEffect {_ceFunction :: (Universe -> Universe, IO (Universe -> Maybe Universe))
+        , _ceString :: String, _ceIsBlocking :: Bool}
+    | BlockingConcEffect {_ceString :: String}
+    | BackgroundConcEffect {_ceString :: String}
 
-data OptionScreenFlag = NormalOptions | GameOverOptions
+data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
     deriving (Eq, Ord, Show, Read)
 
 data ScreenLayer
@@ -50,13 +54,13 @@ data ScreenLayer
         { _scInput :: T.Text
         , _scFooter :: String
         }
-    | WaitScreen
+--    | WaitScreen
-        { _scWaitMessage :: Universe -> String
+--        { _scWaitMessage :: Universe -> String
-        , _scWaitTime :: Int
+--        , _scWaitTime :: Int
-        }
+--        }
-    | DisplayScreen
+--    | DisplayScreen
-        { _scDisplay :: Universe -> Picture
+--        { _scDisplay :: Universe -> Picture
-        }
+--        }
 
 data MenuOption
     = Toggle
@@ -80,3 +84,4 @@ data IntID a = IntID Int a
 
 makeLenses ''Universe
 makeLenses ''ScreenLayer
+makeLenses ''ConcEffect

src/Dodge/Data/World.hs

@@ -42,13 +42,8 @@ data World = World
     , _backspaceTimer :: Int
     , _timeFlow :: TimeFlowStatus
     , _rbOptions :: RightButtonOptions
-    , _gameSlot :: GameSlot
     }
 
-data GameSlot = GameNum Int
-    | GameLoading SaveSlot
-    | GameStartScreen
-
 data TimeFlowStatus
     = RewindingNow
     | RewindingLastFrame

src/Dodge/Debug/Terminal.hs

@@ -59,7 +59,7 @@ parseNum :: [String] -> Int
 parseNum xs = fromMaybe 1 $ xs ^? ix 0 >>= readMaybe
 
 showTerminalError :: String -> String -> Universe -> Universe
-showTerminalError cmd s = menuLayers .:~ InputScreen (T.pack cmd) s
+showTerminalError cmd s = uvScreenLayers .:~ InputScreen (T.pack cmd) s
 
 applySetTerminalString :: String -> Universe -> Universe
 applySetTerminalString [] = id

src/Dodge/Default/World.hs

@@ -31,7 +31,6 @@ defaultWorld =
         , _backspaceTimer = 0
         , _timeFlow = NormalTimeFlow
         , _rbOptions = NoRightButtonOptions
-        , _gameSlot = GameStartScreen
         }
 
 defaultCWorld :: CWorld
@@ -93,12 +92,9 @@ defaultCWorld =
         , _buttons = IM.empty
         , _corpses = IM.empty
         , _decorations = IM.empty
-        , --, _savedWorlds = M.empty
+        , _clickMousePos = V2 0 0
-          --    , _menuLayers = []
-          _clickMousePos = V2 0 0
         , _pathGraph = Data.Graph.Inductive.Graph.empty
-        , --    , _pathGraphP   = mempty
+        , _pnZoning = mempty
-          _pnZoning = mempty
         , _peZoning = mempty
         , _hud =
             HUD

src/Dodge/Event.hs

@@ -90,7 +90,7 @@ handleResizeEvent sev u =
     divRes = resFactorNum $ u ^. uvConfig . graphics_resolution_factor
 
 handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe
-handleMouseWheelEvent mwev w = case _menuLayers w of
+handleMouseWheelEvent mwev w = case _uvScreenLayers w of
     [] -> case mouseWheelEventPos mwev of
         V2 _ y -> Just $ w & uvWorld %~ wheelEvent (fromIntegral y)
     _ -> Just w

src/Dodge/Event/Keyboard.hs

@@ -38,7 +38,7 @@ import SDL
 handleTextInput :: T.Text -> Universe -> Universe
 handleTextInput text u =
     u
-        & menuLayers . ix 0 . scInput %~ updateText
+        & uvScreenLayers . ix 0 . scInput %~ updateText
         & updateTerminalText
   where
     updateTerminalText = case u ^? uvWorld . cWorld . hud . hudElement . subInventory of
@@ -85,12 +85,12 @@ handlePressedKey _ scode u = case scode of
     ScancodeF5 -> return . Just $ doQuicksave u
     ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
     ScancodeSemicolon -> return . Just $ gotoTerminal u
-    _ | null (_menuLayers u) -> case u ^? uvWorld . cWorld . hud . hudElement . subInventory of
+    _ | null (_uvScreenLayers u) -> case u ^? uvWorld . cWorld . hud . hudElement . subInventory of
         Just (DisplayTerminal tmid)
             | inTermFocus (_uvWorld u) ->
                 return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u
         _ -> return $ (Just . handlePressedKeyInGame scode) u
-    _ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u
+    _ -> handlePressedKeyInMenu (head $ _uvScreenLayers u) scode u
 
 handlePressedKeyInGame :: Scancode -> Universe -> Universe
 handlePressedKeyInGame scode uv = case scode of
@@ -136,9 +136,9 @@ toggleInspectInv he = case he of
     _ -> DisplayInventory InspectInventory
 
 gotoTerminal :: Universe -> Universe
-gotoTerminal w = case _menuLayers w of
+gotoTerminal w = case _uvScreenLayers w of
     (InputScreen{} : _) -> w
-    _ -> w & menuLayers .:~ InputScreen T.empty "Enter command"
+    _ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command"
 
 spaceAction :: World -> World
 spaceAction w = case _hudElement $ _hud (_cWorld w) of
@@ -155,7 +155,7 @@ spaceAction w = case _hudElement $ _hud (_cWorld w) of
 --    updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail
 
 pauseGame :: Universe -> Universe
-pauseGame = menuLayers .~ [pauseMenu]
+pauseGame = uvScreenLayers .~ [pauseMenu]
 
 toggleMap :: World -> World
 toggleMap w = case _hudElement $ _hud (_cWorld w) of

src/Dodge/Event/Menu.hs

@@ -15,14 +15,14 @@ handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Unive
 handlePressedKeyInMenu mState scode = case mState of
     OptionScreen{_scOptions = mos, _scDefaultEff = defeff} ->
         optionListToEffects defeff scode mos
-    DisplayScreen{} -> popScreen
+    --DisplayScreen{} -> popScreen
     ColumnsScreen{} -> popScreen
-    WaitScreen{} -> return . Just
+--    WaitScreen{} -> return . Just
     InputScreen s help -> case scode of
         ScancodeEscape -> popScreen
         ScancodeReturn -> popScreen . applyTerminalString (words $ T.unpack s)
         ScancodeTab -> autoCompleteTerminal (T.unpack s) help
-        ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace)
+        ScancodeBackspace -> return . Just . (uvScreenLayers . ix 0 . scInput %~ doBackspace)
         -- text input handled by handleTextInput
         _ -> return . Just
   where
@@ -39,7 +39,7 @@ optionListToEffects ::
 optionListToEffects defaulteff sc mops u = case sc of
     ScancodeSpace ->
         return . Just
-            . (menuLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
+            . (uvScreenLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
             $ u
     _ ->
         ( fromMaybe defaulteff

src/Dodge/Initialisation.hs

@@ -8,11 +8,15 @@ import Dodge.SoundLogic
 import Geometry.Data
 import qualified IntMapHelp as IM
 
+splashScreen :: World
+splashScreen = 
+    defaultWorld
+        & cWorld . creatures .~ IM.fromList [(0, startCr)]
+
 initialWorld :: World
 initialWorld =
     defaultWorld
         & cWorld . cameraZoom .~ 10
         & cWorld . creatures .~ IM.fromList [(0, startCr)]
-        & cWorld . yourID .~ 0
         & cWorld . worldEvents .~ SoundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing :
         [MakeStartCloudAt (V3 x y 5) | x <- [-5, -4 .. 5], y <- [-5, -4 .. 5]]

src/Dodge/Menu.hs

@@ -1,11 +1,14 @@
 module Dodge.Menu (
-    scodeToChar,
     pauseMenu,
     gameOverMenu,
+    splashMenu,
 ) where
 
+import Control.Monad
+import Dodge.Concurrent
 import Dodge.Config.Update
 import Dodge.Data.Universe
+import Dodge.Menu.Option
 import Dodge.Menu.OptionType
 import Dodge.Menu.PushPop
 import Dodge.PreloadData
@@ -19,15 +22,25 @@ import SDL
 import System.Clipboard
 import Text.Read
 
-slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer
+splashMenu :: ScreenLayer
-slTitleOptionsEff title ops eff =
+splashMenu =
-    OptionScreen
+    slTitleOptionsEff "AMNESIS" splashMenuOptions (return . Just)
-        { _scTitle = const title
+        & scOptionFlag .~ SplashOptions
-        , _scOptions = ops
+
-        , _scDefaultEff = eff
+splashMenuOptions :: [MenuOption]
-        , _scOptionFlag = NormalOptions
+splashMenuOptions =
-        , _scOptionsOffset = 0
+    basicKeyOptions
-        }
+        [ Toggle (return . Just . loadSaveSlot (SaveSlotNum 0)) (opText "CONTINUE")
+        , Toggle (return . Just . startNewGameInSlot 0) (opText "NEW GAME")
+        , Toggle (return . Just . reloadLevelStart) (opText "RESTART")
+        , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED")
+        , Toggle (pushScreen optionMenu) (opText "OPTIONS")
+        , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
+        , Toggle (return . Just) (opText "VIEW CURRENT SEED")
+        , Toggle (return . const Nothing) (opText "QUIT")
+        ]
+  where
+    opText = const . Left
 
 pauseMenu :: ScreenLayer
 pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
@@ -35,17 +48,31 @@ pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
 pauseMenuOptions :: [MenuOption]
 pauseMenuOptions =
     basicKeyOptions
-        [ Toggle (return . Just . startNewGame) (opText "NEW LEVEL")
+        [ Toggle popScreen (opText "CONTINUE")
+        , Toggle (return . Just . startNewGameInSlot 0) (opText "NEW GAME")
         , Toggle (return . Just . reloadLevelStart) (opText "RESTART")
-        , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "START FROM SEED")
+        , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED")
         , Toggle (pushScreen optionMenu) (opText "OPTIONS")
-        , Toggle (pushScreen displayControls) (opText "CONTROLS")
+        , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
+        , Toggle (return . Just) (opText "VIEW CURRENT SEED")
+        , Toggle saveQuit (opText "SAVE AND QUIT")
         ]
         ++ [ InvisibleToggle ScancodeEscape (return . const Nothing)
            ]
   where
     opText = const . Left
 
+saveQuit :: Universe -> IO (Maybe Universe)
+saveQuit u =
+    return $
+        Just $
+            u & tryConcEffect True "SAVING" (saveQuitConc u)
+
+saveQuitConc :: Universe -> IO (Universe -> Maybe Universe)
+saveQuitConc u = do
+    void $ writeSaveSlot (SaveSlotNum 0) u
+    return $ const Nothing
+
 seedStartMenu :: String -> ScreenLayer
 seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen
 
@@ -62,7 +89,7 @@ trySeedFromClipboard u = do
         Nothing ->
             pushScreen
                 (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
-                (u & menuLayers %~ tail)
+                (u & uvScreenLayers %~ tail)
         Just i -> return . Just $ startSeedGame 0 i u
 
 slTitleOptions :: String -> [MenuOption] -> ScreenLayer
@@ -172,23 +199,22 @@ graphicsMenuOptions =
 
 gameOverMenu :: ScreenLayer
 gameOverMenu =
-    OptionScreen
+    slTitleOptionsEff "GAME OVER" pauseMenuOptions (return . Just)
-        { _scTitle = const "GAME OVER"
+        & scOptionFlag .~ GameOverOptions
-        , _scOptions = pauseMenuOptions
-        , _scDefaultEff = return . Just
-        , _scOptionFlag = GameOverOptions
-        , _scOptionsOffset = 0
-        }
 
--- | hacky - no longer used
+--    OptionScreen
-scodeToChar :: Scancode -> Char
+--        { _scTitle = const "GAME OVER"
-scodeToChar = toEnum . (+ 61) . fromIntegral . unwrapScancode
+--        , _scOptions = pauseMenuOptions
+--        , _scDefaultEff = return . Just
+--        , _scOptionFlag = GameOverOptions
+--        , _scOptionsOffset = 0
+--        }
 
 --charToScode :: Char -> Scancode
 --charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
 
 unpause :: Universe -> Maybe Universe
-unpause w = Just . resumeSound $ w & menuLayers .~ []
+unpause w = Just . resumeSound $ w & uvScreenLayers .~ []
 
 displayControls :: ScreenLayer
 displayControls = ColumnsScreen (const "CONTROLS") listControls

src/Dodge/Menu/Option.hs

@@ -0,0 +1,13 @@
+module Dodge.Menu.Option
+    where
+import Dodge.Data.Universe
+
+slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer
+slTitleOptionsEff title ops eff =
+    OptionScreen
+        { _scTitle = const title
+        , _scOptions = ops
+        , _scDefaultEff = eff
+        , _scOptionFlag = NormalOptions
+        , _scOptionsOffset = 0
+        }

src/Dodge/Menu/PushPop.hs

@@ -4,13 +4,13 @@ import Dodge.Data.Universe
 import LensHelp
 
 popScreen' :: Universe -> Maybe Universe
-popScreen' = Just . (menuLayers %~ tail)
+popScreen' = Just . (uvScreenLayers %~ tail)
 
 popScreen :: Universe -> IO (Maybe Universe)
 popScreen = return . popScreen'
 
 pushScreen' :: ScreenLayer -> Universe -> Maybe Universe
-pushScreen' ml = Just . (menuLayers .:~ ml)
+pushScreen' ml = Just . (uvScreenLayers .:~ ml)
 
 pushScreen :: ScreenLayer -> Universe -> IO (Maybe Universe)
 pushScreen ml = return . pushScreen' ml

src/Dodge/Render/MenuScreen.hs

@@ -3,10 +3,10 @@ module Dodge.Render.MenuScreen (
     menuScreen,
 ) where
 
+import Dodge.ScodeToChar
 import qualified Data.Text as T
 import Dodge.Base.Window
 import Dodge.Data.Universe
-import Dodge.Menu
 import Dodge.WindowLayout
 import Padding
 import Picture
@@ -15,9 +15,9 @@ menuScreen :: Universe -> ScreenLayer -> Picture
 menuScreen w screen = case screen of
     OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off} ->
         drawOptions w (titf w) mos off "Use keys to navigate the menu"
-    (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
+--    (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
     (InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 help
-    (DisplayScreen sd) -> sd w
+--    (DisplayScreen sd) -> sd w
     (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs
 
 --displayStringList :: World -> [String] -> Picture

src/Dodge/Render/Picture.hs

@@ -2,18 +2,19 @@ module Dodge.Render.Picture (
     fixedCoordPictures,
 ) where
 
-import Dodge.Base.Window
-import Dodge.Render.List
 import Dodge.Base.WinScale
+import Dodge.Base.Window
 import Dodge.Data.Universe
 import Dodge.Render.HUD
+import Dodge.Render.List
 import Dodge.Render.MenuScreen
 import Geometry
 import Picture
+import Control.Lens
 
 fixedCoordPictures :: Universe -> Picture
 fixedCoordPictures u =
-    drawConcurrentMessage u <> case _menuLayers u of
+    drawConcurrentMessage u <> case u ^. uvScreenLayers of
         [] ->
             pictures
                 [ hudDrawings u
@@ -25,9 +26,20 @@ fixedCoordPictures u =
     cfig = _uvConfig u
 
 drawConcurrentMessage :: Universe -> Picture
-drawConcurrentMessage uv = listPicturesAt (halfWidth cfig) (_windowY cfig - 50) cfig [text (_uvConcMessage uv)]
+drawConcurrentMessage u = case u ^. uvConcEffects of
+    BlockingConcEffect str -> listPicturesAt
+        (halfWidth cfig)
+        (halfHeight cfig)
+        cfig
+        [text str]
+    BackgroundConcEffect str -> listPicturesAt
+        (halfWidth cfig)
+        (_windowY cfig - 50)
+        cfig
+        [text str]
+    _ -> mempty
   where
-    cfig = _uvConfig uv
+    cfig = _uvConfig u
 
 customMouseCursor :: Configuration -> World -> Picture
 customMouseCursor cfig w =

src/Dodge/Save.hs

@@ -7,6 +7,7 @@ module Dodge.Save (
     readSaveSlot,
     reloadLevelStart,
 ) where
+import Dodge.Concurrent
 import Control.Lens
 import Dodge.Data.SaveSlot
 import Data.Aeson
@@ -16,27 +17,29 @@ import Dodge.Data.Universe
 --import qualified Data.Set as S
 import System.Directory
 
-writeSaveSlot :: SaveSlot -> Universe -> IO (Universe -> Universe)
+writeSaveSlot :: SaveSlot -> Universe -> IO (Universe -> Maybe Universe)
 writeSaveSlot ss u = do
+    putStrLn $ "Saving " ++ saveSlotPath ss
     createDirectoryIfMissing True "saveSlot"
     BS.writeFile (saveSlotPath ss) $
         AEP.encodePretty'
             (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
             (u ^. uvWorld . cWorld)
-    return id
+    return Just
 
---writeFile (saveSlotPath ss) (show $ u ^. uvWorld . cWorld)
+readSaveSlot :: SaveSlot -> IO (Universe -> Maybe Universe)
-
-readSaveSlot :: SaveSlot -> IO (Universe -> Universe)
 readSaveSlot ss = do
     fExists <- doesFileExist $ saveSlotPath ss
     if fExists
         then do
             cwstr <- decodeFileStrict $ saveSlotPath ss
             case cwstr of
-                Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return id
+                Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return removescreenlayers
-                Just cw -> return $ \uv -> uv & uvWorld . cWorld .~ cw
+                Just cw -> return $ \uv -> Just $ uv & uvWorld . cWorld .~ cw
-        else putStrLn "loadSaveSlot failed to find saved file" >> return id
+                    & uvScreenLayers .~ []
+        else putStrLn "loadSaveSlot failed to find saved file" >> return removescreenlayers
+  where
+    removescreenlayers = Just . (uvScreenLayers .~ [])
 
 saveSlotPath :: SaveSlot -> String
 saveSlotPath (SaveSlotNum i) = "saveSlot/" ++ show i
@@ -44,21 +47,13 @@ saveSlotPath QuicksaveSlot = "saveSlot/QuickSave"
 saveSlotPath (LevelStartSlot i) = "saveSlot/LevelStart" ++ show i
 
 saveWorldInSlot :: SaveSlot -> Universe -> Universe
-saveWorldInSlot slot u = u & uvConcEffects ?~
+saveWorldInSlot slot u = tryConcEffect False "ASDF" (writeSaveSlot slot u) u
-    writeSaveSlot slot u
     
 reloadLevelStart :: Universe -> Universe
-reloadLevelStart u = case u ^. uvWorld . gameSlot of
+reloadLevelStart = loadSaveSlot (LevelStartSlot 0)
-    GameNum i -> loadSaveSlot (LevelStartSlot i) u
-    _ -> u
 
 loadSaveSlot :: SaveSlot -> Universe -> Universe
-loadSaveSlot slot = (uvConcEffects ?~ readSaveSlot slot)
+loadSaveSlot slot = tryConcEffect True "LOADING" (readSaveSlot slot)
-    . (uvWorld . gameSlot .~ GameLoading slot)
---    maybe
---        u
---        (\w -> u & menuLayers .~ [] & uvWorld .~ w)
---        $ M.lookup slot (_savedWorlds u)
 
 doQuicksave :: Universe -> Universe
 doQuicksave = saveWorldInSlot QuicksaveSlot

src/Dodge/ScodeToChar.hs

@@ -0,0 +1,8 @@
+module Dodge.ScodeToChar
+    where
+import SDL
+
+-- | hacky - no longer used
+scodeToChar :: Scancode -> Char
+scodeToChar = toEnum . (+ 61) . fromIntegral . unwrapScancode
+

src/Dodge/StartNewGame.hs

@@ -1,30 +1,28 @@
-module Dodge.StartNewGame where
+module Dodge.StartNewGame (
+    startNewGameInSlot,
+    startSeedGame,
+) where
 
-import Dodge.Save
+import Dodge.Concurrent
+--import Dodge.Menu.Option
 import Control.Lens
 import Dodge.Data.Universe
 import Dodge.LevelGen
+import Dodge.Save
 import System.Random
 
-startNewGame :: Universe -> Universe
-startNewGame u = case u ^. uvWorld . gameSlot of
-    GameNum i -> startNewGameInSlot i u
-    GameLoading{} -> u
-    GameStartScreen -> startNewGameInSlot 0 u -- this needs to be changed
-
 startNewGameInSlot :: Int -> Universe -> Universe
 startNewGameInSlot slot u = startSeedGame slot i u
   where
     i = fst $ randomR (0, maxBound) (_randGen (_uvWorld u))
 
 startSeedGame :: Int -> Int -> Universe -> Universe
-startSeedGame slot i u =
+startSeedGame _ i = tryConcEffect True "GENERATING" (startSeedGameConc i)
-    u
+
-        & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
+startSeedGameConc :: Int -> IO (Universe -> Maybe Universe)
-        & uvIOEffects .~ \_ -> do
+startSeedGameConc seed = do
-            w <- generateWorldFromSeed i
+    w <- generateWorldFromSeed seed
-            return $
+    return $ Just 
-                u & menuLayers .~ [] & uvWorld .~ w
+        . saveWorldInSlot (LevelStartSlot 0)
-                    & uvWorld . gameSlot .~ GameNum slot
+        . (uvScreenLayers .~ [])
-                    & saveWorldInSlot (LevelStartSlot slot)
+        . (uvWorld .~ w)
---                    & savedWorlds . at LevelStartSlot ?~ w

src/Dodge/Update.hs

@@ -63,10 +63,9 @@ import Sound.Data
 
 {- For most menus the only way to change the world is using event handling.  -}
 updateUniverse :: Universe -> Universe
-updateUniverse u = (uvConcEffects .~ Nothing) $ case _menuLayers u of
+updateUniverse u 
-    (WaitScreen s i : _)
+    | isblocking = u
-        | i < 1 -> u & over uvWorld doWorldEvents
+    | otherwise = case _uvScreenLayers u of
-        | otherwise -> u & menuLayers %~ ((WaitScreen s (i -1) :) . tail)
         (OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
             u & uvWorld
                 %~ (
@@ -78,6 +77,10 @@ updateUniverse u = (uvConcEffects .~ Nothing) $ case _menuLayers u of
                    )
         (_ : _) -> u
         [] -> functionalUpdate u
+  where
+    isblocking = case u ^. uvConcEffects of
+        BlockingConcEffect{} -> True
+        _ -> False
 
 -- | The update step.
 functionalUpdate :: Universe -> Universe
@@ -444,7 +447,7 @@ checkEndGame :: Universe -> Universe
 checkEndGame uv = case _deathDelay (_cWorld w) of
     Just x
         | x < 0 ->
-            uv & menuLayers .~ [gameOverMenu]
+            uv & uvScreenLayers .~ [gameOverMenu]
                 & uvWorld . cWorld . deathDelay .~ Nothing
     Just _ -> uv & uvWorld . cWorld . deathDelay . _Just -~ 1
     _ | _crHP (you w) < 1 -> uv & uvWorld . cWorld . deathDelay ?~ 50

src/Loop.hs

@@ -102,8 +102,8 @@ setupConLoop ::
     (world -> IO ()) ->
     -- | Initial simulation state.
     IO world ->
-    -- | Concurrent effects
+    -- | Concurrent effects. Evaluating 'Nothing' exits the loop
-    (world -> Maybe (IO (world -> world))) ->
+    (world -> Maybe (world -> world,IO (world -> Maybe world))) ->
     -- | update, called once per frame. Allows for side effects such as rendering.
     (world -> IO world) ->
     -- | SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
@@ -127,13 +127,14 @@ setupConLoop spf title winconfig paramCleanup ioStartWorld coneffs sideEffects e
 -- | The internal loop.
 doConLoop ::
     -- | The mvar for concurrency
-    MVar (world -> world) ->
+    MVar (world -> Maybe world) ->
     -- | target msec per frame
     Int ->
     -- | The SDL window.
     Window ->
-    -- | Concurrent effects
+    -- | Concurrent effects, the first function in the pair is applied
-    (world -> Maybe (IO (world -> world))) ->
+    -- immediately
+    (world -> Maybe (world->world,IO (world -> Maybe world))) ->
     -- | simulation update.
     (world -> IO world) ->
     -- | SDL Event handling.
@@ -143,17 +144,22 @@ doConLoop ::
     IO ()
 doConLoop themvar spf window coneffs worldSideEffects eventFn startWorld = do
     startTicks <- ticks
-    mconupdate <- tryTakeMVar themvar
+    let mconeff = coneffs startWorld
-    case coneffs startWorld of
+    case mconeff of
         Nothing -> return ()
-        Just acc -> do
+        Just (_,acc) -> do
             _ <- forkIO $ do
                 up <- acc
                 putMVar themvar up
             return ()
-    let startWorld' = case mconupdate of
+    let startWorld'' = maybe id fst mconeff startWorld
-            Just conupdate -> conupdate startWorld
+    mconupdate <- tryTakeMVar themvar
-            Nothing -> startWorld
+    let mstartWorld' = case mconupdate of
+            Just conupdate -> conupdate startWorld''
+            Nothing -> Just startWorld''
+    case mstartWorld' of
+        Nothing -> return ()
+        Just startWorld' -> do
             worldAfterSimStep <- worldSideEffects startWorld'
             glSwapWindow window
             maybeUpdatedWorld <- pollEvents >>= foldM (applyEventIO eventFn) (Just worldAfterSimStep)