diff --git a/src/Classes.hs b/src/Classes.hs index 1668bd5..57bee54 100644 --- a/src/Classes.hs +++ b/src/Classes.hs @@ -3,3 +3,4 @@ module Classes ) where import Classes.Graphics as C +import Classes.Scene as C diff --git a/src/Classes/Scene.hs b/src/Classes/Scene.hs index 50964f6..70d9793 100644 --- a/src/Classes/Scene.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index df655f1..b17d76d 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Map.hs b/src/Map.hs index 34fa4d9..04c1b63 100644 --- a/src/Map.hs +++ b/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 diff --git a/src/Scenes/Test.hs b/src/Scenes/Test.hs new file mode 100644 index 0000000..b7717e0 --- /dev/null +++ b/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) + diff --git a/src/State/MainGame/Load.hs b/src/State/MainGame/Load.hs index b34d595..00979fb 100644 --- a/src/State/MainGame/Load.hs +++ b/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!") diff --git a/src/Types.hs b/src/Types.hs index 6ea5273..828ce2d 100644 --- a/src/Types.hs +++ b/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 diff --git a/src/Types/Application.hs b/src/Types/Application.hs index 98093f8..04ebed1 100644 --- a/src/Types/Application.hs +++ b/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) diff --git a/src/Types/Util.hs b/src/Types/Util.hs new file mode 100644 index 0000000..7d44d82 --- /dev/null +++ b/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