{-# LANGUAGE OverloadedStrings #-} module Main where import Affection import SDL (($=), get) import qualified SDL import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Enum as SDL import qualified Graphics.Rendering.OpenGL as GL import Control.Monad (when, void) import Control.Concurrent.STM import qualified Data.Map.Strict as M import Data.String (fromString) import Linear -- internal imports import StateMachine() import Types import Classes import Scenes.Test 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 4 0 } } , SDL.Windowed ) ] } :: AffectionConfig GameData withAffection config preLoad :: GameData -> Affection () preLoad gd = do void $ generalSubscribe ((\(SubKeyboard t) -> t) $ subKeyboard $ gameSubsystems gd) (\(MsgKeyboardEvent when win motion False keysym) -> do translator <- liftIO $ atomically $ readTVar (gameActionTranslation gd) case ((SDL.keysymScancode keysym, SDL.keysymModifier keysym) `M.lookup` translator) of Just action -> partEmit (subTranslator $ gameSubsystems gd) (TranslatorMessage action when motion) Nothing -> return () ) 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 liftIO ((logIO Verbose) =<< (atomically $ (("Progress: " <>) . snd) <$> (readTMVar $ gameStateLoadProgress gd))) state <- liftIO $ atomically $ readTVar $ gameState gd isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd if isStagePresent then do liftIO $ logIO Verbose "Stage is present" (Stage sceneContainer) <- liftIO $ atomically $ readTMVar $ gameScene gd sceneLoaded <- isSceneLoaded sceneContainer if not sceneLoaded then do liftIO $ logIO Verbose "Loading scene" smLoad state gd else smUpdate state gd dt else liftIO $ logIO Error "No Stage to play on" draw :: GameData -> Affection () draw gd = do state <- liftIO (atomically $ readTVar $ gameState gd) liftIO $ logIO Verbose (fromString $ "now drawing: " <> show state) GL.clearColor $= GL.Color4 0 0 0 1 smDraw state gd err <- SDL.get GL.errors when (not $ null err) (liftIO $ logIO Error ("loop errors: " <> fromString (show err))) init :: IO GameData init = do GL.blend $= GL.Enabled GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 GameData <$> (newTMVarIO =<< (Stage <$> (initScene :: IO Test))) <*> newTVarIO Loading <*> newTMVarIO (0, "Ohai!") <*> (Subsystems <$> (SubWindow <$> newTVarIO []) <*> (SubMouse <$> newTVarIO []) <*> (SubKeyboard <$> newTVarIO []) <*> (SubTranslator <$> newTVarIO []) ) <*> newTVarIO (M.fromList []) <*> newTVarIO True <*> newTVarIO Nothing <*> newTVarIO Nothing