Add text messages on loading screens

src/Dodge/Concurrent.hs

@@ -32,9 +32,10 @@ addSideEffect f s = uvSideEffects %~ (|> NewSideEffect f s)
 hardQuit :: Universe -> Universe
 hardQuit = uvSideEffects %~ (HardQuit <|)
 
-blockingLoad :: String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
-blockingLoad str f u =
-    u & uvScreenLayers .:~ loadingScreen str
+blockingLoad 
+    :: [String] -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
+blockingLoad p str f u =
+    u & uvScreenLayers .:~ LoadingScreen p LoadWaiting
         & addSideEffect f str
 
 --hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
@@ -53,15 +54,3 @@ blockingLoad str f u =
 --    f <- eff
 --    return (f . (uvConcEffects .~ NoConcEffect))
 
-loadingScreen :: String -> ScreenLayer
-loadingScreen str =
-    OptionScreen
-        { _scTitle = str
-        , _scOptions = mempty
-        , _scOffset = 0
-        , _scPositionedMenuOption = NoExtraMenuOption
-        , _scOptionFlag = LoadingScreen
-        , _scSelectionList = mempty
-        , _scAvailableLines = 0
-        , _scDisplayTime = 0
-        }

src/Dodge/Data/GenWorld.hs

@@ -33,7 +33,6 @@ data PSType
     | PutMachine
         { _putMachinePoly :: [Point2]
         , _putMachineMachine :: Machine
---        , _putMachineWall :: Wall
         , _putMachineMaybeItem :: Maybe Item
         }
     | PutLS LightSource

src/Dodge/Data/Universe.hs

@@ -11,20 +11,21 @@ module Dodge.Data.Universe (
     module Loop.Data,
 ) where
 
-import qualified Data.IntMap.Strict as IM
-import Geometry.Data
-import Sound.Data
-import qualified Data.Map.Strict as M
-import GHC.Word (Word32)
-import Dodge.Data.SelectionList
 import Control.Lens
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map.Strict as M
 --import qualified Data.Map.Strict as M
 import Data.Preload
 import Data.Sequence (Seq (..))
 import Dodge.Data.Config
+import Dodge.Data.SelectionList
 import Dodge.Data.World
+import GHC.Word (Word32)
+import Geometry.Data
 import Loop.Data
 import Picture.Data
+import Sound.Data
+
 --import SDL (Scancode)
 
 data Universe = Universe
@@ -48,13 +49,13 @@ data Universe = Universe
     , _uvDebugPut :: IM.IntMap String
     , _uvDebugPathShowType :: PathShowType
     , _uvDebugMessageOffset :: Int
-    , _uvSoundQueue :: [SoundID]  -- sounds without a position, to be played once
+    , _uvSoundQueue :: [SoundID] -- sounds without a position, to be played once
     }
 
 data PathShowType
     = PathBetweenLeftRightClick
     | PathBetweenDebugV2s
-    deriving (Show,Eq,Ord,Enum,Bounded)
+    deriving (Show, Eq, Ord, Enum, Bounded)
 
 data DebugItem = DebugItem
     { _debugMessage :: String
@@ -69,13 +70,15 @@ data SideEffect
     | RunningSideEffect {_ceString :: String}
     | HardQuit
 
-data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
-    | LoadingScreen
+data OptionScreenFlag
+    = NormalOptions
+    | GameOverOptions
+    | SplashOptions
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data ExtraMenuOption
-    = BottomMenuOption { _emoMenuOption :: MenuOption }
-    | TopMenuOption { _emoMenuOption :: MenuOption }
+    = BottomMenuOption {_emoMenuOption :: MenuOption}
+    | TopMenuOption {_emoMenuOption :: MenuOption}
     | NoExtraMenuOption
 
 data ScreenLayer
@@ -85,11 +88,21 @@ data ScreenLayer
         , _scOffset :: Int
         , _scPositionedMenuOption :: ExtraMenuOption
         , _scOptionFlag :: OptionScreenFlag
-        , _scSelectionList :: [SelectionItem (Universe -> Universe,Universe->Universe)]
+        , _scSelectionList :: [SelectionItem (Universe -> Universe, Universe -> Universe)]
         , _scAvailableLines :: Int
         , _scDisplayTime :: Int
         }
-    | InputScreen { _scInput :: String }
+    | InputScreen {_scInput :: String}
+    | LoadingScreen 
+        { _scPara :: [String]
+        , _scBlockStatus :: BlockStatus
+        }
+
+data BlockStatus 
+    = LoadWaitingClicked
+    | LoadWaiting
+    | LoadReady
+    deriving (Show)
 
 data MenuOptionDisplay
     = MODString {_modString :: String}

