pituicat/src/Main.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Affection

import qualified Data.Text as T

import SDL (($=), get)
import qualified SDL
import qualified SDL.Internal.Numbered as 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 Data.Maybe (isJust)

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 3 3
                }
              }
            , SDL.Windowed
            )
          ]
        } :: AffectionConfig GameData
  withAffection config

preLoad :: GameData -> Affection ()
preLoad _ = 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 1 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