meow
This commit is contained in:
parent
3b5d0a90ad
commit
dc78b0fe7b
|
@ -3,3 +3,4 @@ module Classes
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Classes.Graphics as C
|
import Classes.Graphics as C
|
||||||
|
import Classes.Scene as C
|
||||||
|
|
|
@ -1,17 +1,22 @@
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
module Classes.Scene where
|
||||||
module Scenes.Scene where
|
|
||||||
|
|
||||||
import Affection
|
import Affection
|
||||||
|
|
||||||
|
import Control.Concurrent.STM
|
||||||
|
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
|
|
||||||
|
-- internal imports
|
||||||
|
|
||||||
|
import Types.Util
|
||||||
|
|
||||||
class Scene a where
|
class Scene a where
|
||||||
|
|
||||||
-- | Perform initialization and output a (possibly empty) data container.
|
-- | Perform initialization and output a (possibly empty) data container.
|
||||||
initScene :: IO a
|
initScene :: IO a
|
||||||
|
|
||||||
-- | Load actual data into the initialized container.
|
-- | Load actual data into the initialized container.
|
||||||
loadScene :: a -> Affection ()
|
loadScene :: a -> TMVar Progress -> IO a
|
||||||
|
|
||||||
-- | Query whether loading data is finished.
|
-- | Query whether loading data is finished.
|
||||||
isSceneLoaded :: a -> Affection Bool
|
isSceneLoaded :: a -> Affection Bool
|
||||||
|
|
22
src/Main.hs
22
src/Main.hs
|
@ -7,16 +7,22 @@ import qualified Data.Text as T
|
||||||
|
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
|
|
||||||
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
|
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
|
|
||||||
|
import Data.Maybe (isJust)
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import StateMachine
|
import StateMachine
|
||||||
import Types
|
import Types
|
||||||
|
import Classes
|
||||||
|
import Scenes.Test
|
||||||
|
|
||||||
instance Affectionate GameData where
|
instance Affectionate GameData where
|
||||||
preLoop = preLoad
|
preLoop = preLoad
|
||||||
|
@ -54,10 +60,10 @@ preLoad gd =
|
||||||
view = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
|
view = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
|
||||||
model = 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
|
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 :: GameData -> [SDL.EventPayload] -> Affection ()
|
||||||
handle gd evs = do
|
handle gd evs = do
|
||||||
|
@ -67,10 +73,13 @@ handle gd evs = do
|
||||||
update :: GameData -> Double -> Affection ()
|
update :: GameData -> Double -> Affection ()
|
||||||
update gd dt = do
|
update gd dt = do
|
||||||
state <- liftIO $ atomically $ readTVar $ gameState gd
|
state <- liftIO $ atomically $ readTVar $ gameState gd
|
||||||
isStagePresent <- atomically $ isEmptyTMVar $ gamescene gd
|
isStagePresent <- liftIO $ atomically $ isEmptyTMVar $ gameScene gd
|
||||||
if isStagePresent
|
if isStagePresent
|
||||||
then
|
then do
|
||||||
stage <- liftIO $ atomically $ readTVar $ gameScene gd
|
hasLoadThreadId <- isJust <$> (liftIO $ atomically $ readTVar $ gameLoadThread gd)
|
||||||
|
(Stage sceneContainer) <- liftIO $ atomically $ readTMVar $ gameScene gd
|
||||||
|
sceneLoaded <- isSceneLoaded sceneContainer
|
||||||
|
if not sceneLoaded && not hasLoadThreadId
|
||||||
then
|
then
|
||||||
smLoad state gd
|
smLoad state gd
|
||||||
else
|
else
|
||||||
|
@ -96,3 +105,4 @@ init = GameData
|
||||||
)
|
)
|
||||||
<*> newTVarIO (M.fromList [])
|
<*> newTVarIO (M.fromList [])
|
||||||
<*> newTVarIO True
|
<*> newTVarIO True
|
||||||
|
<*> newTVarIO Nothing
|
||||||
|
|
|
@ -16,14 +16,6 @@ import Control.Monad (foldM)
|
||||||
import Types
|
import Types
|
||||||
import Texture
|
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 :: LevelDescriptor -> GL.GLuint -> IO LevelMap
|
||||||
constructMap desc tilemapSlot = do
|
constructMap desc tilemapSlot = do
|
||||||
(layers, dimensions) <- foldM
|
(layers, dimensions) <- foldM
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -12,6 +12,7 @@ import Control.Monad (void)
|
||||||
|
|
||||||
import Types
|
import Types
|
||||||
import Map
|
import Map
|
||||||
|
import Classes.Scene
|
||||||
|
|
||||||
mainGameLoad
|
mainGameLoad
|
||||||
:: GameData
|
:: GameData
|
||||||
|
@ -21,20 +22,23 @@ mainGameLoad gd = do
|
||||||
_ <- takeTMVar (gameStateLoadProgress gd)
|
_ <- takeTMVar (gameStateLoadProgress gd)
|
||||||
putTMVar (gameStateLoadProgress gd) (0, "Ohai!")
|
putTMVar (gameStateLoadProgress gd) (0, "Ohai!")
|
||||||
liftIO $ logIO Verbose "Entering main Game"
|
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
|
loadFork
|
||||||
:: TMVar StateData
|
:: TMVar Stage
|
||||||
-> TMVar Progress
|
-> TMVar Progress
|
||||||
-> IO ()
|
-> IO ()
|
||||||
loadFork dataContainer progress = do
|
loadFork stage progress = do
|
||||||
atomically $ do
|
(Stage sceneContainer) <- atomically $ readTMVar stage
|
||||||
_ <- takeTMVar progress
|
void . atomically . swapTMVar stage =<< Stage <$> loadScene sceneContainer progress
|
||||||
putTMVar progress (0, "Loading test level...")
|
-- atomically $ do
|
||||||
testData <- TestData <$> constructMap testLevelDesc 0
|
-- _ <- takeTMVar progress
|
||||||
print testData
|
-- putTMVar progress (0, "Loading test level...")
|
||||||
atomically $ do
|
-- testData <- TestData <$> constructMap testLevelDesc 0
|
||||||
_ <- takeTMVar dataContainer
|
-- print testData
|
||||||
putTMVar dataContainer testData
|
-- atomically $ do
|
||||||
_ <- takeTMVar progress
|
-- _ <- takeTMVar dataContainer
|
||||||
putTMVar progress (1, "Loaded test level!")
|
-- putTMVar dataContainer testData
|
||||||
|
-- _ <- takeTMVar progress
|
||||||
|
-- putTMVar progress (1, "Loaded test level!")
|
||||||
|
|
|
@ -7,3 +7,4 @@ import Types.Subsystems as T
|
||||||
import Types.GameMap as T
|
import Types.GameMap as T
|
||||||
import Types.Texture as T
|
import Types.Texture as T
|
||||||
import Types.Graphics as T
|
import Types.Graphics as T
|
||||||
|
import Types.Util as T
|
||||||
|
|
|
@ -5,6 +5,7 @@ import Affection
|
||||||
|
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
|
|
||||||
|
import Control.Concurrent (ThreadId)
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
|
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
|
@ -15,6 +16,9 @@ import qualified Data.Text as T
|
||||||
|
|
||||||
import Types.Subsystems
|
import Types.Subsystems
|
||||||
import Types.GameMap
|
import Types.GameMap
|
||||||
|
import Types.Util
|
||||||
|
|
||||||
|
import Classes.Scene
|
||||||
|
|
||||||
data GameData = GameData
|
data GameData = GameData
|
||||||
{ gameScene :: TMVar Stage
|
{ gameScene :: TMVar Stage
|
||||||
|
@ -23,6 +27,7 @@ data GameData = GameData
|
||||||
, gameSubsystems :: Subsystems
|
, gameSubsystems :: Subsystems
|
||||||
, gameActionTranslation :: TVar ActionTranslation
|
, gameActionTranslation :: TVar ActionTranslation
|
||||||
, gameRunning :: TVar Bool
|
, gameRunning :: TVar Bool
|
||||||
|
, gameLoadThread :: TVar (Maybe ThreadId)
|
||||||
}
|
}
|
||||||
|
|
||||||
-- Existential type wrapper to make all Scenes implementing Scene
|
-- Existential type wrapper to make all Scenes implementing Scene
|
||||||
|
@ -34,7 +39,4 @@ data State
|
||||||
= Loading
|
= Loading
|
||||||
| Running
|
| Running
|
||||||
| Pausing
|
| Pausing
|
||||||
|
deriving (Show)
|
||||||
type Progress = (Float, T.Text)
|
|
||||||
|
|
||||||
type ActionTranslation = M.Map SDL.Keycode Action
|
|
||||||
|
|
|
@ -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
|
Loading…
Reference in New Issue