detailed loading output

src/Floorplan.hs

@@ -2,6 +2,7 @@ module Floorplan where
 
 import Data.Matrix (Matrix(..))
 import qualified Data.Matrix as M
+import qualified Data.Text as T
 import Data.Maybe
 
 import Control.Monad (foldM)
@@ -13,28 +14,55 @@ import Types.Map
 
 buildHallFloorIO
   :: FloorConfig
-  -> MVar Float
+  -> MVar (Float, T.Text)
   -> Float
   -> IO (Matrix TileState, [Graph])
 buildHallFloorIO fc progress increment = do
   rand <- newStdGen
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "New RNG"
+    )))
   let empty         = emptyFloor fc
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Built empty floor"
+    )))
   let (g1, withElv) = buildElevator fc (placeHalls rand fc empty)
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Placed Elevator"
+    )))
   let (g2, withIW)  = buildInnerWalls g1 withElv
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Built inner walls"
+    )))
   let withOW        = buildOuterWalls withIW
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "built outer walls"
+    )))
   let closed        = closeOffices withOW
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Closed offices"
+    )))
   let doorgraph     = buildDoorsGraph closed
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Doorgraph"
+    )))
   doors <- buildDoors closed doorgraph
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Build doors"
+    )))
   let (_, facils)  = buildFacilities g2 fc doors
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Build facilities"
+    )))
   return (facils, doorgraph)
 
 emptyFloor :: FloorConfig -> Matrix TileState

src/Load.hs

@@ -10,6 +10,7 @@ import Control.Concurrent.MVar
 import Control.Monad (when)
 
 import qualified Data.Map as M
+import qualified Data.Text as T
 import Data.Ecstasy
 import Data.Maybe
 
@@ -27,7 +28,7 @@ loadLoad :: Affection UserData ()
 loadLoad = do
   ad <- A.get
   ud <- getAffection
-  progress <- liftIO $ newMVar 0
+  progress <- liftIO $ newMVar (0, "Starting up")
   future <- liftIO $ newEmptyMVar
   _ <- liftIO $ createFont (nano ud) "bedstead"
     (FileName "assets/font/Bedstead-Semicondensed.ttf")
@@ -55,47 +56,101 @@ loadFork
   -> SDL.GLContext
   -> Context
   -> MVar (SystemState Entity IO, StateData)
-  -> MVar Float
+  -> MVar (Float, T.Text)
   -> IO ()
 loadFork ws win glc nvg future progress = do
   let stateSteps = 22
       increment = 1 / stateSteps
   SDL.glMakeCurrent win glc
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_asc\""
+    )))
   mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_desc\""
+    )))
   mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_corner_n\""
+    )))
   mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_corner_e\""
+    )))
   mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_corner_s\""
+    )))
   mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_corner_w\""
+    )))
   mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_t_ne\""
+    )))
   mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_t_se\""
+    )))
   mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_t_sw\""
+    )))
   mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_t_nw\""
+    )))
   mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_cross\""
+    )))
   mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"box1\""
+    )))
   mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"table1\""
+    )))
   mmisctable1 <- createImage nvg (FileName "assets/misc/table1.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"table2\""
+    )))
   mmisctable2 <- createImage nvg (FileName "assets/misc/table2.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"table3\""
+    )))
   mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"wall_table4\""
+    )))
   mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading asset \"tableCorner\""
+    )))
   mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading Animation \"intruder: standing\""
+    )))
   let mimgs = [ mwallasc, mwalldesc,
        mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
         mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,
@@ -119,16 +174,28 @@ loadFork ws win glc nvg future progress = do
         [0 .. length (walkIds 0) - 1]
   playerStanding <- loadAnimationSprites "assets/intruder.png" nvg
     (zip (standIds 0) standConfigs)
-  liftIO $modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading Animation \"intruder: walking\""
+    )))
   playerWalking <- loadAnimationSprites "assets/intruder.png" nvg
     (zip (walkIds 0) walkConfigs)
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading Animation \"jdoem: standing\""
+    )))
   jdoemStanding <- loadAnimationSprites "assets/jdoem.png" nvg
     (zip (standIds 1) standConfigs)
-  liftIO $modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading Animation \"jdoem: walking\""
+    )))
   jdoemWalking <- loadAnimationSprites "assets/jdoem.png" nvg
     (zip (walkIds 1) walkConfigs)
