Allow for concurrent effects

appDodge/Main.hs

@@ -6,6 +6,7 @@ import Dodge.TestString
 import Dodge.Data
 import Dodge.StartNewGame
 import Dodge.Initialisation
+import Dodge.Concurrent
 --import Dodge.LevelGen
 import Dodge.Update
 import Dodge.Event
@@ -40,12 +41,13 @@ main = do
         sizey = floor $ _windowY con
         posx = _windowPosX con
         posy = _windowPosY con
-    setupLoop
+    setupConLoop
         20
         (T.pack "Simple Game Loop")
         (winConfig sizex sizey (Just (posx,posy)))
         theCleanup
         (firstWorldLoad con)
+        conTest
         theUpdateStep
         (flip handleEvent)
 
@@ -77,9 +79,11 @@ firstWorldLoad theConfig = do
         ,_uvConfig    = theConfig
         ,_preloadData = pdata
         ,_menuLayers = []
-        ,_savedWorlds = M.empty
         , _uvIOEffects  = return
         , _uvTestString = testStringInit
+        , _uvConcMessage = ""
+        , _quickSave = Nothing
+        , _uvConcEffects = Nothing
         }
 
 theUpdateStep :: Universe -> IO Universe

src/Dodge/Concurrent.hs

@@ -0,0 +1,10 @@
+module Dodge.Concurrent where
+
+import Dodge.Data.Universe
+--import qualified Data.Set as S
+--import Control.Lens
+--import Control.Concurrent
+--import SDL.Input.Keyboard.Codes
+
+conTest :: Universe -> Maybe (IO (Universe -> Universe))
+conTest = _uvConcEffects

src/Dodge/Data/SaveSlot.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Dodge.Data.SaveSlot where
+import Control.Lens
+
+data SaveSlot
+    = QuicksaveSlot
+    | LevelStartSlot Int
+    | SaveSlotNum Int
+    deriving (Eq, Ord, Show, Read)
+
+makeLenses ''SaveSlot

src/Dodge/Data/Universe.hs

@@ -10,7 +10,7 @@ module Dodge.Data.Universe (
 ) where
 
 import Control.Lens
-import qualified Data.Map.Strict as M
+--import qualified Data.Map.Strict as M
 import Data.Preload
 import qualified Data.Text as T
 import Dodge.Data.Config
@@ -22,17 +22,14 @@ data Universe = Universe
     { _uvWorld :: World
     , _preloadData :: PreloadData
     , _menuLayers :: [ScreenLayer]
-    , _savedWorlds :: M.Map SaveSlot World
+    , _quickSave :: Maybe World
     , _uvIOEffects :: Universe -> IO Universe
+    , _uvConcEffects :: Maybe (IO (Universe -> Universe))
     , _uvConfig :: Configuration
     , _uvTestString :: Universe -> [String]
+    , _uvConcMessage :: String
     }
 
-data SaveSlot
-    = QuicksaveSlot
-    | LevelStartSlot
-    | SaveSlotNum Int
-    deriving (Eq, Ord, Show, Read)
 
 data OptionScreenFlag = NormalOptions | GameOverOptions
     deriving (Eq, Ord, Show, Read)

src/Dodge/Data/World.hs

@@ -3,12 +3,14 @@
 
 module Dodge.Data.World (
     module Dodge.Data.World,
+    module Dodge.Data.SaveSlot,
     module Dodge.Data.CWorld,
     module Dodge.Data.RightButtonOptions,
     module Dodge.Data.SoundOrigin,
     module Dodge.Data.Hammer,
 ) where
 
+import Dodge.Data.SaveSlot
 import Control.Lens
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
@@ -40,8 +42,13 @@ data World = World
     , _backspaceTimer :: Int
     , _timeFlow :: TimeFlowStatus
     , _rbOptions :: RightButtonOptions
+    , _gameSlot :: GameSlot
     }
 
+data GameSlot = GameNum Int
+    | GameLoading SaveSlot
+    | GameStartScreen
+
 data TimeFlowStatus
     = RewindingNow
     | RewindingLastFrame

src/Dodge/Default/World.hs

@@ -31,6 +31,7 @@ defaultWorld =
         , _backspaceTimer = 0
         , _timeFlow = NormalTimeFlow
         , _rbOptions = NoRightButtonOptions
