introduce scenes and thus get rid of overly big enums
This commit is contained in:
parent
31f56d62a3
commit
3b5d0a90ad
21
src/Main.hs
21
src/Main.hs
|
@ -56,7 +56,7 @@ preLoad gd =
|
||||||
|
|
||||||
vertexArrayObject <- GL.genObjectName
|
vertexArrayObject <- GL.genObjectName
|
||||||
va <- newVertexArray
|
va <- newVertexArray
|
||||||
atomically $ writeTVar (gameState gd) Loading
|
atomically $ (writeTVar (gameScene gd) =<< (initScene :: IO Test))
|
||||||
|
|
||||||
|
|
||||||
handle :: GameData -> [SDL.EventPayload] -> Affection ()
|
handle :: GameData -> [SDL.EventPayload] -> Affection ()
|
||||||
|
@ -66,14 +66,17 @@ 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
|
||||||
progressMeter <- liftIO $ atomically (fst <$> readTMVar (gameStateLoadProgress gd))
|
isStagePresent <- atomically $ isEmptyTMVar $ gamescene gd
|
||||||
if progressMeter < 0
|
if isStagePresent
|
||||||
then do
|
then
|
||||||
-- liftIO (atomically (putTMVar (gameStateLoadProgress gd) (0, "Ohai!")))
|
stage <- liftIO $ atomically $ readTVar $ gameScene gd
|
||||||
|
then
|
||||||
smLoad state gd
|
smLoad state gd
|
||||||
else
|
else
|
||||||
smUpdate state gd dt
|
smUpdate state gd dt
|
||||||
|
else
|
||||||
|
return ()
|
||||||
|
|
||||||
draw :: GameData -> Affection ()
|
draw :: GameData -> Affection ()
|
||||||
draw gd = do
|
draw gd = do
|
||||||
|
@ -82,9 +85,9 @@ draw gd = do
|
||||||
|
|
||||||
init :: IO GameData
|
init :: IO GameData
|
||||||
init = GameData
|
init = GameData
|
||||||
<$> newTVarIO Loading
|
<$> newEmptyTMVarIO
|
||||||
<*> newTMVarIO (-1, "Ohai!")
|
<*> newTVarIO Loading
|
||||||
<*> newTMVarIO EmptyData
|
<*> newTMVarIO (0, "Ohai!")
|
||||||
<*> (Subsystems
|
<*> (Subsystems
|
||||||
<$> (SubWindow <$> newTVarIO [])
|
<$> (SubWindow <$> newTVarIO [])
|
||||||
<*> (SubMouse <$> newTVarIO [])
|
<*> (SubMouse <$> newTVarIO [])
|
||||||
|
|
|
@ -27,4 +27,4 @@ initLoad
|
||||||
:: GameData
|
:: GameData
|
||||||
-> Affection ()
|
-> Affection ()
|
||||||
initLoad gd =
|
initLoad gd =
|
||||||
liftIO $ atomically $ writeTVar (gameState gd) (MainGame Test)
|
liftIO $ atomically $ writeTVar (gameState gd) Running
|
||||||
|
|
|
@ -16,15 +16,12 @@ import State.MainGame
|
||||||
instance StateMachine GameData State where
|
instance StateMachine GameData State where
|
||||||
|
|
||||||
smLoad Loading = initLoad
|
smLoad Loading = initLoad
|
||||||
smLoad (MainGame Test) = mainGameLoad
|
|
||||||
smLoad x = error ("State load not yet implemented: " <> show x)
|
smLoad x = error ("State load not yet implemented: " <> show x)
|
||||||
|
|
||||||
smUpdate Loading = initLoadUpdate
|
smUpdate Loading = initLoadUpdate
|
||||||
smUpdate (MainGame Test) = mainGameUpdate
|
|
||||||
smUpdate x = error ("State update not yet implemented: " <> show x)
|
smUpdate x = error ("State update not yet implemented: " <> show x)
|
||||||
|
|
||||||
smDraw Loading = initLoadDraw
|
smDraw Loading = initLoadDraw
|
||||||
smDraw (MainGame Test) = mainGameDraw
|
|
||||||
smDraw x = error ("State draw not yet implemented: " <> show x)
|
smDraw x = error ("State draw not yet implemented: " <> show x)
|
||||||
|
|
||||||
smEvent _ gd evs = do
|
smEvent _ gd evs = do
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
module Types.Application where
|
module Types.Application where
|
||||||
|
|
||||||
import Affection
|
import Affection
|
||||||
|
@ -16,61 +17,24 @@ import Types.Subsystems
|
||||||
import Types.GameMap
|
import Types.GameMap
|
||||||
|
|
||||||
data GameData = GameData
|
data GameData = GameData
|
||||||
{ gameState :: TVar State
|
{ gameScene :: TMVar Stage
|
||||||
|
, gameState :: TVar State
|
||||||
, gameStateLoadProgress :: TMVar Progress
|
, gameStateLoadProgress :: TMVar Progress
|
||||||
, gameStateData :: TMVar StateData
|
|
||||||
, gameSubsystems :: Subsystems
|
, gameSubsystems :: Subsystems
|
||||||
, gameActionTranslation :: TVar ActionTranslation
|
, gameActionTranslation :: TVar ActionTranslation
|
||||||
, gameRunning :: TVar Bool
|
, gameRunning :: TVar Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
|
-- Existential type wrapper to make all Scenes implementing Scene
|
||||||
|
-- homogenous.
|
||||||
|
-- See more at https://wiki.haskell.org/Existential_type#Dynamic_dispatch_mechanism_of_OOP
|
||||||
|
data Stage = forall a. Scene a => Stage a
|
||||||
|
|
||||||
data State
|
data State
|
||||||
= Loading
|
= Loading
|
||||||
| Menu MenuState
|
| Running
|
||||||
| MainGame Level
|
| Pausing
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
data MenuState
|
|
||||||
= MenuMain
|
|
||||||
| MenuSettings
|
|
||||||
deriving (Eq , Show)
|
|
||||||
|
|
||||||
data Level
|
|
||||||
= DNAMenu
|
|
||||||
| Sewer01
|
|
||||||
| Sewer02
|
|
||||||
| Sewer03
|
|
||||||
| Sewer04
|
|
||||||
| Alley01
|
|
||||||
| Alley02
|
|
||||||
| Alley03
|
|
||||||
| Alley04
|
|
||||||
| Lab01
|
|
||||||
| Lab02
|
|
||||||
| Lab03
|
|
||||||
| Lab04
|
|
||||||
| Highway01
|
|
||||||
| Highway02
|
|
||||||
| Highway03
|
|
||||||
| Highway04
|
|
||||||
| Complex01
|
|
||||||
| Complex02
|
|
||||||
| Complex03
|
|
||||||
| Complex04
|
|
||||||
| Base01
|
|
||||||
| Base02
|
|
||||||
| Base03
|
|
||||||
| Base04
|
|
||||||
| Test
|
|
||||||
deriving (Enum, Eq, Show)
|
|
||||||
|
|
||||||
type Progress = (Float, T.Text)
|
type Progress = (Float, T.Text)
|
||||||
|
|
||||||
type ActionTranslation = M.Map SDL.Keycode Action
|
type ActionTranslation = M.Map SDL.Keycode Action
|
||||||
|
|
||||||
data StateData
|
|
||||||
= EmptyData
|
|
||||||
| TestData
|
|
||||||
{ testMap :: LevelMap
|
|
||||||
}
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
Loading…
Reference in a new issue