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

Block screen during long loading

Browse Source
This commit is contained in:
justin
2022-12-29 00:44:51 +00:00
parent d1f80f1f7f
commit be41d51819
13 changed files with 90 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Beam.hs
+1 -1
View File
@@ -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
src/Dodge/Concurrent.hs
+5 -1
View File
@@ -1,4 +1,8 @@
module Dodge.Concurrent where
module Dodge.Concurrent
( hardQuit
, addSideEffect
, conEffects
) where
--import qualified Data.Set as S
import Control.Lens
src/Dodge/Data/Universe.hs
+1 -1
View File
@@ -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
src/Dodge/EnergyBall.hs
+7 -3
View File
@@ -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
src/Dodge/Flame.hs
+3 -3
View File
@@ -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)
src/Dodge/HeldUse.hs
+1 -1
View File
@@ -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
src/Dodge/Item/Info.hs
+12
View File
@@ -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"
src/Dodge/Luse.hs
+2 -1
View File
@@ -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'
src/Dodge/Menu/Loading.hs
+16
View File
@@ -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
}
src/Dodge/Spark.hs
+3 -3
View File
@@ -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)
src/Dodge/StartNewGame.hs
+8 -2
View File
@@ -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
src/Dodge/Tesla/Arc.hs
+10 -10
View File
@@ -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
src/Dodge/Update.hs
+21 -28
View File
@@ -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