+        , _gameSlot = GameStartScreen
         }
 
 defaultCWorld :: CWorld

src/Dodge/Event/Keyboard.hs

@@ -80,8 +80,8 @@ handlePressedKey True ScancodeBackspace u
     | otherwise = return $ Just $ u & uvWorld . backspaceTimer -~ 1
 handlePressedKey True _ u = return $ Just u
 handlePressedKey _ scode u = case scode of
-    ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u)
+--    ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u)
-    ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u
+--    ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u
     ScancodeF5 -> return . Just $ doQuicksave u
     ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
     ScancodeSemicolon -> return . Just $ gotoTerminal u

src/Dodge/Menu.hs

@@ -36,7 +36,7 @@ pauseMenuOptions :: [MenuOption]
 pauseMenuOptions =
     basicKeyOptions
         [ Toggle (return . Just . startNewGame) (opText "NEW LEVEL")
-        , Toggle (return . Just . loadSaveSlot LevelStartSlot) (opText "RESTART")
+        , Toggle (return . Just . reloadLevelStart) (opText "RESTART")
         , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "START FROM SEED")
         , Toggle (pushScreen optionMenu) (opText "OPTIONS")
         , Toggle (pushScreen displayControls) (opText "CONTROLS")
@@ -63,7 +63,7 @@ trySeedFromClipboard u = do
             pushScreen
                 (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
                 (u & menuLayers %~ tail)
-        Just i -> return . Just $ startSeedGame i u
+        Just i -> return . Just $ startSeedGame 0 i u
 
 slTitleOptions :: String -> [MenuOption] -> ScreenLayer
 slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)

src/Dodge/Render/Picture.hs

@@ -2,6 +2,8 @@ module Dodge.Render.Picture (
     fixedCoordPictures,
 ) where
 
+import Dodge.Base.Window
+import Dodge.Render.List
 import Dodge.Base.WinScale
 import Dodge.Data.Universe
 import Dodge.Render.HUD
@@ -10,17 +12,23 @@ import Geometry
 import Picture
 
 fixedCoordPictures :: Universe -> Picture
-fixedCoordPictures u = case _menuLayers u of
+fixedCoordPictures u =
-    [] ->
+    drawConcurrentMessage u <> case _menuLayers u of
-        pictures
+        [] ->
-            [ hudDrawings u
+            pictures
-            , customMouseCursor cfig w
+                [ hudDrawings u
-            ]
+                , customMouseCursor cfig w
-    (lay : _) -> setDepth (-1) . winScale cfig $ menuScreen u lay
+                ]
+        (lay : _) -> setDepth (-1) . winScale cfig $ menuScreen u lay
   where
     w = _uvWorld u
     cfig = _uvConfig u
 
+drawConcurrentMessage :: Universe -> Picture
+drawConcurrentMessage uv = listPicturesAt (halfWidth cfig) (_windowY cfig - 50) cfig [text (_uvConcMessage uv)]
+  where
+    cfig = _uvConfig uv
+
 customMouseCursor :: Configuration -> World -> Picture
 customMouseCursor cfig w =
     winScale cfig

src/Dodge/Save.hs

@@ -1,71 +1,73 @@
 module Dodge.Save (
-    saveWorldInEmptySlot,
+    saveWorldInSlot,
     loadSaveSlot,
     doQuicksave,
-    saveLevelStartSlot,
+--    saveLevelStartSlot,
     writeSaveSlot,
     readSaveSlot,
+    reloadLevelStart,
 ) where
 import Control.Lens
+import Dodge.Data.SaveSlot
 import Data.Aeson
 import qualified Data.Aeson.Encode.Pretty as AEP
 import qualified Data.ByteString.Lazy as BS
-import qualified Data.Map.Strict as M
 import Dodge.Data.Universe
 --import qualified Data.Set as S
 import System.Directory
 
