meow

src/Classes.hs

@@ -3,3 +3,4 @@ module Classes
   ) where
 
 import Classes.Graphics as C
+import Classes.Scene as C

src/Classes/Scene.hs

@@ -1,17 +1,22 @@
-{-# LANGUAGE ExistentialQuantification #-}
-module Scenes.Scene where
+module Classes.Scene where
 
 import Affection
 
+import Control.Concurrent.STM
+
 import qualified SDL
 
+-- internal imports
+
+import Types.Util
+
 class Scene a where
 
   -- | Perform initialization and output a (possibly empty) data container.
   initScene :: IO a
 
   -- | Load actual data into the initialized container.
-  loadScene :: a -> Affection ()
+  loadScene :: a -> TMVar Progress -> IO a
 
   -- | Query whether loading data is finished.
   isSceneLoaded :: a -> Affection Bool

src/Main.hs

@@ -7,16 +7,22 @@ import qualified Data.Text as T
 
 import qualified SDL
 
+import qualified Graphics.Rendering.OpenGL as GL
+
 import Control.Concurrent.STM
 
 import qualified Data.Map.Strict as M
 
+import Data.Maybe (isJust)
+
 import Linear
 
 -- internal imports
 
 import StateMachine
 import Types
+import Classes
+import Scenes.Test
 
 instance Affectionate GameData where
   preLoop = preLoad
@@ -54,10 +60,10 @@ preLoad gd =
         view = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
         model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
 
-    vertexArrayObject <- GL.genObjectName
+    -- vertexArrayObject <- GL.genObjectName
     va <- newVertexArray
-    atomically $ (writeTVar (gameScene gd) =<< (initScene :: IO Test))
-  
+    scene <- liftIO $ (initScene :: IO Test)
+    atomically $ putTMVar (gameScene gd) (Stage scene)
 
 handle :: GameData -> [SDL.EventPayload] -> Affection ()
 handle gd evs = do
@@ -67,10 +73,13 @@ handle gd evs = do
 update :: GameData -> Double -> Affection ()
 update gd dt = do
   state <- liftIO $ atomically $ readTVar $ gameState gd
-  isStagePresent <- atomically $ isEmptyTMVar $ gamescene gd
+  isStagePresent <- liftIO $ atomically $ isEmptyTMVar $ gameScene gd
   if isStagePresent
-  then
-    stage <- liftIO $ atomically $ readTVar $ gameScene gd
+  then do
+    hasLoadThreadId <- isJust <$> (liftIO $ atomically $ readTVar $ gameLoadThread gd)
+    (Stage sceneContainer) <- liftIO $ atomically $ readTMVar $ gameScene gd
+    sceneLoaded <- isSceneLoaded sceneContainer
+    if not sceneLoaded && not hasLoadThreadId
     then
       smLoad state gd
     else
@@ -96,3 +105,4 @@ init = GameData
     )
   <*> newTVarIO (M.fromList [])
   <*> newTVarIO True
+  <*> newTVarIO Nothing

src/Map.hs

@@ -16,14 +16,6 @@ import Control.Monad (foldM)
 import Types
 import Texture
 
-testLevelDesc :: LevelDescriptor
-testLevelDesc = LevelDescriptor
-  [ (0, "res/maps/00_test/00_test.bmp")
-  ]
-  0
-  "res/tiles/00_test/00_test.png"
-  (3, 3)
-
 constructMap :: LevelDescriptor -> GL.GLuint -> IO LevelMap
 constructMap desc tilemapSlot = do
   (layers, dimensions) <- foldM

src/Scenes/Test.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Scenes.Test where
+
+import Affection
+
+import Control.Concurrent.STM
+
+import Control.Monad (void)
+
+-- internal imports
+
+import Types
+import Map
+import Classes.Scene
+
+data Test = Test
+  { testMap :: TMVar LevelMap
+  , testLoaded :: TVar Bool
+  }
+
+instance Scene Test where
+
+  initScene = Test <$> newEmptyTMVarIO <*> newTVarIO False
+
+  loadScene level progress = do
+    atomically $ do
+      void $ takeTMVar progress
+      putTMVar progress (0, "Loading test level...")
+    loadedMap <- constructMap testLevelDesc 0
+    atomically $ putTMVar (testMap level) loadedMap
+    void $ atomically $ do
+      void $ takeTMVar progress
+      putTMVar progress (1, "Loaded test level!")
+    void $ atomically $ swapTVar (testLoaded level) True
+    return level
+
+  isSceneLoaded = liftIO . atomically . readTVar . testLoaded
+
+  update _ _ = return ()
+
+  onEvents _ _ = return ()
+
+  render _ = return ()
+
+testLevelDesc :: LevelDescriptor
+testLevelDesc = LevelDescriptor
+  [ (0, "res/maps/00_test/00_test.bmp")
+  ]
+  0
+  "res/tiles/00_test/00_test.png"
+  (3, 3)
+