-  modifyMVar_ progress (return . (+ increment))
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Handing over"
+    )))
   finish
   putMVar future
     ( ws

src/MainGame/WorldMap.hs

@@ -44,7 +44,7 @@ loadMap = do
   uu1 <- partSubscribe m movePlayer
   uu2 <- partSubscribe k changeMaps
   future <- liftIO newEmptyMVar
-  progress <- liftIO $ newMVar 0
+  progress <- liftIO $ newMVar (0, "Ohai!")
   _ <- liftIO $ forkIO $ loadMapFork ud future progress
   putAffection ud
     { stateData = None
@@ -71,7 +71,7 @@ changeMaps _ = return ()
 loadMapFork
   :: UserData
   -> MVar (SystemState Entity IO, StateData)
-  -> MVar Float
+  -> MVar (Float, T.Text)
   -> IO ()
 loadMapFork ud future progress = do
   let loadSteps = 18
@@ -79,9 +79,9 @@ loadMapFork ud future progress = do
         (10, 10)
         [(5, 5), (5, 45)]
         (50, 50)
-  _ <- liftIO $ swapMVar progress (1 / loadSteps)
+  _ <- liftIO $ swapMVar progress (1 / loadSteps, "Building floor")
   (mat, gr) <- buildHallFloorIO fc progress (1 / loadSteps)
-  _ <- liftIO $ swapMVar progress (11 / loadSteps)
+  _ <- liftIO $ swapMVar progress (11 / loadSteps, "Converting to images")
   let imgmat = convertTileToImg mat
       exits = Prelude.foldl
         (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
@@ -90,19 +90,19 @@ loadMapFork ud future progress = do
           )
         []
         ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
-  _ <- liftIO $ swapMVar progress (12 / loadSteps)
+  _ <- liftIO $ swapMVar progress (12 / loadSteps, "Placing furniture")
   (inter, rps) <- placeInteriorIO mat imgmat exits gr
-  _ <- liftIO $ swapMVar progress (13 / loadSteps)
+  _ <- liftIO $ swapMVar progress (13 / loadSteps, "Placing NPCs")
   logIO A.Debug ("number of reachpoints: " ++ show (length rps))
   let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
-  npcposs <- placeNPCs inter mat rps 75 -- (length nnex)
+  npcposs <- placeNPCs inter mat rps 100 -- (length nnex)
-  _ <- liftIO $ swapMVar progress (14 / loadSteps)
+  _ <- liftIO $ swapMVar progress (14 / loadSteps, "Unfolding MindMap graph")
   A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
   (mmintmat, mmgraph) <- buildFloorMap . springField <$>
-    buildMindMap (length npcposs) 3
+    buildMindMap (length npcposs) 2
-  _ <- liftIO $ swapMVar progress (15 / loadSteps)
+  _ <- liftIO $ swapMVar progress (15 / loadSteps, "Converting MindMap to images")
   let mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat
-  _ <- liftIO $ swapMVar progress (16 / loadSteps)
+  _ <- liftIO $ swapMVar progress (16 / loadSteps, "Creating WorldState")
   (nws, _) <- yieldSystemT (worldState ud) $ do
     let pmmpos = (+ 0.5) . (fromIntegral :: Int -> Double) . floor <$> mmPos
           (fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph))
@@ -125,7 +125,7 @@ loadMapFork ud future progress = do
       , rot           = Just SE
       , anim          = Just $ AnimState (AnimId 0 "standing" SE) 0 0
       }
-    void $ liftIO $ swapMVar progress (17 / loadSteps)
+    void $ liftIO $ swapMVar progress (17 / loadSteps, "Registering NPCs into WorldState")
     mapM_ (\npcpos@(V2 nr nc) -> do
       fact <- liftIO $ randomRIO (0.5, 1.5)
       fut <- liftIO newEmptyMVar
@@ -139,7 +139,7 @@ loadMapFork ud future progress = do
         , anim          = Just $ AnimState (AnimId 1 "standing" SE) 0 0
         }
       ) npcposs
-    void $ liftIO $ swapMVar progress (18 / loadSteps)
+    void $ liftIO $ swapMVar progress (18 / loadSteps, "Handing over")
   putMVar future (nws, MainData
       { mapMat = mat
       , imgMat = M.fromList (nrows inter) (ncols inter) $

src/MindMap.hs

@@ -44,7 +44,7 @@ buildMindMap num difficulty = do
       vert <- randomRIO (1, num)
       x <- randomRIO (4.5, 5.5) :: IO Double
       y <- randomRIO (4.5, 5.5) :: IO Double
-      A.logIO A.Debug ("pos: " ++ show (x, y))
+      -- A.logIO A.Debug ("pos: " ++ show (x, y))
       let node = MMNode (V2 x y) vert
       if node `elem` acc
       then makeVert acc a
@@ -54,13 +54,11 @@ springField :: AG.Graph MMNode -> AG.Graph MMNode
 springField =
   calcul
   where
-    -- This could be optimized in such a way, that you update both computation partners at once.
-    -- Limit the force
     calcul graph =
-      let deltas = calculDelta2 graph -- map (calculDelta graph) (vertexList graph)
+      let deltas = calculDelta2 graph
       in  if any (\(_, v) -> len v > 1)
-            (A.log A.Debug ("deltas: " ++ show deltas) deltas)
+            -- (A.log A.Debug ("deltas: " ++ show deltas) deltas)
-            -- deltas
+            deltas
         then
           let deltaNodes = map
                 (\n -> n { mmPos = mmPos n + snd (fromJust (find ((== mmId n) . fst) deltas))})
@@ -69,7 +67,9 @@ springField =
           in  -- A.log A.Debug "\n\nRECURSING\n"
                 (calcul ngraph)
         else graph
-    len v = sqrt (v `dot` v)
+
+len :: (Floating a, Metric f) => f a -> a
+len v = sqrt (v `dot` v)
 
 normv :: (Eq a, Floating a) => V2 a -> V2 a
 normv v@(V2 0 0) = v
@@ -82,7 +82,7 @@ buildFloorMap inGraph =
         (floor r + 2, floor c + 2) amat
         )
       emptyFloor
-      (A.log A.Debug ("floorGraph: " ++ show floorGraph) floorGraph)
+      floorGraph
   , fmap (\n -> n { mmPos = (+ 2) <$> mmPos n} ) floorGraph
   )
   where
