pituicat/src/Main.hs

157 lines
4.4 KiB
Haskell
Raw Normal View History

2020-09-23 23:26:47 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-08-30 15:36:32 +00:00
module Main where
2020-09-23 23:26:47 +00:00
import Affection
2020-12-06 07:14:50 +00:00
import SDL (($=), get)
2020-09-23 23:26:47 +00:00
import qualified SDL
2020-12-06 07:14:50 +00:00
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
2020-09-23 23:26:47 +00:00
2020-10-28 10:48:58 +00:00
import qualified Graphics.Rendering.OpenGL as GL
2021-07-09 17:39:50 +00:00
import Control.Monad (when, void, unless)
2020-12-06 07:14:50 +00:00
2020-09-23 23:26:47 +00:00
import Control.Concurrent.STM
import qualified Data.Map.Strict as M
2020-12-06 07:14:50 +00:00
import Data.String (fromString)
2020-09-23 23:26:47 +00:00
import Linear
-- internal imports
2020-12-14 02:12:33 +00:00
import StateMachine()
2020-09-23 23:26:47 +00:00
import Types
2020-10-28 10:48:58 +00:00
import Classes
2021-01-11 23:51:58 +00:00
import Util
2020-10-28 10:48:58 +00:00
import Scenes.Test
2020-09-23 23:26:47 +00:00
instance Affectionate GameData where
preLoop = preLoad
2020-10-16 23:53:25 +00:00
handleEvents = handle
update = Main.update
draw = Main.draw
2020-09-23 23:26:47 +00:00
loadState = Main.init
cleanUp _ = return ()
2021-07-09 17:39:50 +00:00
hasNextStep = liftIO . readTVarIO . gameRunning
2020-09-23 23:26:47 +00:00
2020-08-30 15:36:32 +00:00
main :: IO ()
2020-09-23 23:26:47 +00:00
main = do
let config = AffectionConfig
{ initComponents = All
, windowTitle = "Pituicat"
, windowConfigs =
[ ( 0
, SDL.defaultWindow
{ SDL.windowInitialSize = V2 800 600
2021-01-11 07:22:07 +00:00
, SDL.windowResizable = False
2020-09-23 23:26:47 +00:00
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
2021-01-03 09:14:36 +00:00
{ SDL.glProfile = SDL.Core SDL.Normal 4 0
2020-09-23 23:26:47 +00:00
}
}
, SDL.Windowed
)
]
} :: AffectionConfig GameData
withAffection config
preLoad :: GameData -> Affection ()
2021-01-11 11:01:07 +00:00
preLoad gd = do
2021-01-11 23:51:58 +00:00
translatorUUID <- partSubscribe
(subKeyboard $ gameSubsystems gd)
2021-01-11 23:51:58 +00:00
(\mesg ->
case mesg of
2021-07-09 17:39:50 +00:00
(MsgKeyboardEvent time _ motion False keysym) -> do
translator <- liftIO $ readTVarIO (gameActionTranslation gd)
2021-01-11 23:51:58 +00:00
case
2021-07-09 17:39:50 +00:00
( SDL.keysymScancode keysym
, translateSDLModifiers (SDL.keysymModifier keysym)
) `M.lookup`
translator
2021-01-11 23:51:58 +00:00
of
Just action ->
partEmit
(subTranslator $ gameSubsystems gd)
(TranslatorMessage action time motion)
Nothing ->
globalKeyHandle gd mesg
_ ->
return ()
2021-01-11 11:01:07 +00:00
)
2021-01-11 23:51:58 +00:00
windowCloseUUID <- partSubscribe
(subWindow $ gameSubsystems gd)
2021-01-11 23:51:58 +00:00
(\mesg -> case mesg of
2021-07-09 17:39:50 +00:00
MsgWindowClose _ _ ->
2021-01-11 23:51:58 +00:00
liftIO $ atomically $ writeTVar (gameRunning gd) False
2021-07-09 17:39:50 +00:00
MsgWindowResize {} ->
2021-01-11 23:51:58 +00:00
fitViewport (800 / 600) mesg
_ ->
return ()
)
2021-01-11 23:51:58 +00:00
liftIO $ atomically $ writeTVar
(gameGeneralClean gd)
[translatorUUID, windowCloseUUID]
2020-10-16 23:53:25 +00:00
handle :: GameData -> [SDL.EventPayload] -> Affection ()
handle gd evs = do
2021-07-09 17:39:50 +00:00
state <- liftIO (readTVarIO $ gameState gd)
2020-10-16 23:53:25 +00:00
smEvent state gd evs
update :: GameData -> Double -> Affection ()
update gd dt = do
2021-01-11 23:51:58 +00:00
loadProgress <- liftIO $ atomically $ readTMVar $ gameStateLoadProgress gd
when (fst loadProgress < 1) $
liftIO (logIO Verbose ("Progress: " <> snd loadProgress))
2021-07-09 17:39:50 +00:00
state <- liftIO $ readTVarIO $ gameState gd
2020-12-06 07:14:50 +00:00
isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd
if isStagePresent
2020-10-28 10:48:58 +00:00
then do
2020-12-06 07:14:50 +00:00
liftIO $ logIO Verbose "Stage is present"
2020-10-28 10:48:58 +00:00
(Stage sceneContainer) <- liftIO $ atomically $ readTMVar $ gameScene gd
sceneLoaded <- isSceneLoaded sceneContainer
2020-12-06 07:14:50 +00:00
if not sceneLoaded
then do
liftIO $ logIO Verbose "Loading scene"
smLoad state gd
2021-01-11 23:51:58 +00:00
evHandler <- partSubscribe
(subTranslator $ gameSubsystems gd)
(onEvents sceneContainer)
liftIO $ atomically $ writeTVar (gameSceneClean gd) (Just evHandler)
else
smUpdate state gd dt
else
2020-12-06 07:14:50 +00:00
liftIO $ logIO Error "No Stage to play on"
2020-10-16 23:53:25 +00:00
draw :: GameData -> Affection ()
draw gd = do
2021-07-09 17:39:50 +00:00
state <- liftIO (readTVarIO $ gameState gd)
2020-12-06 07:14:50 +00:00
liftIO $ logIO Verbose (fromString $ "now drawing: " <> show state)
2020-12-14 02:12:33 +00:00
GL.clearColor $= GL.Color4 0 0 0 1
2020-10-16 23:53:25 +00:00
smDraw state gd
2020-12-06 07:14:50 +00:00
err <- SDL.get GL.errors
2021-07-09 17:39:50 +00:00
unless (null err) (liftIO $ logIO Error ("loop errors: " <> fromString (show err)))
2020-10-16 23:53:25 +00:00
2020-09-23 23:26:47 +00:00
init :: IO GameData
2020-12-06 07:14:50 +00:00
init = do
GL.blend $= GL.Enabled
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
GameData
2021-07-09 17:39:50 +00:00
<$> (newTMVarIO . Stage =<< (initScene :: IO Test))
2020-12-06 07:14:50 +00:00
<*> newTVarIO Loading
<*> newTMVarIO (0, "Ohai!")
<*> (Subsystems
<$> (SubWindow <$> newTVarIO [])
<*> (SubMouse <$> newTVarIO [])
<*> (SubKeyboard <$> newTVarIO [])
<*> (SubTranslator <$> newTVarIO [])
)
2021-01-11 23:51:58 +00:00
<*> newTVarIO defaultTranslation
2020-12-06 07:14:50 +00:00
<*> newTVarIO True
<*> newTVarIO Nothing
<*> newTVarIO Nothing
2021-01-11 23:51:58 +00:00
<*> newTVarIO []
<*> newTVarIO Nothing