pituicat/src/StateMachine.hs

61 lines
1.6 KiB
Haskell
Raw Normal View History

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