pituicat/src/Main.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Affection

import qualified Data.Text as T

import qualified SDL

import Control.Concurrent.STM

import qualified Data.Map.Strict as M

import Linear

-- internal imports

import StateMachine
import Types

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 gd = do
  liftIO $ atomically $ writeTVar (gameState gd) Loading
  

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
  state <- liftIO (atomically $ readTVar $ gameState gd)
  progressMeter <- liftIO $ atomically (fst <$> readTMVar (gameStateLoadProgress gd))
  if progressMeter < 0
  then do
    -- liftIO (atomically (putTMVar (gameStateLoadProgress gd) (0, "Ohai!")))
    smLoad state gd
  else
    smUpdate state gd dt

draw :: GameData -> Affection ()
draw gd = do
  state <- liftIO (atomically $ readTVar $ gameState gd)
  smDraw state gd

init :: IO GameData
init = GameData
  <$> newTVarIO Loading
  <*> newTMVarIO (-1, "Ohai!")
  <*> newTMVarIO EmptyData
  <*> (Subsystems
    <$> (SubWindow <$> newTVarIO [])
    <*> (SubMouse <$> newTVarIO [])
    <*> (SubKeyboard <$> newTVarIO [])
    <*> (SubTranslator <$> newTVarIO [])
    )
  <*> newTVarIO (M.fromList [])
  <*> newTVarIO True