src/State/MainGame/Load.hs

@@ -12,6 +12,7 @@ import Control.Monad (void)
 
 import Types
 import Map
+import Classes.Scene
 
 mainGameLoad
   :: GameData
@@ -21,20 +22,23 @@ mainGameLoad gd = do
     _ <- takeTMVar (gameStateLoadProgress gd)
     putTMVar (gameStateLoadProgress gd) (0, "Ohai!")
   liftIO $ logIO Verbose "Entering main Game"
-  liftIO $ void $ forkIO $ loadFork (gameStateData gd) (gameStateLoadProgress gd)
+  tid <- liftIO $ forkIO $ loadFork (gameScene gd) (gameStateLoadProgress gd)
+  liftIO $ atomically $ writeTVar (gameLoadThread gd) (Just tid)
 
 loadFork
-  :: TMVar StateData
+  :: TMVar Stage
   -> TMVar Progress
   -> IO ()
-loadFork dataContainer progress = do
-  atomically $ do
-    _ <- takeTMVar progress
-    putTMVar progress (0, "Loading test level...")
-  testData <- TestData <$> constructMap testLevelDesc 0
-  print testData
-  atomically $ do
-    _ <- takeTMVar dataContainer
-    putTMVar dataContainer testData
-    _ <- takeTMVar progress
-    putTMVar progress (1, "Loaded test level!")
+loadFork stage progress = do
+  (Stage sceneContainer) <- atomically $ readTMVar stage
+  void . atomically . swapTMVar stage =<< Stage <$> loadScene sceneContainer progress
+  -- atomically $ do
+  --   _ <- takeTMVar progress
+  --   putTMVar progress (0, "Loading test level...")
+  -- testData <- TestData <$> constructMap testLevelDesc 0
+  -- print testData
+  -- atomically $ do
+  --   _ <- takeTMVar dataContainer
+  --   putTMVar dataContainer testData
+  --   _ <- takeTMVar progress
+  --   putTMVar progress (1, "Loaded test level!")

src/Types.hs

@@ -7,3 +7,4 @@ import Types.Subsystems as T
 import Types.GameMap as T
 import Types.Texture as T
 import Types.Graphics as T
+import Types.Util as T

src/Types/Application.hs

@@ -5,6 +5,7 @@ import Affection
 
 import qualified SDL
 
+import Control.Concurrent (ThreadId)
 import Control.Concurrent.STM
 
 import qualified Data.Map.Strict as M
@@ -15,6 +16,9 @@ import qualified Data.Text as T
 
 import Types.Subsystems
 import Types.GameMap
+import Types.Util
+
+import Classes.Scene
 
 data GameData = GameData
   { gameScene             :: TMVar Stage
@@ -23,6 +27,7 @@ data GameData = GameData
   , gameSubsystems        :: Subsystems
   , gameActionTranslation :: TVar ActionTranslation
   , gameRunning           :: TVar Bool
+  , gameLoadThread        :: TVar (Maybe ThreadId)
   }
 
 -- Existential type wrapper to make all Scenes implementing Scene
@@ -34,7 +39,4 @@ data State
   = Loading
   | Running
   | Pausing
-
-type Progress = (Float, T.Text)
-
-type ActionTranslation = M.Map SDL.Keycode Action
+  deriving (Show)

src/Types/Util.hs

@@ -0,0 +1,15 @@
+module Types.Util where
+
+import qualified Data.Text as T
+
+import qualified Data.Map.Strict as M
+
+import qualified SDL
+
+-- internal imports
+
+import Types.Subsystems
+
+type Progress = (Float, T.Text)
+
+type ActionTranslation = M.Map SDL.Keycode Action