154 lines
4.4 KiB
Haskell
154 lines
4.4 KiB
Haskell
{-# 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 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 . 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 = 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 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 time motion)
|
|
Nothing ->
|
|
globalKeyHandle gd mesg
|
|
_ ->
|
|
return ()
|
|
)
|
|
windowCloseUUID <- partSubscribe
|
|
(subWindow $ gameSubsystems gd)
|
|
(\mesg -> case mesg of
|
|
MsgWindowClose time win ->
|
|
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 (atomically $ readTVar $ 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 $ 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
|
|
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 (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 defaultTranslation
|
|
<*> newTVarIO True
|
|
<*> newTVarIO Nothing
|
|
<*> newTVarIO Nothing
|
|
<*> newTVarIO []
|
|
<*> newTVarIO Nothing
|