This commit is contained in:
nek0 2020-10-28 11:48:58 +01:00
parent 3b5d0a90ad
commit dc78b0fe7b
9 changed files with 116 additions and 34 deletions

View File

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

View File

@ -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

View File

@ -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

View File

@ -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

52
src/Scenes/Test.hs Normal file
View File

@ -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)

View File

@ -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!")

View File

@ -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

View File

@ -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)

15
src/Types/Util.hs Normal file
View File

@ -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