diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 8798d18f1..4dce504d6 100644 --- a/appDodge/Main.hs +++ b/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 diff --git a/src/Dodge/Concurrent.hs b/src/Dodge/Concurrent.hs new file mode 100644 index 000000000..7357cd54d --- /dev/null +++ b/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 diff --git a/src/Dodge/Data/SaveSlot.hs b/src/Dodge/Data/SaveSlot.hs new file mode 100644 index 000000000..5542bee41 --- /dev/null +++ b/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 diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index 7077b5e96..8d7c44d24 100644 --- a/src/Dodge/Data/Universe.hs +++ b/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) diff --git a/src/Dodge/Data/World.hs b/src/Dodge/Data/World.hs index e5547ff4c..12f8279bf 100644 --- a/src/Dodge/Data/World.hs +++ b/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 diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 4f3915ed7..aa5d1b8ff 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -31,6 +31,7 @@ defaultWorld = , _backspaceTimer = 0 , _timeFlow = NormalTimeFlow , _rbOptions = NoRightButtonOptions + , _gameSlot = GameStartScreen } defaultCWorld :: CWorld diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 6452970b0..89428e87f 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/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) - ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u +-- ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u) +-- ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u ScancodeF5 -> return . Just $ doQuicksave u ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u ScancodeSemicolon -> return . Just $ gotoTerminal u diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 75e445add..c4cf716bd 100644 --- a/src/Dodge/Menu.hs +++ b/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) diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index bc3c427c3..c9f16f872 100644 --- a/src/Dodge/Render/Picture.hs +++ b/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 - [] -> - pictures - [ hudDrawings u - , customMouseCursor cfig w - ] - (lay : _) -> setDepth (-1) . winScale cfig $ menuScreen u lay +fixedCoordPictures u = + drawConcurrentMessage u <> case _menuLayers u of + [] -> + pictures + [ hudDrawings u + , customMouseCursor cfig w + ] + (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 diff --git a/src/Dodge/Save.hs b/src/Dodge/Save.hs index ec5f59847..f97533c96 100644 --- a/src/Dodge/Save.hs +++ b/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 ss uv = do +readSaveSlot :: SaveSlot -> IO (Universe -> Universe) +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 - Just cw -> return $ uv & uvWorld . cWorld .~ cw - else putStrLn "loadSaveSlot failed to find saved file" >> return uv + Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return id + Just cw -> return $ \uv -> uv & uvWorld . cWorld .~ cw + 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" - -saveWorldInEmptySlot :: SaveSlot -> Universe -> Universe -saveWorldInEmptySlot slot w = case M.lookup slot $ _savedWorlds w of - Nothing -> w & savedWorlds %~ M.insert slot (clearKeys (_uvWorld w)) - _ -> w +saveSlotPath (LevelStartSlot i) = "saveSlot/LevelStart" ++ show i 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 = - maybe - u - (\w -> u & menuLayers .~ [] & uvWorld .~ w) - $ M.lookup slot (_savedWorlds u) +loadSaveSlot slot = (uvConcEffects ?~ readSaveSlot slot) + . (uvWorld . gameSlot .~ GameLoading slot) +-- maybe +-- u +-- (\w -> u & menuLayers .~ [] & uvWorld .~ w) +-- $ M.lookup slot (_savedWorlds u) doQuicksave :: Universe -> Universe doQuicksave = saveWorldInSlot QuicksaveSlot -clearKeys :: World -> World -clearKeys = (keys .~ mempty) . (mouseButtons .~ mempty) +--clearKeys :: World -> World +--clearKeys = (keys .~ mempty) . (mouseButtons .~ mempty) -saveLevelStartSlot :: Universe -> Universe ---saveLevelStartSlot = id -saveLevelStartSlot = saveWorldInSlot LevelStartSlot +--saveLevelStartSlot :: Universe -> Universe +----saveLevelStartSlot = id +--saveLevelStartSlot = saveWorldInSlot LevelStartSlot --saveLevelStartSlot = sideEffects %~ (fmap (undefined) . ) diff --git a/src/Dodge/StartNewGame.hs b/src/Dodge/StartNewGame.hs index 2ce211f5d..543be1b60 100644 --- a/src/Dodge/StartNewGame.hs +++ b/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 i u = +startSeedGame :: Int -> Int -> Universe -> Universe +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 diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index 49d3f3f6f..9b23c8918 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -4,3 +4,4 @@ import Dodge.Data.Universe testStringInit :: Universe -> [String] testStringInit _ = [] + diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index fba008d2a..6bd64af79 100644 --- a/src/Dodge/Update.hs +++ b/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) diff --git a/src/Loop.hs b/src/Loop.hs index 3bc9efa8b..972d255be 100644 --- a/src/Loop.hs +++ b/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 ()