loading screen

shell.nix

@@ -79,7 +79,7 @@ let
 
   f = { mkDerivation, astar, base, containers, linear
       , matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers
-      , vector, JuicyPixels, JuicyPixels-extra, bytestring
+      , vector, JuicyPixels, JuicyPixels-extra, bytestring, monad-loops
       }:
       mkDerivation {
         pname = "tracer-game";

src/Init.hs

@@ -43,11 +43,13 @@ foreign import ccall unsafe "glewInit"
 
 load :: IO UserData
 load = do
-  _ <- glewInit
-  nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
   subs <- Subsystems
     <$> (Window <$> newTVarIO [])
     <*> (Mouse <$> newTVarIO [])
+  _ <- glewInit
+  nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
+  _ <- createFont nvg "bedstead"
+    (FileName "assets/font/Bedstead-Semicondensed.ttf")
   (ws, _) <- yieldSystemT (0, defStorage) (return ())
   mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
   mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
@@ -66,8 +68,6 @@ load = do
   mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0
   mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0
   mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0
-  _ <- createFont nvg "bedstead"
-    (FileName "assets/font/Bedstead-Semicondensed.ttf")
   let mimgs = [ mwallasc, mwalldesc,
        mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
         mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,

src/NPC.hs

@@ -81,21 +81,21 @@ placeNPCs
   -> [ReachPoint]
   -> [Graph]
   -> Int
-  -> Affection UserData [V2 Double]
+  -> IO [V2 Double]
 placeNPCs imgmat tilemat rp gr count =
   doPlace 1 []
   where
-    doPlace :: Int -> [V2 Double] -> Affection UserData [V2 Double]
+    doPlace :: Int -> [V2 Double] -> IO [V2 Double]
     doPlace nr acc = do
       if nr <= count
       then do
-        r <- liftIO $ randomRIO (1, M.nrows imgmat)
-        c <- liftIO $ randomRIO (1, M.ncols imgmat)
+        r <- randomRIO (1, M.nrows imgmat)
+        c <- randomRIO (1, M.ncols imgmat)
         if null (imgObstacle $ imgmat M.! (r, c)) &&
           tilemat M.! (r, c) == Hall
         then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc)
         else do
-          i <- liftIO $ randomRIO (0, length nonexits - 1)
+          i <- randomRIO (0, length nonexits - 1)
           doPlace
             (nr + 1)
             ((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc)

src/Test.hs

@@ -8,7 +8,7 @@ import NanoVG hiding (V2(..))
 import Control.Monad (when, void)
 import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent.MVar
-import Control.Concurrent (forkOS)
+import Control.Concurrent (forkIO)
 
 import Data.Map.Strict as Map
 import qualified Data.Set as S
@@ -35,12 +35,33 @@ import NPC
 loadMap :: Affection UserData ()
 loadMap = do
   ud <- getAffection
+  let (Subsystems _ m) = subsystems ud
+      ctx = nano ud
+  uu <- partSubscribe m movePlayer
+  future <- liftIO $ newEmptyMVar
+  _ <- liftIO $ forkIO $ loadMapFork ud future
+  -- liftIO $ whileM_ (isJust <$> tryTakeMVar future) $ do
+  --   beginFrame (nano ud) 1280 720 1
+  --   fontSize ctx 100
+  --   fontFace ctx (assetFonts ud Map.! FontBedstead)
+  --   textAlign ctx (S.fromList [AlignCenter,AlignTop])
+  --   fillColor ctx (rgb 255 128 0)
+  --   textBox ctx 0 300 1280 ("Loading")
+  --   endFrame (nano ud)
+  -- (nws, mendat) <- liftIO $ takeMVar future
+  putAffection ud
+    { stateData = None
+    , uuid = [uu]
+    , menuMVar = future
+    }
+
+loadMapFork :: UserData -> MVar (SystemState Entity IO, StateData) -> IO ()
+loadMapFork ud future = do
   let fc = FloorConfig
         (10, 10)
         []
         (50, 50)
-      (Subsystems _ m) = subsystems ud
-  (mat, gr) <- liftIO $ buildHallFloorIO fc
+  (mat, gr) <- buildHallFloorIO fc
   let imgmat = convertTileToImg mat
       exits = Prelude.foldl
         (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
@@ -49,12 +70,12 @@ loadMap = do
           )
         []
         ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
-  (inter, rps) <- liftIO $ placeInteriorIO mat imgmat exits gr
-  liftIO $ logIO A.Debug ("number of reachpoints: " ++ show (length rps))
+  (inter, rps) <- placeInteriorIO mat imgmat exits gr
+  logIO A.Debug ("number of reachpoints: " ++ show (length rps))
   let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
   npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
-  liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
-  (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
+  A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
+  (nws, _) <- yieldSystemT (worldState ud) $ do
     void $ createEntity $ newEntity
       { pos           = Just (V2 10.5 10.5)
       , vel           = Just (V2 0 0)
@@ -65,7 +86,7 @@ loadMap = do
     void $ mapM_ (\npcpos@(V2 nr nc) -> do
       fact <- liftIO $ randomRIO (0.5, 1.5)
       future <- liftIO newEmptyMVar
-      _ <- liftIO $ forkOS $ getPath (fmap floor npcpos) future nnex inter
+      _ <- liftIO $ forkIO $ getPath (fmap floor npcpos) future nnex inter
       void $ createEntity $ newEntity
         { pos           = Just (V2 (nr + 0.5) (nc + 0.5))
         , vel           = Just (V2 0 0)
@@ -75,10 +96,7 @@ loadMap = do
         , anim          = Just $ AnimState (AnimId 0 "standing" SE) 0 0
         }
       ) npcposs
-  uu <- partSubscribe m movePlayer
-  putAffection ud
-    { worldState = nws
-    , stateData = MenuData
+  putMVar future (nws, MenuData
       { mapMat = mat
       , imgMat = M.fromList (nrows inter) (ncols inter) $
         Prelude.map
@@ -86,9 +104,7 @@ loadMap = do
           (M.toList inter)
       , initCoords = (0, 500)
       , reachPoints = rps
-      }
-    , uuid = [uu]
-    }
+      })
 
 mouseToPlayer :: V2 Int32 -> Affection UserData ()
 mouseToPlayer mv2 = do
@@ -126,6 +142,17 @@ movePlayer _ = return ()
 drawMap :: Affection UserData ()
 drawMap = do
   ud <- getAffection
+  let ctx = nano ud
+  case stateData ud of
+    None -> liftIO $ do
+      beginFrame (nano ud) 1280 720 1
+      fontSize ctx 100
+      fontFace ctx (assetFonts ud Map.! FontBedstead)
+      textAlign ctx (S.fromList [AlignCenter,AlignTop])
+      fillColor ctx (rgb 255 128 0)
+      textBox ctx 0 300 1280 ("Loading")
+      endFrame (nano ud)
+    _ -> do
       dt <- getDelta
       (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
         pc <- fmap head $ efor allEnts $ do
@@ -141,7 +168,6 @@ drawMap = do
         return (pc, posanims)
       let V2 pr pc = playerPos
           mat = imgMat (stateData ud)
-      ctx = nano ud
           cols = fromIntegral (ncols mat)
           rows = fromIntegral (nrows mat)
           tileWidth = 64 :: Double
@@ -268,11 +294,22 @@ drawTile ud ctx posanims pr pc row col img =
 
 updateMap :: Double -> Affection UserData ()
 updateMap dt = do
+  ud <- getAffection
+  isFut <- liftIO $ isEmptyMVar (menuMVar ud)
+  if not isFut && stateData ud == None
+  then do
+    Just (nws, mendat) <- liftIO $ tryTakeMVar (menuMVar ud)
+    putAffection ud
+      { worldState = nws
+      , stateData = mendat
+      }
+  else do
     let direction :: V2 Double -> Direction -> Direction
         direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
           then
             let xuu =
-                acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel')) / pi * 180
+                  acos ((vel' `dot` V2 0 1) /
+                    sqrt (vel' `dot` vel')) / pi * 180
                 xu = if vr < 0 then 360 - xuu else xuu
                 d
                   |               xu < 22.5  = NE
@@ -287,7 +324,6 @@ updateMap dt = do
                   | otherwise                = NE
             in d
           else rot'
-  ud <- getAffection
     (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
       emap allEnts $ do
         with anim

src/Types/ReachPoint.hs

@@ -8,7 +8,7 @@ data ReachPoint = ReachPoint
   , pointCoord :: V2 Int
   , pointDir   :: Direction
   }
-  deriving (Show)
+  deriving (Eq, Show)
 
 data PointType
   = RoomExit

src/Types/StateData.hs

@@ -14,3 +14,4 @@ data StateData
     , imgMat      :: Matrix (Maybe ImgId)                                          
     , reachPoints :: [ReachPoint]                                                  
     }
+  deriving (Eq)

src/Types/UserData.hs

@@ -32,6 +32,7 @@ data UserData = UserData
   , uuid            :: [UUID]
   , worldState      :: SystemState Entity IO
   , stateData       :: StateData
+  , menuMVar        :: MVar (SystemState Entity IO, StateData)
   }
 
 data State