{-# 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 (gameState gd) Loading 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) progressMeter <- liftIO $ atomically (fst <$> readTMVar (gameStateLoadProgress gd)) if progressMeter < 0 then do -- liftIO (atomically (putTMVar (gameStateLoadProgress gd) (0, "Ohai!"))) smLoad state gd else smUpdate state gd dt draw :: GameData -> Affection () draw gd = do state <- liftIO (atomically $ readTVar $ gameState gd) smDraw state gd init :: IO GameData init = GameData <$> newTVarIO Loading <*> newTMVarIO (-1, "Ohai!") <*> newTMVarIO EmptyData <*> (Subsystems <$> (SubWindow <$> newTVarIO []) <*> (SubMouse <$> newTVarIO []) <*> (SubKeyboard <$> newTVarIO []) <*> (SubTranslator <$> newTVarIO []) ) <*> newTVarIO (M.fromList []) <*> newTVarIO True