pituicat/src/Main.hs

103 lines
2.5 KiB
Haskell
Raw Normal View History

2020-09-23 23:26:47 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-08-30 15:36:32 +00:00
module Main where
2020-09-23 23:26:47 +00:00
import Affection
import qualified Data.Text as T
import qualified SDL
2020-10-28 10:48:58 +00:00
import qualified Graphics.Rendering.OpenGL as GL
2020-09-23 23:26:47 +00:00
import Control.Concurrent.STM
import qualified Data.Map.Strict as M
2020-10-28 10:48:58 +00:00
import Data.Maybe (isJust)
2020-09-23 23:26:47 +00:00
import Linear
-- internal imports
2020-10-16 23:53:25 +00:00
import StateMachine
2020-09-23 23:26:47 +00:00
import Types
2020-10-28 10:48:58 +00:00
import Classes
import Scenes.Test
2020-09-23 23:26:47 +00:00
instance Affectionate GameData where
preLoop = preLoad
2020-10-16 23:53:25 +00:00
handleEvents = handle
update = Main.update
draw = Main.draw
2020-09-23 23:26:47 +00:00
loadState = Main.init
cleanUp _ = return ()
hasNextStep = liftIO . atomically . readTVar . gameRunning
2020-08-30 15:36:32 +00:00
main :: IO ()
2020-09-23 23:26:47 +00:00
main = do
let config = AffectionConfig
{ initComponents = All
, windowTitle = "Pituicat"
, windowConfigs =
[ ( 0
, SDL.defaultWindow
{ SDL.windowInitialSize = V2 800 600
, SDL.windowResizable = True
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
, SDL.Windowed
)
]
} :: AffectionConfig GameData
withAffection config
preLoad :: GameData -> Affection ()
2020-10-17 14:18:42 +00:00
preLoad gd =
liftIO $ do
2020-10-28 10:48:58 +00:00
scene <- liftIO $ (initScene :: IO Test)
atomically $ putTMVar (gameScene gd) (Stage scene)
2020-10-16 23:53:25 +00:00
handle :: GameData -> [SDL.EventPayload] -> Affection ()
handle gd evs = do
state <- liftIO (atomically $ readTVar $ gameState gd)
smEvent state gd evs
update :: GameData -> Double -> Affection ()
update gd dt = do
state <- liftIO $ atomically $ readTVar $ gameState gd
2020-10-28 10:48:58 +00:00
isStagePresent <- liftIO $ atomically $ isEmptyTMVar $ gameScene gd
if isStagePresent
2020-10-28 10:48:58 +00:00
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
smUpdate state gd dt
else
return ()
2020-10-16 23:53:25 +00:00
draw :: GameData -> Affection ()
draw gd = do
state <- liftIO (atomically $ readTVar $ gameState gd)
smDraw state gd
2020-09-23 23:26:47 +00:00
init :: IO GameData
init = GameData
<$> newEmptyTMVarIO
<*> newTVarIO Loading
<*> newTMVarIO (0, "Ohai!")
2020-09-23 23:26:47 +00:00
<*> (Subsystems
<$> (SubWindow <$> newTVarIO [])
<*> (SubMouse <$> newTVarIO [])
<*> (SubKeyboard <$> newTVarIO [])
<*> (SubTranslator <$> newTVarIO [])
)
<*> newTVarIO (M.fromList [])
<*> newTVarIO True
2020-10-28 10:48:58 +00:00
<*> newTVarIO Nothing