{-# 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, unless) 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 Util import Scenes.Test instance Affectionate GameData where preLoop = preLoad handleEvents = handle update = Main.update draw = Main.draw loadState = Main.init cleanUp _ = return () hasNextStep = liftIO . readTVarIO . gameRunning main :: IO () main = do let config = AffectionConfig { initComponents = All , windowTitle = "Pituicat" , windowConfigs = [ ( 0 , SDL.defaultWindow { SDL.windowInitialSize = V2 800 600 , SDL.windowResizable = False , 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 translatorUUID <- partSubscribe (subKeyboard $ gameSubsystems gd) (\mesg -> case mesg of (MsgKeyboardEvent time _ motion False keysym) -> do translator <- liftIO $ readTVarIO (gameActionTranslation gd) case ( SDL.keysymScancode keysym , translateSDLModifiers (SDL.keysymModifier keysym) ) `M.lookup` translator of Just action -> partEmit (subTranslator $ gameSubsystems gd) (TranslatorMessage action time motion) Nothing -> globalKeyHandle gd mesg _ -> return () ) windowCloseUUID <- partSubscribe (subWindow $ gameSubsystems gd) (\mesg -> case mesg of MsgWindowClose _ _ -> liftIO $ atomically $ writeTVar (gameRunning gd) False MsgWindowResize {} -> fitViewport (800 / 600) mesg _ -> return () ) liftIO $ atomically $ writeTVar (gameGeneralClean gd) [translatorUUID, windowCloseUUID] handle :: GameData -> [SDL.EventPayload] -> Affection () handle gd evs = do state <- liftIO (readTVarIO $ gameState gd) smEvent state gd evs update :: GameData -> Double -> Affection () update gd dt = do loadProgress <- liftIO $ atomically $ readTMVar $ gameStateLoadProgress gd when (fst loadProgress < 1) $ liftIO (logIO Verbose ("Progress: " <> snd loadProgress)) state <- liftIO $ readTVarIO $ 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 evHandler <- partSubscribe (subTranslator $ gameSubsystems gd) (onEvents sceneContainer) liftIO $ atomically $ writeTVar (gameSceneClean gd) (Just evHandler) else smUpdate state gd dt else liftIO $ logIO Error "No Stage to play on" draw :: GameData -> Affection () draw gd = do state <- liftIO (readTVarIO $ 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 unless (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 defaultTranslation <*> newTVarIO True <*> newTVarIO Nothing <*> newTVarIO Nothing <*> newTVarIO [] <*> newTVarIO Nothing