pituicat/src/Main.hs

120 lines
3.2 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Main where
import Affection
import qualified Data.Text as T
import SDL (($=), get)
import qualified SDL
import qualified SDL.Internal.Numbered as 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 Data.Maybe (isJust)
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 3 3
}
}
, SDL.Windowed
)
]
} :: AffectionConfig GameData
withAffection config
preLoad :: GameData -> Affection ()
preLoad _ = 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 1 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