-writeSaveSlot :: SaveSlot -> Universe -> IO ()
+writeSaveSlot :: SaveSlot -> Universe -> IO (Universe -> Universe)
 writeSaveSlot ss u = do
     createDirectoryIfMissing True "saveSlot"
     BS.writeFile (saveSlotPath ss) $
         AEP.encodePretty'
             (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
             (u ^. uvWorld . cWorld)
+    return id
 
 --writeFile (saveSlotPath ss) (show $ u ^. uvWorld . cWorld)
 
-readSaveSlot :: SaveSlot -> Universe -> IO Universe
+readSaveSlot :: SaveSlot -> IO (Universe -> Universe)
-readSaveSlot ss uv = do
+readSaveSlot ss = do
     fExists <- doesFileExist $ saveSlotPath ss
     if fExists
         then do
-            --cwstr <- readFile $ saveSlotPath ss
-            --case readMaybe cwstr of
             cwstr <- decodeFileStrict $ saveSlotPath ss
             case cwstr of
-                Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return uv
+                Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return id
-                Just cw -> return $ uv & uvWorld . cWorld .~ cw
+                Just cw -> return $ \uv -> uv & uvWorld . cWorld .~ cw
-        else putStrLn "loadSaveSlot failed to find saved file" >> return uv
+        else putStrLn "loadSaveSlot failed to find saved file" >> return id
 
 saveSlotPath :: SaveSlot -> String
 saveSlotPath (SaveSlotNum i) = "saveSlot/" ++ show i
 saveSlotPath QuicksaveSlot = "saveSlot/QuickSave"
-saveSlotPath LevelStartSlot = "saveSlot/LevelStartSave"
+saveSlotPath (LevelStartSlot i) = "saveSlot/LevelStart" ++ show i
-
-saveWorldInEmptySlot :: SaveSlot -> Universe -> Universe
-saveWorldInEmptySlot slot w = case M.lookup slot $ _savedWorlds w of
-    Nothing -> w & savedWorlds %~ M.insert slot (clearKeys (_uvWorld w))
-    _ -> w
 
 saveWorldInSlot :: SaveSlot -> Universe -> Universe
-saveWorldInSlot slot u = u & savedWorlds %~ M.insert slot (clearKeys (_uvWorld u))
+saveWorldInSlot slot u = u & uvConcEffects ?~
+    writeSaveSlot slot u
+    
+reloadLevelStart :: Universe -> Universe
+reloadLevelStart u = case u ^. uvWorld . gameSlot of
+    GameNum i -> loadSaveSlot (LevelStartSlot i) u
+    _ -> u
 
 loadSaveSlot :: SaveSlot -> Universe -> Universe
-loadSaveSlot slot u =
+loadSaveSlot slot = (uvConcEffects ?~ readSaveSlot slot)
-    maybe
+    . (uvWorld . gameSlot .~ GameLoading slot)
-        u
+--    maybe
-        (\w -> u & menuLayers .~ [] & uvWorld .~ w)
+--        u
-        $ M.lookup slot (_savedWorlds u)
+--        (\w -> u & menuLayers .~ [] & uvWorld .~ w)
+--        $ M.lookup slot (_savedWorlds u)
 
 doQuicksave :: Universe -> Universe
 doQuicksave = saveWorldInSlot QuicksaveSlot
 
-clearKeys :: World -> World
+--clearKeys :: World -> World
-clearKeys = (keys .~ mempty) . (mouseButtons .~ mempty)
+--clearKeys = (keys .~ mempty) . (mouseButtons .~ mempty)
 
-saveLevelStartSlot :: Universe -> Universe
+--saveLevelStartSlot :: Universe -> Universe
---saveLevelStartSlot = id
+----saveLevelStartSlot = id
-saveLevelStartSlot = saveWorldInSlot LevelStartSlot
+--saveLevelStartSlot = saveWorldInSlot LevelStartSlot
 
 --saveLevelStartSlot = sideEffects %~ (fmap  (undefined) . )

src/Dodge/StartNewGame.hs

@@ -1,21 +1,30 @@
 module Dodge.StartNewGame where
 
+import Dodge.Save
 import Control.Lens
 import Dodge.Data.Universe
 import Dodge.LevelGen
 import System.Random
 
 startNewGame :: Universe -> Universe
-startNewGame u = startSeedGame i u
+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 -> Universe -> Universe
+startSeedGame :: Int -> Int -> Universe -> Universe
-startSeedGame i u =
+startSeedGame slot i u =
     u
         & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
         & uvIOEffects .~ \_ -> do
             w <- generateWorldFromSeed i
             return $
                 u & menuLayers .~ [] & uvWorld .~ w
-                    & savedWorlds . at LevelStartSlot ?~ w
+                    & uvWorld . gameSlot .~ GameNum slot
+                    & saveWorldInSlot (LevelStartSlot slot)
+--                    & savedWorlds . at LevelStartSlot ?~ w

src/Dodge/TestString.hs

@@ -4,3 +4,4 @@ import Dodge.Data.Universe
 
 testStringInit :: Universe -> [String]
 testStringInit _ = []
+

src/Dodge/Update.hs

@@ -63,7 +63,7 @@ import Sound.Data
 
 {- For most menus the only way to change the world is using event handling.  -}
 updateUniverse :: Universe -> Universe
-updateUniverse u = case _menuLayers u of
+updateUniverse u = (uvConcEffects .~ Nothing) $ case _menuLayers u of
     (WaitScreen s i : _)
         | i < 1 -> u & over uvWorld doWorldEvents
         | otherwise -> u & menuLayers %~ ((WaitScreen s (i -1) :) . tail)

src/Loop.hs

@@ -8,6 +8,7 @@ This module sets up an SDL window which may be updated using a simple game loop.
 -}
 module Loop (
     setupLoop,
+    setupConLoop,
 ) where
 
 import Control.Concurrent
