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
import Control.Concurrent.MVar

-- internal imports

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

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

instance Affectionate UserData where
  preLoop      = (\ud -> pre ud >> smLoad Load ud)
  handleEvents = handle
  update       = Main.update
  draw         = Main.draw
  loadState    = Init.init
  cleanUp      = clean
  hasNextStep  = liftIO . readMVar . doNextStep

main :: IO ()
main = do
  let config = AffectionConfig
        { initComponents  = All
        , windowTitle     = "Tracer"
        , windowConfigs   =
          [ ( 0
            , SDL.defaultWindow
              { SDL.windowInitialSize     = V2 1280 720
              , SDL.windowResizable       = True
              , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
                { SDL.glProfile = SDL.Core SDL.Normal 3 3
                }
              }
            , SDL.Windowed
            )
          ]
        } :: AffectionConfig UserData
  withAffection config

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

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

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

update :: UserData -> Double -> Affection ()
update ud dt = do
  curState <- liftIO $ readMVar (state ud)
  smUpdate curState ud dt

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

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

exitOnWindowClose :: UserData -> WindowMessage -> Affection ()
exitOnWindowClose ud (MsgWindowClose _ _) = do
  liftIO $ logIO A.Debug "Window Closed"
  void $ liftIO $ swapMVar (doNextStep ud) False
exitOnWindowClose _ _ = return ()

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