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

Refactor concurrent side effects

Browse Source
This commit is contained in:
justin
2022-10-30 14:55:30 +00:00
parent 11e873ea48
commit 624a4c3bcd
10 changed files with 56 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Concurrent.hs
+27 -14
View File
@@ -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))
src/Dodge/Data/Universe.hs
+17 -13
View File
@@ -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
src/Dodge/Menu.hs
+1 -1
View File
@@ -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
src/Dodge/Render/Picture.hs
+3 -8
View File
@@ -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)
src/Dodge/Save.hs
+4 -2
View File
@@ -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
src/Dodge/StartNewGame.hs
+1 -1
View File
@@ -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
src/Dodge/Update.hs
-5
View File
@@ -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'