src/Dodge/Data/World.hs

@@ -10,6 +10,7 @@ module Dodge.Data.World (
     module Dodge.Data.Input,
 ) where
 
+import Color.Data
 import qualified Data.IntMap.Strict as IM
 import NewInt
 import Control.Lens
@@ -81,6 +82,10 @@ data TimeFlowStatus
         { _timeFlowCharge :: Int
         , _scrollItemID :: NewInt ItmInt
         }
+    | PauseTimeMessage
+        { _pauseTimeMesage :: String
+        , _pauseTimeMesageColor :: Color
+        }
 
 makeLenses ''TimeFlowStatus
 makeLenses ''World

src/Dodge/Initialisation.hs

@@ -8,9 +8,7 @@ import qualified IntMapHelp as IM
 import Dodge.SpawnAt
 
 splashScreen :: World
-splashScreen = 
-    defaultWorld
-        & cWorld . lWorld . creatures .~ IM.fromList [(0, startCr)]
+splashScreen = defaultWorld & cWorld . lWorld . creatures .~ IM.fromList [(0, startCr)]
 
 initialWorld :: World
 initialWorld = respawn defaultWorld

src/Dodge/Placement/Instance/Analyser.hs

@@ -28,5 +28,5 @@ analyserWithPrompt l pst pslight psmc = extTrigLitPos pslight $ \tp ->
     themachine =
         defaultMachine & mcColor .~ aquamarine
             & mcType .~ McTerminal
-            & mcHP .~ 100
+            & mcHP .~ 10000
             & mcType .~ McProxSensor (ProxSensor pst Nothing)

src/Dodge/Render.hs

@@ -201,10 +201,10 @@ doDrawing' win pdata u = do
 
     --setup downscale viewport for blurring bloom
     setViewport _gr_downsize_res cfig
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboHalf pdata)))
+    glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboHalf . _1 . unFBO
     glDepthFunc GL_ALWAYS
-    glBindTextureUnit 0 (pdata ^. fboBloom . _2 . unTO)
     glGenerateTextureMipmap (pdata ^. fboBloom . _2 . unTO)
+    glBindTextureUnit 0 (pdata ^. fboBloom . _2 . unTO)
     glDisable GL_BLEND
     -- this all needs more tuning + more thought
     -- a fade effect would be cool, so not to fully reset last frames bloom
@@ -398,7 +398,8 @@ doDrawing' win pdata u = do
             glDrawArrays GL_TRIANGLES 0 6
     glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
     -- draw the overlay
-    glDepthFunc GL_ALWAYS
+    glDepthFunc GL_LEQUAL
+    --glDepthFunc GL_ALWAYS
     glDepthMask GL_FALSE
     glEnable GL_BLEND
     --glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
@@ -406,9 +407,8 @@ doDrawing' win pdata u = do
     renderLayer DebugLayer shadV pokeCounts
     withArray (scaleMatrix (2 / windowXFloat cfig) (2 / windowYFloat cfig)) $
         glNamedBufferSubData (pdata ^. matUBO) 0 64
-    glDepthFunc GL_GEQUAL
     glDepthMask GL_TRUE
-    with (-1) $ glClearNamedFramebufferfv 0 GL_DEPTH 0
+    with 1 $ glClearNamedFramebufferfv 0 GL_DEPTH 0
     renderLayer FixedCoordLayer shadV pokeCounts
     checkGLError "during doDrawing'"
     SDL.glSwapWindow win

src/Dodge/Render/MenuScreen.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE LambdaCase #-}
 module Dodge.Render.MenuScreen (drawMenuScreen) where
 
+import Geometry.Polygon
+import Linear
+import Dodge.Data.ScreenPos
 import Control.Lens
 import Dodge.Base.Window
 import Dodge.Data.CardinalPoint
@@ -15,6 +18,15 @@ drawMenuScreen :: Maybe Int -> ScreenLayer -> Config -> Picture
 drawMenuScreen mi = \case
     OptionScreen{_scTitle = s, _scSelectionList = l} -> drawOptions s mi l
     InputScreen inputstr -> drawInputMenu ('>' : inputstr)
+    LoadingScreen ss t -> drawLoadingScreen ss t
+
+drawLoadingScreen :: [String] -> BlockStatus -> Config -> Picture
+drawLoadingScreen s _ cfig = 
+    polygon (rectWH (fromIntegral (cfig ^.windowX)) (fromIntegral (cfig ^. windowY))) <>
+    translateScreenPos cfig
+    (ScreenPos (V2 0 0.2) (V2 (-300) (10 * fromIntegral (length s))))
+    (drawList $ map text s -- <> [text $ show t])
+    )
 
 drawInputMenu :: String -> Config -> Picture
 drawInputMenu s cf = darkenBackground cf <> drawTitle cf s

