{-# LANGUAGE OverloadedStrings #-} module Main where import Affection import qualified Data.Text as T import qualified SDL import Control.Concurrent.STM import qualified Data.Map.Strict as M import Linear -- internal imports import StateMachine import Types instance Affectionate GameData where preLoop = preLoad handleEvents = handle update = Main.update draw = Main.draw loadState = Main.init cleanUp _ = return () hasNextStep = liftIO . atomically . readTVar . gameRunning main :: IO () 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 () preLoad gd = liftIO $ do let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat view = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0) model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0) vertexArrayObject <- GL.genObjectName va <- newVertexArray atomically $ (writeTVar (gameScene gd) =<< (initScene :: IO Test)) 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 isStagePresent <- atomically $ isEmptyTMVar $ gamescene gd if isStagePresent then stage <- liftIO $ atomically $ readTVar $ gameScene gd then smLoad state gd else smUpdate state gd dt else return () draw :: GameData -> Affection () draw gd = do state <- liftIO (atomically $ readTVar $ gameState gd) smDraw state gd init :: IO GameData init = GameData <$> newEmptyTMVarIO <*> newTVarIO Loading <*> newTMVarIO (0, "Ohai!") <*> (Subsystems <$> (SubWindow <$> newTVarIO []) <*> (SubMouse <$> newTVarIO []) <*> (SubKeyboard <$> newTVarIO []) <*> (SubTranslator <$> newTVarIO []) ) <*> newTVarIO (M.fromList []) <*> newTVarIO True