content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE MultiWayIf #-}
  {-# LANGUAGE FlexibleContexts #-}
  --------------------------------------------------------------------
  -- |
  -- Copyright :  (c) 2014 Edward Kmett
  -- License   :  BSD2
  -- Maintainer:  Edward Kmett <ekmett@gmail.com>
  -- Stability :  experimental
  -- Portability: non-portable
  --
  --------------------------------------------------------------------
  module Main where
  
  import Control.Applicative
  import Control.Concurrent
  import Control.Exception
  import Control.Exception.Lens
  import Control.Lens hiding (assign)
  import Control.Lens.Extras (is)
  import Control.Monad hiding (forM_)
  import Control.Monad.Reader
  import Control.Monad.State hiding (get)
  import Data.Default
  import Data.FileEmbed
  import Data.Monoid
  import Data.StateVar
  import Foreign
  import Foreign.C
  import GHC.Conc
  import Graphics.GL.Core41
  import SDL.Raw
  import Linear
  import Numeric (showFFloat)
  import Options.Applicative
  import Prelude hiding (init)
  import Quine.Camera
  import Quine.Debug
  import Quine.Display
  import Quine.Env
  import Quine.Exception
  import Quine.GL
  import Quine.GL.Error
  import Quine.GL.Object
  import Quine.GL.Program
  import Quine.GL.Shader
  import Quine.GL.Types
  import Quine.GL.Uniform
  import Quine.GL.Version as GL
  import Quine.GL.VertexArray
  import Quine.Input
  import Quine.Meter
  import Quine.Monitor
  import Quine.Options
  import Quine.SDL as SDL
  import Quine.Simulation
  import Quine.System
  import System.Exit
  import System.FilePath
  import System.IO
  
  #include "locations.h"
  
  -- * State
  
  main :: IO ()
  main = runInBoundThread $ withCString "quine" $ \windowName -> do
    -- parse options
    opts <- execParser $ info (helper <*> parseOptions) $
      fullDesc
      <> progDesc "quine"
      <> header "Quine"
  
    -- be careful with exceptions
    setUncaughtExceptionHandler $ \ e -> if
      | is _Shutdown e -> return ()
      | otherwise -> do
        hPrint stderr e
        hFlush stderr
        exitFailure
  
    -- set up EKG
    ekg <- forkMonitor opts
  
    label "sdl.version" ekg >>= ($= show SDL.version)
  
    -- start SDL
    init SDL_INIT_EVERYTHING >>= err
    contextMajorVersion $= 3
    contextMinorVersion $= 3
    contextProfileMask  $= SDL_GL_CONTEXT_PROFILE_CORE
    redSize   $= 5
    greenSize $= 5
    blueSize  $= 5
    depthSize $= 16
    doubleBuffer $= True
    let w = opts^.optionsWindowWidth
        h = opts^.optionsWindowHeight
        flags = SDL_WINDOW_OPENGL
            .|. SDL_WINDOW_SHOWN
            .|. SDL_WINDOW_RESIZABLE
            .|. (if opts^.optionsHighDPI then SDL_WINDOW_ALLOW_HIGHDPI else 0)
            .|. (if | not (opts^.optionsFullScreen) -> 0
                    | opts^.optionsFullScreenNormal -> SDL_WINDOW_FULLSCREEN
                    | otherwise                     -> SDL_WINDOW_FULLSCREEN_DESKTOP)
    window <- createWindow windowName SDL_WINDOWPOS_CENTERED SDL_WINDOWPOS_CENTERED (fromIntegral w) (fromIntegral h) flags >>= errOnNull
  
    -- start OpenGL
    cxt <- glCreateContext window >>= errOnNull
    makeCurrent window cxt
  
    when (opts^.optionsDebug) installDebugHook
  
    label "gl.vendor" ekg           >>= ($= vendor)
    label "gl.renderer" ekg         >>= ($= renderer)
    label "gl.version" ekg          >>= ($= show GL.version)
    label "gl.shading.version" ekg  >>= ($= show shadingLanguageVersion)
    label "gl.shading.versions" ekg >>= ($= show shadingLanguageVersions)
  
    -- glEnable gl_FRAMEBUFFER_SRGB
  
    throwErrors
    fc <- counter "quine.frame" ekg
    vw <- gauge "viewport.width" ekg
    vh <- gauge "viewport.height" ekg
    let sys = Env ekg opts fc vw vh
        dsp = Display
          { _displayWindow            = window
          , _displayGL                = cxt
          , _displayFullScreen        = opts^.optionsFullScreen
          , _displayWindowSize        = (fromIntegral w, fromIntegral h)
          , _displayWindowSizeChanged = True
          , _displayMinimized         = False
          , _displayHasMouseFocus     = True
          , _displayHasKeyboardFocus  = True
          , _displayVisible           = True
          , _displayMeter             = def
          }
    relativeMouseMode $= True -- switch to relative mouse mouse initially
    sim <- createSimulation ekg () ()
    handling id print (runReaderT (evalStateT core $ System dsp def def sim) sys) `finally` do
      glDeleteContext cxt
      destroyWindow window
      quit
      exitSuccess
  
  translate :: Vec3 -> Mat4
  translate v = identity & translation .~ v
  
  core :: (MonadIO m, MonadState s m, HasSystem s (), MonadReader e m, HasEnv e, HasOptions e) => m a
  core = do
    liftIO (getDir "shaders") >>= \ ss -> buildNamedStrings ss ("/shaders"</>)
    screenShader <- compile ["/shaders"] GL_VERTEX_SHADER   "shaders/screen.vert"
    sceneShader  <- compile ["/shaders"] GL_FRAGMENT_SHADER =<< view optionsFragment
    scn <- link [screenShader,sceneShader]
    emptyVAO <- gen
    iResolution        <- programUniform2f scn `liftM` uniformLocation scn "iResolution"
    iGlobalTime        <- (mapStateVar realToFrac realToFrac . programUniform1f scn) `liftM` uniformLocation scn "iGlobalTime"
    iPhysicsAlpha      <- (mapStateVar realToFrac realToFrac . programUniform1f scn) `liftM` uniformLocation scn "iPhysicsAlpha"
    iCamera            <- programUniform3f scn `liftM` uniformLocation scn "iCamera" -- yaw, pitch, fovy
    iProjection        <- (SettableStateVar . uniformMat4) `liftM` uniformLocation scn "iProjection"
    iInverseProjection <- (SettableStateVar . uniformMat4) `liftM` uniformLocation scn "iProjection"
    iView              <- (SettableStateVar . uniformMat4) `liftM` uniformLocation scn "iView"
    iInverseView       <- (SettableStateVar . uniformMat4) `liftM` uniformLocation scn "iInverseView"
    throwErrors
    currentProgram   $= scn
    boundVertexArray $= emptyVAO
    forever $ do
      (alpha,t) <- simulate $ poll $ \e -> handleDisplayEvent e >> handleInputEvent e
      displayMeter %= tick t
  
      displayFPS <- uses displayMeter fps
      physicsFPS <- uses simulationMeter fps
      let title = showString "quine (display "
              $ showFFloat (Just 1) displayFPS
              $ showString " fps, physics "
              $ showFFloat (Just 1) physicsFPS ")"
      use displayWindow >>= liftIO . withCString title . setWindowTitle
  
      updateCamera
      resizeDisplay
      render $ do
        (w,h) <- use displayWindowSize
        let wf = fromIntegral w
            hf = fromIntegral h
        c <- use camera
        let cameraQuat = axisAngle (V3 1 0 0) (c^.pitch) * axisAngle (V3 0 1 0) (c^.yaw)
        let inverseCameraQuat = axisAngle (V3 0 1 0) (-c^.yaw) * axisAngle (V3 1 0 0) (-c^.pitch)
        iResolution        $= V2 wf hf
        iProjection        $= perspective (c^.fovy) (wf/hf) (c^.nearZ) (c^.farZ)
        iInverseProjection $= inversePerspective (c^.fovy) (wf/hf) (c^.nearZ) (c^.farZ)
        iView              $= m33_to_m44 (fromQuaternion cameraQuat)
        iInverseView       $= m33_to_m44 (fromQuaternion inverseCameraQuat)
        iCamera            $= V3 (c^.yaw) (c^.pitch) (c^.fovy)
        iGlobalTime        $= t
        iPhysicsAlpha      $= alpha
        glDrawArrays GL_TRIANGLES 0 3
  
  render :: (MonadIO m, MonadReader e m, HasEnv e, MonadState s m, HasDisplay s) => m () -> m ()
  render kernel = do
    inc =<< view (env.frameCounter)
    glClearColor 0 0 0 1
    glClear $ GL_COLOR_BUFFER_BIT .|. GL_STENCIL_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT
    kernel
    w <- use displayWindow
    liftIO $ glSwapWindow w
  