src/Dodge/Room/Tutorial.hs

@@ -263,8 +263,8 @@ tutHub = do
             =<< roomNgon 6 100
     bcor <- treeAttachDeep (return door) <$> blockedCorridor
     --bcor <- treeAttachDeep (return door) <$> return (return $ cleatOnward door)
-    r1 <- r burstRifle <&> rmPmnts .:~ t
-    r2 <- r (drumMag & itConsumables ?~ 90)
+    r1 <- r burstRifle <&> rmPmnts .:~ itemshiftterminal
+    r2 <- ammoroom (drumMag & itConsumables ?~ 90) -- <&> rmPmnts .:~ tutorialterminal
     --r2 <- r (tinMag & itConsumables ?~ 500)
     return $
         tToBTree "DoorTest" $
@@ -290,7 +290,8 @@ tutHub = do
         , makeTermLine ""
         ]
     r x = roomRectAutoLinks 100 100 <&> rmPmnts .:~ sps (PS 50 0) (PutFlIt x)
-    t =
+    ammoroom x = roomRectAutoLinks 100 100 <&> rmPmnts .:~ sps (PS 50 0) (PutFlIt x)
+    itemshiftterminal =
         putMessageTerminal
             terminalColor
             (defaultTerminal & tmBootLines .~ ss' <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)

src/Dodge/Save.hs

@@ -72,7 +72,7 @@ reloadLevelStart :: Universe -> Universe
 reloadLevelStart = loadSaveSlot (LevelStartSlot 0)
 
 loadSaveSlot :: SaveSlot -> Universe -> Universe
-loadSaveSlot slot = blockingLoad ("DESERIALISING " ++ show slot) $ readSaveSlot slot
+loadSaveSlot slot = blockingLoad [] ("DESERIALISING " ++ show slot) $ readSaveSlot slot
 
 doQuicksave :: Universe -> Universe
 doQuicksave u =

src/Dodge/StartNewGame.hs

@@ -8,9 +8,10 @@ import Dodge.Data.Universe
 import Dodge.LevelGen
 import Dodge.Save
 import Dodge.WorldLoad
+import Justify
 import LensHelp
-import System.Random
 import System.Directory
+import System.Random
 
 startNewGameInSlot :: Int -> Universe -> Universe
 startNewGameInSlot slot u = startSeedGame slot i u
@@ -20,10 +21,28 @@ startNewGameInSlot slot u = startSeedGame slot i u
 startSeedGame :: Int -> Int -> Universe -> Universe
 startSeedGame _ i u =
     blockingLoad
+        startPara
         ("GENERATING FROM SEED " ++ show i)
         (startSeedGameConc i $ u ^. preloadData)
         u
 
+startPara :: [String]
+startPara =
+    [ "Something has gone wrong."
+    , ""
+    , ""
+    , ""
+    ]
+        <> makeParagraph
+            55
+            ( "My last memory is the reconstitution scan. "
+            <> "Though experimental, this techology allows for perfect duplication. "
+            <> "At least in theory, "
+            <> "it hasn't been tested on humans. "
+            <> "I'd only be duplicated if my original body was...  non-functional."
+            )
+        <> ["", "","", "Hopefully I can take better care of this one."]
+
 startSeedGameConc :: Int -> PreloadData -> IO (Universe -> Maybe Universe)
 startSeedGameConc seed pdata = do
     w <- generateWorldFromSeed (pdata ^?! renderData) seed
@@ -32,6 +51,11 @@ startSeedGameConc seed pdata = do
     return $
         Just
             . saveWorldInSlot (LevelStartSlot 0)
-            . (uvScreenLayers .~ [])
+            . maybeClearLoadingScreen
             . (uvWorld .~ w)
             . postUniverseLoadSideEffect
+
+maybeClearLoadingScreen :: Universe -> Universe
+maybeClearLoadingScreen u = case u ^? uvScreenLayers . ix 0 . scBlockStatus of
+    Just LoadWaitingClicked -> u & uvScreenLayers .~ []
+    _ -> u & uvScreenLayers . ix 0 . scBlockStatus .~ LoadReady

src/Dodge/TestString.hs

@@ -32,12 +32,7 @@ import Data.Foldable
 import Data.Monoid
 
 testStringInit :: Universe -> [String]
-testStringInit u =  [ show (u ^. uvConfig . windowX)
-    , show (u ^. uvConfig . windowY)
-    ,show $ fmap (
-     worldPosToScreen (u ^. uvWorld . wCam) )
-    $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crPos . _xy
- ]
+testStringInit _ =  []
 --    [show $ foldMap (foldMap (Sum . length . (^. seObstacles))) 
 --    $ u ^. uvWorld . cWorld . incGraph]
     -- foldMap prettyShort $ u ^? uvWorld . cWorld . lWorld . machines . ix 0 . mcType . _McProxSensor
@@ -81,3 +76,4 @@ showTimeFlow tfs = case tfs of
     CameraScrollTimeFlow {_reverseAmount = ra } -> "CameraScrollTimeFlow" ++ show ra
     RewindLeftClick {_reverseAmount = ra } -> "RewindLeftClick" ++ show ra
     PausedTimeFlow {_timeFlowCharge = ra } -> "PausedTimeFlow" ++ show ra
+    PauseTimeMessage {} -> "PausedTimeMessage"

src/Dodge/Update.hs

@@ -136,7 +136,7 @@ openConsole = \case
 updateUniverseLast :: Universe -> Universe
 updateUniverseLast u =
     u
-        & over (uvWorld . input . textInput) (const mempty)
+        & uvWorld . input . textInput .~ mempty
         & maybeOpenConsole
         & advanceScrollAmount
         & updateWorldEventFlags
@@ -155,7 +155,6 @@ updateUniverseLast u =
 {- 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
     (sl : _) -> u & uvWorld . unpauseClock .~ 0 & updateUseInputOnScreen sl
     [] ->
         (uvWorld . unpauseClock +~ 1)
@@ -178,6 +177,7 @@ timeFlowUpdate u = case u ^. uvWorld . timeFlow of
     RewindLeftClick _ _ -> over uvWorld scrollTimeBack u
     RespawnDelay{} -> functionalUpdate u
     PausedTimeFlow _ itmloc -> over uvWorld (pauseTime itmloc) u
+    PauseTimeMessage {} -> u
 
 pauseTime :: NewInt ItmInt -> World -> World
 pauseTime _ w

src/Dodge/Update/Input/ScreenLayer.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module Dodge.Update.Input.ScreenLayer (
     updateUseInputOnScreen,
     ldpSelection,
@@ -21,9 +22,18 @@ import Linear
 import SDL
 
 updateUseInputOnScreen :: ScreenLayer -> Universe -> Universe
-updateUseInputOnScreen sl = case sl of
-    InputScreen{} -> doInputScreenInput (sl ^. scInput)
-    _ -> optionScreenUpdate
+updateUseInputOnScreen = \case
+    InputScreen{_scInput = s} -> doInputScreenInput s
+    OptionScreen{} -> optionScreenUpdate
+    LoadingScreen{} -> loadingScreenUpdate
+
+loadingScreenUpdate :: Universe -> Universe
+loadingScreenUpdate u
+    | isJust $ u ^. uvWorld . input . pressedKeys . at ScancodeSpace
+        = case u ^? uvScreenLayers . ix 0 . scBlockStatus of 
+            Just LoadReady -> u & uvScreenLayers .~ []
+            _ -> u & uvScreenLayers . ix 0 . scBlockStatus .~ LoadWaitingClicked
+    | otherwise = u
 
 doInputScreenInput :: String -> Universe -> Universe
 doInputScreenInput s u =

src/Dodge/Wall/Damage.hs

@@ -34,8 +34,7 @@ damageWall wlid dt w = fromMaybe (mempty,w) $ do
         MachinePart mcid -> (,) mempty 
             $ w' & cWorld . lWorld . machines . ix mcid . mcDamage .:~ dt
         BlockPart blid ->
-            w' & damageBlock (wl ^. wlMaterial) dmam blid -- cWorld . lWorld . blocks . ix blid . blHP -~ dmam
---                & maybeDestroyBlock blid
+            w' & damageBlock (wl ^. wlMaterial) dmam blid
         DoorPart drid _ ->
             w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam
                 & maybeDestroyDoor drid

src/Loop.hs

@@ -242,7 +242,8 @@ doConLoop' ::
     -- | Current simulation state.
     world ->
     IO ()
-doConLoop' themvar spf window coneffs worldSideEffects eventFn !startWorld = go startWorld
+--doConLoop' themvar spf window coneffs worldSideEffects eventFn !startWorld = go startWorld
+doConLoop' themvar spf window coneffs worldSideEffects eventFn = go
   where
     worldSideEffectsWindow = worldSideEffects window
     go sw = do