pituicat/src/Main.hs

{-# 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