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)

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 $ partSubscribe
    (subKeyboard $ gameSubsystems gd)
    (\(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 ->
            return ()
      )
  void $ partSubscribe
    (subWindow $ gameSubsystems gd)
    (\(MsgWindowClose time win) ->
      atomically $ writeTVar (gameRunning gd) False
      )

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