From be41d5181971ef920bf5c990894e4772e96b1e39 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 29 Dec 2022 00:44:51 +0000 Subject: [PATCH] Block screen during long loading --- src/Dodge/Beam.hs | 2 +- src/Dodge/Concurrent.hs | 6 ++++- src/Dodge/Data/Universe.hs | 2 +- src/Dodge/EnergyBall.hs | 10 +++++--- src/Dodge/Flame.hs | 6 ++--- src/Dodge/HeldUse.hs | 2 +- src/Dodge/Item/Info.hs | 12 ++++++++++ src/Dodge/Luse.hs | 3 ++- src/Dodge/Menu/Loading.hs | 16 +++++++++++++ src/Dodge/Spark.hs | 6 ++--- src/Dodge/StartNewGame.hs | 10 ++++++-- src/Dodge/Tesla/Arc.hs | 20 ++++++++-------- src/Dodge/Update.hs | 49 ++++++++++++++++---------------------- 13 files changed, 90 insertions(+), 54 deletions(-) create mode 100644 src/Dodge/Item/Info.hs create mode 100644 src/Dodge/Menu/Loading.hs diff --git a/src/Dodge/Beam.hs b/src/Dodge/Beam.hs index 3d35e108c..c231c664a 100644 --- a/src/Dodge/Beam.hs +++ b/src/Dodge/Beam.hs @@ -54,7 +54,7 @@ teslaBeamCombine (p, (a, b, bm), (x, y, _)) w = where itid = fromJust $ _bmOrigin bm dir = argV (normalizeV (b -.- a) +.+ normalizeV (y -.- x)) - (w', ip) = shootTeslaArc' (fromJust . _subParams $ _itParams it) p dir w + (w', ip) = makeTeslaArc (fromJust . _subParams $ _itParams it) p dir w it = case getItem itid w of Nothing -> error "tried to get item use teslaBeamCombine that doesn't exist" Just itm -> itm diff --git a/src/Dodge/Concurrent.hs b/src/Dodge/Concurrent.hs index d335b77ed..39122d2b9 100644 --- a/src/Dodge/Concurrent.hs +++ b/src/Dodge/Concurrent.hs @@ -1,4 +1,8 @@ -module Dodge.Concurrent where +module Dodge.Concurrent + ( hardQuit + , addSideEffect + , conEffects + ) where --import qualified Data.Set as S import Control.Lens diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index c2722c2ae..746b4f477 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -46,6 +46,7 @@ data SideEffect | HardQuit data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions + | LoadingScreen deriving (Eq, Ord, Show, Read) --Generic, Flat) data PositionedMenuOption @@ -68,7 +69,6 @@ data ScreenLayer { _scInput :: T.Text , _scFooter :: String } - -- | WaitScreen -- { _scWaitMessage :: Universe -> String -- , _scWaitTime :: Int diff --git a/src/Dodge/EnergyBall.hs b/src/Dodge/EnergyBall.hs index 998420bc7..8dae22dd1 100644 --- a/src/Dodge/EnergyBall.hs +++ b/src/Dodge/EnergyBall.hs @@ -1,4 +1,8 @@ -module Dodge.EnergyBall where +module Dodge.EnergyBall + ( updateEnergyBall + , incBallAt + , makeFlamelet + ) where import Dodge.DamageCircle import Dodge.Data.World @@ -38,8 +42,8 @@ makeFlamelet (V2 x y) z vel size time w = where (rot, g) = randomR (0, 3) $ _randGen w -moveEnergyBall :: World -> EnergyBall -> (World, Maybe EnergyBall) -moveEnergyBall w eb +updateEnergyBall :: World -> EnergyBall -> (World, Maybe EnergyBall) +updateEnergyBall w eb | _ebTimer eb <= 0 = (w, Nothing) | otherwise = ( ebFlicker eb $ uncurry (damageCircle 5 (_ebPos eb)) (_ebEff eb) w diff --git a/src/Dodge/Flame.hs b/src/Dodge/Flame.hs index 1e4e409eb..d746cc459 100644 --- a/src/Dodge/Flame.hs +++ b/src/Dodge/Flame.hs @@ -1,7 +1,7 @@ module Dodge.Flame ( aFlameParticle, makeFlame, - moveFlame, + updateFlame, ) where import Dodge.Data.World @@ -68,8 +68,8 @@ doDamagesFL fdm (p, thhit) bt = case thhit of dams = fdm bt p {- TODO: add generalised area damage particles/hiteffects. -} -moveFlame :: World -> Flame -> (World, Maybe Flame) -moveFlame w pt +updateFlame :: World -> Flame -> (World, Maybe Flame) +updateFlame w pt | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing) | otherwise = case List.safeHead $ thingsHit sp ep w of Just (_, Left _) -> (doSound $ dodamage w, mvPt' 0.7) diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index a9ebc8405..2a8e17484 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -501,6 +501,6 @@ shootTeslaArc it cr w = w' & cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itParams .~ ip where - (w', ip) = shootTeslaArc' (_itParams it) pos dir w + (w', ip) = makeTeslaArc (_itParams it) pos dir w pos = _crPos cr +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir dir = _crDir cr diff --git a/src/Dodge/Item/Info.hs b/src/Dodge/Item/Info.hs new file mode 100644 index 000000000..4f3055599 --- /dev/null +++ b/src/Dodge/Item/Info.hs @@ -0,0 +1,12 @@ +module Dodge.Item.Info where + +import Dodge.Data.Item + +itmBaseInfo :: ItemBaseType -> String +itmBaseInfo t = case t of + HELD _ -> "THIS ITEM CAN BE HELD." + LEFT _ -> "THIS ITEM CAN BE EQUIPPED. WHEN EQUIPPED, IT CAN BE ACTIVATED." + EQUIP _ -> "THIS ITEM CAN BE EQUIPPED." + Consumable _ -> "THIS ITEM CAN BE CONSUMED." + CRAFT _ -> "THIS ITEM SEEMS USELESS ON ITS OWN." + _ -> "THIS SHOULD NOT BE DISPLAYED" diff --git a/src/Dodge/Luse.hs b/src/Dodge/Luse.hs index b5bcdbaea..98d7aaa69 100644 --- a/src/Dodge/Luse.hs +++ b/src/Dodge/Luse.hs @@ -29,7 +29,8 @@ useTimeScrollGun itm _ w = w & cWorld . timeFlow .~ ScrollTimeFlow } useRewindGun :: Item -> Creature -> World -> World -useRewindGun itm _ w = w & cWorld . timeFlow .~ RewindLeftClick (itm ^?! itUse . leftConsumption . wpCharge) +useRewindGun itm _ w = w + & cWorld . timeFlow .~ RewindLeftClick (itm ^?! itUse . leftConsumption . wpCharge) --useRewindGun _ _ w = case w ^. cwTime . rewindWorlds of -- [w'] -> w & cwTime . maybeWorld .~ Just' w' diff --git a/src/Dodge/Menu/Loading.hs b/src/Dodge/Menu/Loading.hs new file mode 100644 index 000000000..b2c156889 --- /dev/null +++ b/src/Dodge/Menu/Loading.hs @@ -0,0 +1,16 @@ +module Dodge.Menu.Loading where + +import Dodge.Menu.Option +import Dodge.Data.Universe + +loadingScreen :: String -> ScreenLayer +loadingScreen str = OptionScreen + { _scTitle = str + , _scOptions = [] + , _scOffset = 0 + , _scPositionedMenuOption = NoPositionedMenuOption + , _scOptionFlag = LoadingScreen + , _scSelectionList = SelectionList [] Nothing 0 + , _scAvailableLines = 0 + , _scListDisplayParams = optionListDisplayParams + } diff --git a/src/Dodge/Spark.hs b/src/Dodge/Spark.hs index 8e302f3e2..c385c6133 100644 --- a/src/Dodge/Spark.hs +++ b/src/Dodge/Spark.hs @@ -1,5 +1,5 @@ module Dodge.Spark ( - moveSpark, + updateSpark, colSpark, colSparkRandDir, createBarrelSpark, @@ -16,8 +16,8 @@ import Geometry import LensHelp import System.Random -moveSpark :: World -> Spark -> (World, Maybe Spark) -moveSpark w sk +updateSpark :: World -> Spark -> (World, Maybe Spark) +updateSpark w sk | magV (_skVel sk) < 1 = (w, Nothing) | otherwise = case thingHit sp ep w of Nothing -> (w, Just $ sk & skPos .~ ep & skVel .*.*~ 0.9 & skOldPos .~ sp) diff --git a/src/Dodge/StartNewGame.hs b/src/Dodge/StartNewGame.hs index b05a8021c..d0c9be91d 100644 --- a/src/Dodge/StartNewGame.hs +++ b/src/Dodge/StartNewGame.hs @@ -3,9 +3,10 @@ module Dodge.StartNewGame ( startSeedGame, ) where +import Dodge.Menu.Loading import Dodge.Concurrent --import Dodge.Menu.Option -import Control.Lens +import LensHelp import Dodge.Data.Universe import Dodge.LevelGen import Dodge.Save @@ -16,8 +17,13 @@ startNewGameInSlot slot u = startSeedGame slot i u where i = fst $ randomR (0, maxBound) (_randGen (_uvWorld u)) + +blockingLoad :: String -> IO (Universe -> Maybe Universe) -> Universe -> Universe +blockingLoad str f u = u & uvScreenLayers .:~ loadingScreen str + & addSideEffect f str + startSeedGame :: Int -> Int -> Universe -> Universe -startSeedGame _ i = addSideEffect (startSeedGameConc i) "GENERATING" +startSeedGame _ i = blockingLoad "LOADING" (startSeedGameConc i) startSeedGameConc :: Int -> IO (Universe -> Maybe Universe) startSeedGameConc seed = do diff --git a/src/Dodge/Tesla/Arc.hs b/src/Dodge/Tesla/Arc.hs index 4e2861f56..60e5e8594 100644 --- a/src/Dodge/Tesla/Arc.hs +++ b/src/Dodge/Tesla/Arc.hs @@ -1,14 +1,14 @@ -module Dodge.Tesla.Arc - ( shootTeslaArc' - , moveTeslaArc - ) where +module Dodge.Tesla.Arc ( + makeTeslaArc, + updateTeslaArc, +) where import Data.Foldable -import Dodge.Data.CrWlID -import Dodge.Data.ArcStep import Data.Maybe import Dodge.ArcStep import Dodge.Damage +import Dodge.Data.ArcStep +import Dodge.Data.CrWlID import Dodge.Data.World import Dodge.Spark import Geometry @@ -26,11 +26,11 @@ aTeslaArcAt col thearc = , _taColor = brightX 100 1.5 col } -moveTeslaArc :: +updateTeslaArc :: World -> TeslaArc -> (World, Maybe TeslaArc) -moveTeslaArc w pt +updateTeslaArc w pt | _taTimer pt == 2 = (makesparks $ foldl' (flip damthings) w thearc, Just $ pt & taTimer -~ 1) | _taTimer pt < 1 = (w, Nothing) | otherwise = (w, Just $ pt & taTimer -~ 1) @@ -54,8 +54,8 @@ moveTeslaArc w pt where q = 5 *.* unitVectorAtAngle dir -shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World, ItemParams) -shootTeslaArc' ip pos dir w = +makeTeslaArc :: ItemParams -> Point2 -> Float -> World -> (World, ItemParams) +makeTeslaArc ip pos dir w = ( w & randGen .~ g & cWorld . lWorld . teslaArcs .:~ aTeslaArcAt col newarc , ip & currentArc ?~ newarc diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 0a2b79451..71fba3de2 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -65,7 +65,8 @@ import qualified IntMapHelp as IM import LensHelp import SDL import Sound.Data -import StrictHelp + +--import StrictHelp updateUniverse :: Universe -> Universe updateUniverse u = @@ -103,8 +104,8 @@ mouseClickOptionsList screen u = fromMaybe u $ do mouseOverSelectionList :: ListDisplayParams -> SelectionList (Universe -> Universe) -> Universe -> Universe mouseOverSelectionList ldps sl u - | x > xl && x < xr - && ylower == yupper + | x > xl && x < xr + && ylower == yupper && mmoving && ylower >= 0 && ylower < ymax @@ -179,6 +180,7 @@ updateUniverseLast = {- For most menus the only way to change the world is using event handling. -} updateUniverseMid :: Universe -> Universe updateUniverseMid u = case _uvScreenLayers u of + (OptionScreen{_scOptionFlag = LoadingScreen} : _) -> u (OptionScreen{_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~ ( @@ -268,7 +270,6 @@ functionalUpdate w = . over uvWorld updateFlames . over uvWorld updateShockwaves . over uvWorld updateEnergyBalls - -- . over uvWorld updateParticles . over uvWorld updateBullets . over uvWorld updateRadarBlips . over uvWorld updateFlares @@ -298,7 +299,7 @@ functionalUpdate w = . over uvWorld updateCloseObjects . over uvWorld updateWheelEvents -- . over uvWorld updateInventorySelectionList - $ over uvWorld updatePastWorlds w + $ over (uvWorld . cWorld) updatePastWorlds w --updateInventorySelectionList :: World -> World --updateInventorySelectionList w = w @@ -334,10 +335,9 @@ advanceScrollAmount u = & uvWorld . input . previousScrollAmount .~ _scrollAmount (_input $ _uvWorld u) & uvWorld . input . scrollAmount .~ 0 -updatePastWorlds :: World -> World -updatePastWorlds w = w & cWorld . pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :)) - ---updatePastWorlds w = w & cWorld . pastWorlds .~ [] +updatePastWorlds :: CWorld -> CWorld +--updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. lWorld) :)) +updatePastWorlds w = w & pastWorlds .~ [] moveHammersUp :: Universe -> Universe --moveHammersUp = uvWorld . hammers .~ M.empty @@ -494,52 +494,48 @@ updateObjCatMaybes p f w = w' & cWorld . lWorld . p #~ catMaybes newxs updateDistortions :: World -> World updateDistortions = updateObjMapMaybe distortions updateDistortion ---updateDistortions = cWorld . lWorld . distortions %~ mapMaybe updateDistortion - updateLightSources :: World -> World updateLightSources = updateObjMapMaybe tempLightSources (\b -> updateTempLightSource (_tlsUpdate b) b) -updateTeslaArcs :: World -> World -updateTeslaArcs = updateObjCatMaybes teslaArcs moveTeslaArc - updateRadarBlips :: World -> World updateRadarBlips = updateObjMapMaybe radarBlips updateRadarBlip updateFlares :: World -> World updateFlares = updateObjMapMaybe flares updateFlare -updateTractorBeams :: World -> World -updateTractorBeams = updateObjCatMaybes tractorBeams updateTractorBeam - {- Apply internal particle updates, delete 'Nothing's. -} updateBullets :: World -> World updateBullets w = updateInstantBullets $ set (cWorld . lWorld . bullets) (catMaybes ps) w' where (w', ps) = mapAccumR updateBullet w $ w ^. cWorld . lWorld . bullets +updateTeslaArcs :: World -> World +updateTeslaArcs = updateObjCatMaybes teslaArcs updateTeslaArc + +updateTractorBeams :: World -> World +updateTractorBeams = updateObjCatMaybes tractorBeams updateTractorBeam + updateShockwaves :: World -> World updateShockwaves = updateObjCatMaybes shockwaves updateShockwave updateFlames :: World -> World -updateFlames = updateObjCatMaybes flames moveFlame +updateFlames = updateObjCatMaybes flames updateFlame updateEnergyBalls :: World -> World -updateEnergyBalls = updateObjCatMaybes energyBalls moveEnergyBall +updateEnergyBalls = updateObjCatMaybes energyBalls updateEnergyBall updateRadarSweeps :: World -> World updateRadarSweeps = updateObjCatMaybes radarSweeps updateRadarSweep updateSparks :: World -> World -updateSparks = updateObjCatMaybes sparks moveSpark +updateSparks = updateObjCatMaybes sparks updateSpark updatePosEvents :: World -> World updatePosEvents = updateObjCatMaybes posEvents updatePosEvent -{- Apply internal particle updates, delete 'Nothing's. -} ---updateParticles :: World -> World ---updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w' --- where --- (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w +updateClouds :: World -> World +updateClouds = updateObjCatMaybes clouds updateCloud + updateBeams :: World -> World updateBeams w = w @@ -683,9 +679,6 @@ mvGust _ gu & guPos .+.+~ _guVel gu & guTime -~ 1 -updateClouds :: World -> World -updateClouds = updateObjCatMaybes clouds updateCloud - cloudEffect :: Cloud -> World -> World cloudEffect cl = case _clType cl of GasCloud -> cloudPoisonDamage cl