@@ -89,3 +90,78 @@ applyEventIO fn mw e = case eventPayload e of
     mupdate = case mw of
         Nothing -> return Nothing
         Just w -> fn w e
+
+-- | Create a game loop with an SDL window.
+setupConLoop ::
+    -- | Target seconds per frame
+    Int ->
+    -- | Window title
+    T.Text ->
+    WindowConfig ->
+    -- | Function for cleaning up parameters, applied when exiting loop.
+    (world -> IO ()) ->
+    -- | Initial simulation state.
+    IO world ->
+    -- | Concurrent effects
+    (world -> Maybe (IO (world -> 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.
+    (world -> Event -> IO (Maybe world)) ->
+    IO ()
+setupConLoop spf title winconfig paramCleanup ioStartWorld coneffs sideEffects eventFn = do
+    initializeAll
+    themvar <- newEmptyMVar
+    bracket
+        (createWindow title winconfig)
+        destroyWindow
+        $ \window -> bracket
+            (glCreateContext window)
+            (\con -> GL.finish >> glDeleteContext con)
+            $ \_ ->
+                bracket
+                    ioStartWorld
+                    paramCleanup
+                    (doConLoop themvar spf window coneffs sideEffects eventFn)
+
+-- | The internal loop.
+doConLoop ::
+    -- | The mvar for concurrency
+    MVar (world -> world) ->
+    -- | target msec per frame
+    Int ->
+    -- | The SDL window.
+    Window ->
+    -- | Concurrent effects
+    (world -> Maybe (IO (world -> world))) ->
+    -- | simulation update.
+    (world -> IO world) ->
+    -- | SDL Event handling.
+    (world -> Event -> IO (Maybe world)) ->
+    -- | Current simulation state.
+    world ->
+    IO ()
+doConLoop themvar spf window coneffs worldSideEffects eventFn startWorld = do
+    startTicks <- ticks
+    mconupdate <- tryTakeMVar themvar
+    case coneffs startWorld of
+        Nothing -> return ()
+        Just acc -> do
+            _ <- forkIO $ do
+                up <- acc
+                putMVar themvar up
+            return ()
+    let startWorld' = case mconupdate of
+            Just conupdate -> conupdate startWorld
+            Nothing -> startWorld
+    worldAfterSimStep <- worldSideEffects startWorld'
+    glSwapWindow window
+    maybeUpdatedWorld <- pollEvents >>= foldM (applyEventIO eventFn) (Just worldAfterSimStep)
+    case maybeUpdatedWorld of
+        Just updatedWorld -> do
+            performGC
+            endTicks <- ticks -- it might be better to use System.Clock (monotonic)
+            let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks)
+            threadDelay (theDelay * 1000)
+            doConLoop themvar spf window coneffs worldSideEffects eventFn updatedWorld
+        Nothing -> return ()