2020-10-16 23:53:25 +00:00
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module StateMachine where
|
|
|
|
|
|
|
|
import Affection
|
|
|
|
|
2020-12-14 02:12:33 +00:00
|
|
|
import Data.Maybe (isNothing)
|
2020-12-06 07:14:50 +00:00
|
|
|
|
|
|
|
import Control.Monad (void, when)
|
|
|
|
|
|
|
|
import Control.Concurrent.STM
|
2020-10-16 23:53:25 +00:00
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types
|
2020-12-06 07:14:50 +00:00
|
|
|
import Classes
|
2020-10-16 23:53:25 +00:00
|
|
|
|
2020-12-06 07:14:50 +00:00
|
|
|
-- import State.Loading
|
|
|
|
-- import State.MainGame
|
2020-10-16 23:53:25 +00:00
|
|
|
|
|
|
|
instance StateMachine GameData State where
|
|
|
|
|
2020-12-06 07:14:50 +00:00
|
|
|
smLoad Loading gd = do
|
|
|
|
mThreadId <- liftIO $ atomically $ readTVar (gameLoadThread gd)
|
|
|
|
when (isNothing mThreadId) $ do
|
|
|
|
(Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
|
|
|
|
-- ctx <- liftIO $ atomically $ fromJust <$>
|
|
|
|
-- (readTVar $ gameLoadContext gd)
|
|
|
|
ad <- get -- get inner state of engine
|
2020-12-14 02:12:33 +00:00
|
|
|
-- let win = ((\(_, y, _) -> y) $ head $ drawWindows ad)
|
2020-12-06 07:14:50 +00:00
|
|
|
liftIO $
|
|
|
|
loadScene scene (gameStateLoadProgress gd)
|
|
|
|
-- SDL.glMakeCurrent win (snd $ head $ glContext ad)
|
|
|
|
-- liftIO $ atomically $ writeTVar (gameLoadThread gd) (Just tid)
|
|
|
|
|
|
|
|
smLoad x _ = error ("State load not yet implemented: " <> show x)
|
|
|
|
|
2020-10-16 23:53:25 +00:00
|
|
|
|
2020-12-14 07:00:06 +00:00
|
|
|
smUpdate Loading gd dt = do
|
|
|
|
(Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
|
|
|
|
Classes.update scene dt
|
2020-12-06 07:14:50 +00:00
|
|
|
|
|
|
|
smUpdate x _ _ = error ("State update not yet implemented: " <> show x)
|
|
|
|
|
|
|
|
|
|
|
|
smDraw Loading gd = do
|
|
|
|
(Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
|
|
|
|
render scene
|
|
|
|
|
|
|
|
smDraw x _ = error ("State draw not yet implemented: " <> show x)
|
2020-10-16 23:53:25 +00:00
|
|
|
|
|
|
|
|
|
|
|
smEvent _ gd evs = do
|
|
|
|
let Subsystems w m k _ = gameSubsystems gd
|
|
|
|
void . (consumeSDLEvents k) =<<
|
|
|
|
consumeSDLEvents m =<<
|
|
|
|
consumeSDLEvents w evs
|
|
|
|
|
2020-12-06 07:14:50 +00:00
|
|
|
|
|
|
|
smClean x _ = error ("State clean not yet implemented: " <> show x)
|