pituicat/src/Main.hs

130 lines
3.6 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 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