diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 1c5451faa..43ba94b30 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -89,7 +89,7 @@ firstWorldLoad theConfig = do , _uvScreenLayers = [splashMenu] , _uvIOEffects = return , _uvTestString = testStringInit - , _uvConcEffects = NoConcEffect + , _uvSideEffects = mempty , _uvCanContinue = cancontinue , _uvMSeed = mseed } diff --git a/src/Dodge/Concurrent.hs b/src/Dodge/Concurrent.hs index 0e6b9f0f4..9ba2ddd52 100644 --- a/src/Dodge/Concurrent.hs +++ b/src/Dodge/Concurrent.hs @@ -3,25 +3,38 @@ module Dodge.Concurrent where --import qualified Data.Set as S import Control.Lens import Dodge.Data.Universe +import Data.Sequence (Seq (..)) --import Control.Concurrent --import SDL.Input.Keyboard.Codes conEffects :: Universe -> ConcurrentEffect Universe -conEffects u = case u ^. uvConcEffects of - NewConcEffect{_ceFunction = eff} -> eff +conEffects u = case u ^? uvSideEffects . _head of + Just NewSideEffect{_ceSideEffect = eff} -> ConcurrentEffect (u & uvSideEffects . _head %~ g) + (dopop eff) _ -> NoConcurrentEffect - -tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe -tryConcEffect bl str eff u = case u ^. uvConcEffects of - NoConcEffect -> u & uvConcEffects .~ NewConcEffect (ConcurrentEffect setstr (clearConcEff eff)) str bl - _ -> u where - setstr - | bl = uvConcEffects .~ BlockingConcEffect str - | otherwise = uvConcEffects .~ BackgroundConcEffect str + g seff = RunningSideEffect (_ceString seff) + dopop :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe) + dopop mf = do + f <- mf + return $ f . (uvSideEffects %~ taker) + taker (_ :<| xs) = xs + taker _ = mempty -clearConcEff :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe) -clearConcEff eff = do - f <- eff - return (f . (uvConcEffects .~ NoConcEffect)) +addSideEffect :: IO (Universe -> Maybe Universe) -> String -> Universe -> Universe +addSideEffect f s = uvSideEffects %~ (|> NewSideEffect f s) + +--tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe +--tryConcEffect bl str eff u = case u ^. uvConcEffects of +-- NoConcEffect -> u & uvConcEffects .~ NewConcEffect (ConcurrentEffect 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 c9657cad3..d6932ce40 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -9,16 +9,17 @@ module Dodge.Data.Universe ( module Dodge.Data.World, module Data.Preload, module Picture.Data, - module Loop.Data + module Loop.Data, ) where -import Loop.Data import Control.Lens --import qualified Data.Map.Strict as M import Data.Preload +import Data.Sequence (Seq (..)) import qualified Data.Text as T import Dodge.Data.Config import Dodge.Data.World +import Loop.Data import Picture.Data import SDL (Scancode) @@ -27,18 +28,19 @@ data Universe = Universe , _preloadData :: PreloadData , _uvScreenLayers :: [ScreenLayer] , _uvIOEffects :: Universe -> IO Universe - , _uvConcEffects :: ConcEffect + , _uvSideEffects :: Seq SideEffect , _uvConfig :: Configuration , _uvTestString :: Universe -> [String] , _uvCanContinue :: Bool , _uvMSeed :: Maybe Int } -data ConcEffect = NoConcEffect - | NewConcEffect {_ceFunction :: ConcurrentEffect Universe - , _ceString :: String, _ceIsBlocking :: Bool} - | BlockingConcEffect {_ceString :: String} - | BackgroundConcEffect {_ceString :: String} +data SideEffect + = NewSideEffect + { _ceSideEffect :: IO (Universe -> Maybe Universe) + , _ceString :: String + } + | RunningSideEffect {_ceString :: String} data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions deriving (Eq, Ord, Show, Read) --Generic, Flat) @@ -59,6 +61,7 @@ data ScreenLayer { _scInput :: T.Text , _scFooter :: String } + -- | WaitScreen -- { _scWaitMessage :: Universe -> String -- , _scWaitTime :: Int @@ -67,9 +70,10 @@ data ScreenLayer -- { _scDisplay :: Universe -> Picture -- } -data MenuOptionDisplay = MODString {_modString :: String} - | MODBlockedString {_modString :: String} - | MODStringOption {_modString :: String,_modOption :: String} +data MenuOptionDisplay + = MODString {_modString :: String} + | MODBlockedString {_modString :: String} + | MODStringOption {_modString :: String, _modOption :: String} data MenuOption = Toggle @@ -93,5 +97,5 @@ data IntID a = IntID Int a makeLenses ''Universe makeLenses ''ScreenLayer -makeLenses ''ConcEffect +makeLenses ''SideEffect makeLenses ''MenuOptionDisplay diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 33f7a419b..d9e9d6b17 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -71,7 +71,7 @@ saveQuit :: Universe -> IO (Maybe Universe) saveQuit u = return $ Just $ - u & tryConcEffect True "SAVING" (saveQuitConc u) + u & addSideEffect (saveQuitConc u) "SAVING" saveQuitConc :: Universe -> IO (Universe -> Maybe Universe) saveQuitConc u = do diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 91df5fa6b..ef3d77a02 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -26,14 +26,9 @@ fixedCoordPictures u = cfig = _uvConfig u drawConcurrentMessage :: Universe -> Picture -drawConcurrentMessage u = case u ^. uvConcEffects of - BlockingConcEffect str -> fillWidthText cfig str - --listPicturesAt - --(halfWidth cfig) - --(halfHeight cfig) - --cfig - --[centerText str] - BackgroundConcEffect str -> +drawConcurrentMessage u = case u ^? uvSideEffects . _head of + --Just (BlockingConcEffect str) -> fillWidthText cfig str + Just (RunningSideEffect str) -> listPicturesAt (halfWidth cfig) (_windowY cfig - 50) diff --git a/src/Dodge/Save.hs b/src/Dodge/Save.hs index b831bea71..4c4f7a939 100644 --- a/src/Dodge/Save.hs +++ b/src/Dodge/Save.hs @@ -18,6 +18,7 @@ import qualified Data.ByteString.Lazy as BS import Dodge.Data.Universe --import qualified Data.Set as S import System.Directory +--import Data.Sequence ((|>)) writeSaveSlot :: SaveSlot -> Universe -> IO (Universe -> Maybe Universe) @@ -52,13 +53,14 @@ saveSlotPath QuicksaveSlot = "saveSlot/QuickSave" saveSlotPath (LevelStartSlot i) = "saveSlot/LevelStart" ++ show i saveWorldInSlot :: SaveSlot -> Universe -> Universe -saveWorldInSlot slot u = tryConcEffect False "SAVING" (writeSaveSlot slot u) u +--saveWorldInSlot slot u = u & uvSideEffects %~ (|> NewSideEffect (writeSaveSlot slot u) "SAVING") +saveWorldInSlot slot u = u & addSideEffect (writeSaveSlot slot u) "SAVING" reloadLevelStart :: Universe -> Universe reloadLevelStart = loadSaveSlot (LevelStartSlot 0) loadSaveSlot :: SaveSlot -> Universe -> Universe -loadSaveSlot slot = tryConcEffect True "LOADING" (readSaveSlot slot) +loadSaveSlot slot = addSideEffect (readSaveSlot slot) "LOADING" doQuicksave :: Universe -> Universe doQuicksave = saveWorldInSlot QuicksaveSlot diff --git a/src/Dodge/StartNewGame.hs b/src/Dodge/StartNewGame.hs index 2c10a182f..b05a8021c 100644 --- a/src/Dodge/StartNewGame.hs +++ b/src/Dodge/StartNewGame.hs @@ -17,7 +17,7 @@ startNewGameInSlot slot u = startSeedGame slot i u i = fst $ randomR (0, maxBound) (_randGen (_uvWorld u)) startSeedGame :: Int -> Int -> Universe -> Universe -startSeedGame _ i = tryConcEffect True "GENERATING" (startSeedGameConc i) +startSeedGame _ i = addSideEffect (startSeedGameConc i) "GENERATING" startSeedGameConc :: Int -> IO (Universe -> Maybe Universe) startSeedGameConc seed = do diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index b6128348c..70e5d7302 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -93,7 +93,6 @@ updateUniverseLast = over uvWorld (input . mouseButtons . each .~ True) -- to de {- For most menus the only way to change the world is using event handling. -} updateUniverseMid :: Universe -> Universe updateUniverseMid u - | concurrentblocking = u | otherwise = case _uvScreenLayers u of (OptionScreen{_scOptionFlag = GameOverOptions} : _) -> u & uvWorld @@ -106,10 +105,6 @@ updateUniverseMid u ) (_ : _) -> u [] -> functionalUpdate'' u - where - concurrentblocking = case u ^. uvConcEffects of - BlockingConcEffect{} -> True - _ -> False functionalUpdate'' :: Universe -> Universe functionalUpdate'' = advanceScrollAmount . functionalUpdate' diff --git a/src/Loop.hs b/src/Loop.hs index eee9bc078..35ee24e35 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -161,7 +161,7 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go s return () let startWorld'' = case mconeff of NoConcurrentEffect -> sw - ConcurrentEffect immediatef _ -> immediatef sw + ConcurrentEffect immediatef _ -> immediatef mconupdate <- tryTakeMVar themvar let mstartWorld' = case mconupdate of Just conupdate -> conupdate startWorld'' diff --git a/src/Loop/Data.hs b/src/Loop/Data.hs index 9d38b1f99..fa15996a8 100644 --- a/src/Loop/Data.hs +++ b/src/Loop/Data.hs @@ -6,6 +6,6 @@ module Loop.Data where data ConcurrentEffect world = NoConcurrentEffect | ConcurrentEffect - { _immediateEffect :: world -> world + { _immediateUpdate :: world , _sideEffect :: IO (world -> Maybe world) }