justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Work on saving/loading concurrently

Browse Source
This commit is contained in:
justin
2022-08-18 10:05:24 +01:00
parent 26e88f059a
commit c74d3b04bf
20 changed files with 232 additions and 154 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+9 -7
View File
@@ -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
{_uvWorld = initialWorld
--return $ startNewGame $ Universe
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
+18 -3
View File
@@ -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))
conTest = _uvConcEffects
conEffects :: Universe -> Maybe (Universe -> Universe,IO (Universe -> Maybe Universe))
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
+16 -11
View File
@@ -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
{ _scWaitMessage :: Universe -> String
, _scWaitTime :: Int
}
| DisplayScreen
{ _scDisplay :: Universe -> Picture
}
-- | WaitScreen
-- { _scWaitMessage :: Universe -> String
-- , _scWaitTime :: Int
-- }
-- | DisplayScreen
-- { _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
-5
View File
@@ -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
+1 -1
View File
@@ -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
+2 -6
View File
@@ -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
-- , _menuLayers = []
_clickMousePos = V2 0 0
, _clickMousePos = V2 0 0
, _pathGraph = Data.Graph.Inductive.Graph.empty
, -- , _pathGraphP = mempty
_pnZoning = mempty
, _pnZoning = mempty
, _peZoning = mempty
, _hud =
HUD
src/Dodge/Event.hs
+1 -1
View File
@@ -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
+6 -6
View File
@@ -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
+4 -4
View File
@@ -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
+5 -1
View File
@@ -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
+51 -25
View File
@@ -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
slTitleOptionsEff title ops eff =
OptionScreen
{ _scTitle = const title
, _scOptions = ops
, _scDefaultEff = eff
, _scOptionFlag = NormalOptions
, _scOptionsOffset = 0
}
splashMenu :: ScreenLayer
splashMenu =
slTitleOptionsEff "AMNESIS" splashMenuOptions (return . Just)
& scOptionFlag .~ SplashOptions
splashMenuOptions :: [MenuOption]
splashMenuOptions =
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
{ _scTitle = const "GAME OVER"
, _scOptions = pauseMenuOptions
, _scDefaultEff = return . Just
, _scOptionFlag = GameOverOptions
, _scOptionsOffset = 0
}
slTitleOptionsEff "GAME OVER" pauseMenuOptions (return . Just)
& scOptionFlag .~ GameOverOptions
-- | hacky - no longer used
scodeToChar :: Scancode -> Char
scodeToChar = toEnum . (+ 61) . fromIntegral . unwrapScancode
-- OptionScreen
-- { _scTitle = const "GAME OVER"
-- , _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
+13
View File
@@ -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
+2 -2
View File
@@ -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 -3
View File
@@ -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
+17 -5
View File
@@ -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
+14 -19
View File
@@ -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 -> Universe)
readSaveSlot :: SaveSlot -> IO (Universe -> Maybe 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
Just cw -> return $ \uv -> uv & uvWorld . cWorld .~ cw
else putStrLn "loadSaveSlot failed to find saved file" >> return id
Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return removescreenlayers
Just cw -> return $ \uv -> Just $ uv & uvWorld . cWorld .~ cw
& 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 ?~
writeSaveSlot slot u
saveWorldInSlot slot u = tryConcEffect False "ASDF" (writeSaveSlot slot u) u
reloadLevelStart :: Universe -> Universe
reloadLevelStart u = case u ^. uvWorld . gameSlot of
GameNum i -> loadSaveSlot (LevelStartSlot i) u
_ -> u
reloadLevelStart = loadSaveSlot (LevelStartSlot 0)
loadSaveSlot :: SaveSlot -> Universe -> Universe
loadSaveSlot slot = (uvConcEffects ?~ readSaveSlot slot)
. (uvWorld . gameSlot .~ GameLoading slot)
-- maybe
-- u
-- (\w -> u & menuLayers .~ [] & uvWorld .~ w)
-- $ M.lookup slot (_savedWorlds u)
loadSaveSlot slot = tryConcEffect True "LOADING" (readSaveSlot slot)
doQuicksave :: Universe -> Universe
doQuicksave = saveWorldInSlot QuicksaveSlot
src/Dodge/ScodeToChar.hs
+8
View File
@@ -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
+16 -18
View File
@@ -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 =
u
& menuLayers .~ [WaitScreen (const "GENERATING...") 1]
& uvIOEffects .~ \_ -> do
w <- generateWorldFromSeed i
return $
u & menuLayers .~ [] & uvWorld .~ w
& uvWorld . gameSlot .~ GameNum slot
& saveWorldInSlot (LevelStartSlot slot)
-- & savedWorlds . at LevelStartSlot ?~ w
startSeedGame _ i = tryConcEffect True "GENERATING" (startSeedGameConc i)
startSeedGameConc :: Int -> IO (Universe -> Maybe Universe)
startSeedGameConc seed = do
w <- generateWorldFromSeed seed
return $ Just
. saveWorldInSlot (LevelStartSlot 0)
. (uvScreenLayers .~ [])
. (uvWorld .~ w)
src/Dodge/Update.hs
+19 -16
View File
@@ -63,21 +63,24 @@ 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
(WaitScreen s i : _)
| i < 1 -> u & over uvWorld doWorldEvents
| otherwise -> u & menuLayers %~ ((WaitScreen s (i -1) :) . tail)
(OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
u & uvWorld
%~ (
--updateParticles
(cWorld . radarBlips .~ [])
-- . updateIMl _props _pjUpdate
. updateLightSources
. updateClouds
)
(_ : _) -> u
[] -> functionalUpdate u
updateUniverse u
| isblocking = u
| otherwise = case _uvScreenLayers u of
(OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
u & uvWorld
%~ (
--updateParticles
(cWorld . radarBlips .~ [])
-- . updateIMl _props _pjUpdate
. updateLightSources
. updateClouds
)
(_ : _) -> 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
+27 -21
View File
@@ -102,8 +102,8 @@ setupConLoop ::
(world -> IO ()) ->
-- | Initial simulation state.
IO world ->
-- | Concurrent effects
(world -> Maybe (IO (world -> world))) ->
-- | Concurrent effects. Evaluating 'Nothing' exits the loop
(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
(world -> Maybe (IO (world -> world))) ->
-- | Concurrent effects, the first function in the pair is applied
-- immediately
(world -> Maybe (world->world,IO (world -> Maybe world))) ->
-- | simulation update.
(world -> IO world) ->
-- | SDL Event handling.
@@ -143,25 +144,30 @@ doConLoop ::
IO ()
doConLoop themvar spf window coneffs worldSideEffects eventFn startWorld = do
startTicks <- ticks
mconupdate <- tryTakeMVar themvar
case coneffs startWorld of
let mconeff = coneffs startWorld
case mconeff of
Nothing -> return ()
Just acc -> do
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
let startWorld'' = maybe id fst mconeff startWorld
mconupdate <- tryTakeMVar themvar
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)
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 ()