detailed loading output

2018-07-19 04:51:07 +02:00 · 2018-07-19 04:51:07 +02:00 · 2b86eaf230
commit 2b86eaf230
parent b04ae8759b
7 changed files with 160 additions and 64 deletions
--- a/src/Floorplan.hs
+++ b/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
--- a/src/Load.hs
+++ b/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
--- a/src/MainGame/WorldMap.hs
+++ b/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)
-  _ <- liftIO $ swapMVar progress (14 / loadSteps)
+  npcposs <- placeNPCs inter mat rps 100 -- (length nnex)
+  _ <- 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
-  _ <- liftIO $ swapMVar progress (15 / loadSteps)
+    buildMindMap (length npcposs) 2
+  _ <- 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) $
--- a/src/MindMap.hs
+++ b/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)
-            -- deltas
+            -- (A.log A.Debug ("deltas: " ++ show deltas) deltas)
+            deltas
        then
          let deltaNodes = map
                (\n -> n { mmPos = mmPos n + snd (fromJust (find ((== mmId n) . fst) deltas))})
@ -69,6 +67,8 @@ springField =
          in  -- A.log A.Debug "\n\nRECURSING\n"
                (calcul ngraph)
        else graph
+
+len :: (Floating a, Metric f) => f a -> a
 len v = sqrt (v `dot` v)

 normv :: (Eq a, Floating a) => V2 a -> V2 a
@ -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 =
-      fmap (\n -> n { mmPos = (* 45) <$> mmPos n} )
-        (A.log A.Verbose ("normGraph: " ++ (show $ vertexList normGraph)) normGraph)
+    floorGraph = fmap (\n -> n { mmPos = (* 45) <$> mmPos n }) 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
--- a/src/Types/UserData.hs
+++ b/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
  }
--- a/src/Util.hs
+++ b/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 ud progress = do
+drawLoadScreen :: UserData -> (Float, T.Text) -> IO ()
+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
--- a/tracer-game.cabal
+++ b/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