@@ -95,9 +95,7 @@ buildFloorMap inGraph =
             ( maximum $ map ((\(V2 _ c) -> c) . mmPos) (vertexList redGraph))
           redGraph = fmap (\n -> n { mmPos = mmPos n - minVert }) inGraph
       in  fmap (\n -> n { mmPos = mmPos n / maxVert }) redGraph
-    floorGraph =
+    floorGraph = fmap (\n -> n { mmPos = (* 45) <$> mmPos n }) normGraph
-      fmap (\n -> n { mmPos = (* 45) <$> mmPos n} )
-        (A.log A.Verbose ("normGraph: " ++ (show $ vertexList normGraph)) normGraph)
     emptyFloor = M.matrix 50 50 (const 0)
 
 manhattan :: AG.Graph MMNode -> M.Matrix Int -> M.Matrix TileState
@@ -140,7 +138,7 @@ calculDelta2 graph =
       sproing2 [] = []
       sproing2 ((cnode, cacc):nodeaccs) =
         ( mmId cnode
-        , if (distance (V2 0 0) (V2 100 100 * normv deltasum)) < distance (V2 0 0) deltasum
+        , if (len (V2 100 100 * normv deltasum)) < len deltasum
           then V2 100 100 * normv deltasum
           else deltasum
         ) : sproing2 dnodeaccs

src/Types/UserData.hs

@@ -35,7 +35,7 @@ data UserData = UserData
   , worldState      :: SystemState Entity IO
   , stateData       :: StateData
   , stateMVar       :: MVar (SystemState Entity IO, StateData)
-  , stateProgress   :: MVar Float
+  , stateProgress   :: MVar (Float, T.Text)
   , threadContext   :: Maybe SDL.GLContext
   , window          :: Maybe SDL.Window
   }

src/Util.hs

@@ -9,6 +9,7 @@ import qualified Data.Map as Map
 import Data.ByteString.Lazy (toStrict)
 import Data.Graph.AStar
 import Data.Maybe
+import qualified Data.Text as T
 
 import qualified SDL
 import qualified Graphics.Rendering.OpenGL as GL hiding (get)
@@ -175,8 +176,8 @@ naviGraph imgmat (V2 r c) =
           [(-1, -1), (-1, 1), (1, -1), (1, 1)]
   in  HS.fromList (list1 ++ list2)
 
-drawLoadScreen :: UserData -> Float -> IO ()
+drawLoadScreen :: UserData -> (Float, T.Text) -> IO ()
-drawLoadScreen ud progress = do
+drawLoadScreen ud (progress, msg) = do
   let ctx = nano ud
   save ctx
   fillColor ctx (rgb 255 128 0)
@@ -189,6 +190,8 @@ drawLoadScreen ud progress = do
     (640 - 640 * realToFrac progress) 450 (1280 * realToFrac progress) 20
   closePath ctx
   fill ctx
+  fontSize ctx 25
+  textBox ctx 0 500 1280 msg
   restore ctx
 
 loadAnimationSprites

tracer-game.cabal

@@ -47,7 +47,7 @@ executable tracer-game
   -- other-extensions:    
   build-depends:       base >=4.10 && <5
                      , affection == 0.0.0.9
-                     , sdl2
+                     , sdl2 >= 2.4.0.0
                      , OpenGL
                      , nanovg >= 0.6.0.0
                      , stm
@@ -55,7 +55,7 @@ executable tracer-game
                      , containers
                      , ecstasy >= 0.2.1.0
                      , linear
-                     , matrix
+                     , matrix >= 0.3.6.0
                      , random
                      , vector
                      , astar