tracer/src/Main.hs

{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import Affection as A

import Data.Ecstasy

import qualified SDL

import NanoVG hiding (V2(..), V3(..))

import Linear

import Foreign.C.Types (CInt(..))

import Data.Maybe (fromJust)

import Control.Monad (when)

-- internal imports

import Types hiding (draw)
import StateMachine ()
import Init
import Util

foreign import ccall unsafe "glewInit"
  glewInit :: IO CInt

main :: IO ()
main = do
  let config = AffectionConfig
        { initComponents = All
        , windowTitle    = "Tracer"
        , windowConfigs  = [
          ( 0
          , SDL.defaultWindow
            { SDL.windowInitialSize = V2 1280 720
            , SDL.windowResizable   = True
            , SDL.windowOpenGL      = Just SDL.defaultOpenGL
              { SDL.glProfile = SDL.Core SDL.Normal 3 3
              }
            }
          )
          ]
        , canvasSize     = Nothing
        , preLoop        = pre >> smLoad Load
        , eventLoop      = handle
        , updateLoop     = update
        , drawLoop       = draw
        , loadState      = Init.init
        , cleanUp        = clean
        , initScreenMode = SDL.Windowed
        }
  withAffection config

pre :: Affection UserData ()
pre = do
  ad <- A.get
  ud <- getAffection
  threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad)
  SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad)
  let Subsystems w m k j t = subsystems ud
  _ <- partSubscribe w (fitViewport (1280/720))
  _ <- partSubscribe w exitOnWindowClose
  _ <- partSubscribe k toggleFullScreen
  _ <- partSubscribe k quitGame
  u <- partSubscribe j cacheJoypad
  (ws, _) <- yieldSystemT (0, defStorage) (return ())
  putAffection ud
    { threadContext = Just threadCtx
    , window     = Just (snd $ head $ drawWindows ad)
    , worldState = ws
    , joyUUID    = u
    }

quitGame :: KeyboardMessage -> Affection UserData ()
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
  | SDL.keysymKeycode sym == SDL.KeycodeEscape = quit
  | SDL.keysymKeycode sym == SDL.KeycodeF5 = do
    ad <- A.get
    ud <- getAffection
    when (state ud == Main WorldMap || state ud == Main MindMap) $ do
      let Subsystems w m k j t = subsystems ud
      mapM_ (partUnSubscribe w) (uuid ud)
      mapM_ (partUnSubscribe m) (uuid ud)
      mapM_ (partUnSubscribe k) (uuid ud)
      mapM_ (partUnSubscribe j) (uuid ud)
      mapM_ (partUnSubscribe t) (uuid ud)
      SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad)
      (ws, _) <- yieldSystemT (0, defStorage) (return ())
      putAffection ud
        { worldState = ws
        , state = Load
        }
      smLoad Load
  | otherwise                                  = return ()
quitGame _ = return ()

toggleFullScreen :: KeyboardMessage -> Affection UserData ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
  | otherwise                               = return ()
toggleFullScreen _ = return ()

update :: Double -> Affection UserData ()
update dt = do
  ud <- getAffection
  smUpdate (state ud) dt

draw :: Affection UserData ()
draw = do
  ud <- getAffection
  liftIO $ beginFrame (nano ud) 1280 720 1
  smDraw (state ud)
  liftIO $ endFrame (nano ud)

handle :: [SDL.EventPayload] -> Affection UserData ()
handle evs = do
  s <- state <$> getAffection
  smEvent s evs

exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose (MsgWindowClose _ _) = do
  liftIO $ logIO A.Debug "Window Closed"
  quit
exitOnWindowClose _ = return ()

clean :: UserData -> IO ()
clean ud =
  SDL.glDeleteContext $ fromJust $ threadContext ud