Block screen during long loading

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

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

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

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)
+updateEnergyBall :: World -> EnergyBall -> (World, Maybe EnergyBall)
-moveEnergyBall w eb
+updateEnergyBall w eb
     | _ebTimer eb <= 0 = (w, Nothing)
     | otherwise =
         ( ebFlicker eb $ uncurry (damageCircle 5 (_ebPos eb)) (_ebEff eb) w

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)
+updateFlame :: World -> Flame -> (World, Maybe Flame)
-moveFlame w pt
+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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)
+updateSpark :: World -> Spark -> (World, Maybe Spark)
-moveSpark w sk
+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

@@ -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

@@ -1,14 +1,14 @@
-module Dodge.Tesla.Arc 
+module Dodge.Tesla.Arc (
-    ( shootTeslaArc'
+    makeTeslaArc,
-    , moveTeslaArc
+    updateTeslaArc,
-    ) where
+) 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)
+makeTeslaArc :: ItemParams -> Point2 -> Float -> World -> (World, ItemParams)
-shootTeslaArc' ip pos dir w =
+makeTeslaArc ip pos dir w =
     ( w & randGen .~ g
         & cWorld . lWorld . teslaArcs .:~ aTeslaArcAt col newarc
     , ip & currentArc ?~ newarc

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 
+    | x > xl && x < xr
-        && ylower == yupper 
+        && 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 :: CWorld -> CWorld
-updatePastWorlds w = w & cWorld . pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
+--updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. lWorld) :))
-
+updatePastWorlds w = w & pastWorlds .~ []
---updatePastWorlds w = w & cWorld . 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.  -}
+updateClouds :: World -> World
---updateParticles :: World -> World
+updateClouds = updateObjCatMaybes clouds updateCloud
---updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w'
+
---  where
---    (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
 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