diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 4dce504d6..743b57a26 100644 --- a/appDodge/Main.hs +++ b/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 - {_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 diff --git a/src/Dodge/Concurrent.hs b/src/Dodge/Concurrent.hs index 7357cd54d..30114911d 100644 --- a/src/Dodge/Concurrent.hs +++ b/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)) -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)) diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index 8d7c44d24..fa41693a9 100644 --- a/src/Dodge/Data/Universe.hs +++ b/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 - { _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 diff --git a/src/Dodge/Data/World.hs b/src/Dodge/Data/World.hs index 12f8279bf..cee2ac477 100644 --- a/src/Dodge/Data/World.hs +++ b/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 diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs index 4f0b170a3..9fda85245 100644 --- a/src/Dodge/Debug/Terminal.hs +++ b/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 diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index aa5d1b8ff..0ba8ca3d4 100644 --- a/src/Dodge/Default/World.hs +++ b/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 - -- , _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 diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index fe95f8e72..243f1b6d7 100644 --- a/src/Dodge/Event.hs +++ b/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 diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 89428e87f..800a0d3ce 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/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 diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index fadee908b..f3568a52d 100644 --- a/src/Dodge/Event/Menu.hs +++ b/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 diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 125d01ed4..2914a3f25 100644 --- a/src/Dodge/Initialisation.hs +++ b/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]] diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index c4cf716bd..cc3530641 100644 --- a/src/Dodge/Menu.hs +++ b/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 -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 diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs new file mode 100644 index 000000000..8e263c206 --- /dev/null +++ b/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 + } diff --git a/src/Dodge/Menu/PushPop.hs b/src/Dodge/Menu/PushPop.hs index a17471185..beb825099 100644 --- a/src/Dodge/Menu/PushPop.hs +++ b/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 diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 826d15a29..defb2935c 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index c9f16f872..425e4e75d 100644 --- a/src/Dodge/Render/Picture.hs +++ b/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 = diff --git a/src/Dodge/Save.hs b/src/Dodge/Save.hs index f97533c96..51dc6cc75 100644 --- a/src/Dodge/Save.hs +++ b/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 -> 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 diff --git a/src/Dodge/ScodeToChar.hs b/src/Dodge/ScodeToChar.hs new file mode 100644 index 000000000..f7f5e6824 --- /dev/null +++ b/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 + diff --git a/src/Dodge/StartNewGame.hs b/src/Dodge/StartNewGame.hs index 543be1b60..d96341621 100644 --- a/src/Dodge/StartNewGame.hs +++ b/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 = - 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) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 6bd64af79..88ee80008 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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 diff --git a/src/Loop.hs b/src/Loop.hs index 972d255be..e55f33ab0 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -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 ()