content: 
  {-# LANGUAGE   RecordWildCards
               , LambdaCase
               , FlexibleContexts
               , RankNTypes
               , TypeFamilies #-}
  
  module App ( run
             , module AppDefs
             ) where
  
  import Control.Lens
  import Control.Monad.Reader
  import Control.Monad.State
  import Control.Monad.Trans.Either
  import Control.Monad.STM
  import Control.Monad.Trans.Control
  import Control.Concurrent.STM.TQueue
  import qualified Graphics.Rendering.OpenGL as GL
  import qualified Graphics.UI.GLFW as GLFW
  import Text.Printf
  import Data.Time
  import Data.Maybe
  
  import AppDefs
  import GLFWHelpers
  import GLHelpers
  import Timing
  import Trace
  import Font
  import FrameBuffer
  import QuadRendering
  import qualified BoundedSequence as BS
  import Experiment
  import Median
  
  processAllEvents :: MonadIO m => TQueue a -> (a -> m ()) -> m ()
  processAllEvents tq processEvent =
      (liftIO . atomically $ tryReadTQueue tq) >>= \case
          Just e -> processEvent e >> processAllEvents tq processEvent
          _      -> return ()
  
  processGLFWEvent :: GLFWEvent -> AppIO ()
  processGLFWEvent ev = do
      case ev of
          GLFWEventError e s -> do
             window <- view aeWindow
             liftIO $ do
                 traceS TLError $ "GLFW Error " ++ show e ++ " " ++ show s
                 GLFW.setWindowShouldClose window True
          GLFWEventKey win k _sc ks _mk | ks == GLFW.KeyState'Pressed ->
              case k of
                  GLFW.Key'Escape -> do
                      lastPress <- use asLastEscPress
                      tick      <- use asCurTick
                      -- Only close when ESC has been pressed twice quickly
                      when (tick - lastPress < 0.5) .
                          liftIO $ GLFW.setWindowShouldClose win True
                      asLastEscPress .= tick
                  GLFW.Key'T     -> view aeFB >>= \fb -> liftIO $ saveFrameBufferToPNG fb .
                                      map (\c -> if c `elem` ['/', '\\', ':', ' '] then '-' else c)
                                        . printf "Screenshot-%s.png" =<< show <$> getZonedTime
                  GLFW.Key'V     -> asVSync %= not >> setVSync
                                    -- Exit and switch to a different experiment
                  GLFW.Key'Minus -> onRenderSettingsChage >> left ExpPrev
                  GLFW.Key'Equal -> onRenderSettingsChage >> left ExpNext
                  _              -> return ()
          GLFWEventFramebufferSize _win _w _h -> resize
          _ -> return ()
      runExperimentState $ experimentGLFWEvent ev -- Pass on event to the experiment
  
  -- Handle changes in window and frame buffer size
  resize :: (MonadReader AppEnv m, MonadState AppState m, MonadIO m) => m ()
  resize = do
      window <- view aeWindow
      fb     <- view aeFB
      liftIO $ do (w, h) <- GLFW.getFramebufferSize window
                  setupViewport w h
                  resizeFrameBuffer fb w h
      onRenderSettingsChage
  
  onRenderSettingsChage :: MonadState AppState m => m ()
  onRenderSettingsChage = do
      -- Reset frame time measurements and frame index when the rendering settings have changed
      asFrameTimes %= BS.clear
      asFrameIdx   .= 0
  
  draw :: AppIO ()
  draw = do
      AppEnv   { .. } <- ask
      AppState { .. } <- get
      -- Clear
      liftIO $ do
          GL.clearColor GL.$= (GL.Color4 1 0 1 1 :: GL.Color4 GL.GLclampf)
          GL.clear [GL.ColorBuffer, GL.DepthBuffer]
          GL.depthFunc GL.$= Just GL.Lequal
      -- Allow the experiment to draw into the framebuffer
      runExperimentState $ experimentDraw _aeFB _asCurTick
      -- Render everything quad based
      (liftIO $ GLFW.getFramebufferSize _aeWindow) >>= \(w, h) ->
          void . withQuadRenderBuffer _aeQR w h $ \qb -> do
              ftStr          <- updateAndReturnFrameTimes
              (fbWdh, fbHgt) <- liftIO $ getFrameBufferDim _aeFB
              expDesc        <- use asExperimentDesc
              vsync          <- use asVSync
              statusString   <- (++) ( "2x[ESC] Exit | Screensho[T] | %ix%i | %s\n" ++
                                       "[V]Sync: %s | Exp. [-][=] %s | "
                                     )
                                <$> runExperimentState experimentStatusString
              liftIO $ do
                  -- Draw frame buffer contents
                  drawFrameBuffer _aeFB qb 0 0 (fromIntegral w) (fromIntegral h)
                  -- FPS counter and mode / statistics / key bindings display
                  let statusStringHgt = (succ . length $ filter (== '\n') statusString) * 12
                  drawQuad qb
                           0                (fromIntegral h - fromIntegral statusStringHgt)
                           (fromIntegral w) (fromIntegral h)
                           2
                           FCBlack
                           (TRBlend 0.5)
                           Nothing
                           QuadUVDefault
                  drawTextWithShadow _aeFontTexture qb 3 (h - 12) $ printf
                      statusString
                      fbWdh
                      fbHgt
                      ftStr
                      (if vsync then "On" else "Off")
                      expDesc
    where drawTextWithShadow :: GL.TextureObject -> QuadRenderBuffer -> Int -> Int -> String -> IO ()
          drawTextWithShadow tex qb x y str = do
              drawText tex qb (x + 1) (y - 1) 0x00000000 str
              drawText tex qb  x       y      0x0000FF00 str
  
  updateAndReturnFrameTimes :: MonadState AppState m => m String
  updateAndReturnFrameTimes = do
      frameTimes <- use $ asFrameTimes.to BS.toList
      curTick    <- use asCurTick
      asFrameTimes %= BS.push_ curTick
      let frameDeltas      = case frameTimes of (x:xs) -> goFD x xs; _ -> []
          goFD prev (x:xs) = (prev - x) : goFD x xs
          goFD _ []        = []
          fdMedian         = fromMaybe 1 $ median frameDeltas
          fdWorst          = case frameDeltas of [] -> 0; xs -> maximum xs
          fdBest           = case frameDeltas of [] -> 0; xs -> minimum xs
       in return $ printf "%.2fFPS/%.1fms (L: %.2fms, H: %.2fms)"
                          (1.0 / fdMedian)
                          (fdMedian * 1000)
                          (fdBest   * 1000)
                          (fdWorst  * 1000)
  
  setVSync :: (MonadIO m, MonadState AppState m) => m ()
  setVSync = use asVSync >>= \vsync -> liftIO . GLFW.swapInterval $ if vsync then 1 else 0
  
  run :: AppEnv -> AppState -> IO ()
  run env st =
      -- Setup state, reader, OpenGL / GLFW and enter loop
      flip runReaderT env . flip evalStateT st $ do
          resize
          setVSync
          experimentLoop 2
    where -- Initialize / shutdown / switch experiment
          experimentLoop :: Int -> StateT AppState (ReaderT AppEnv IO) ()
          experimentLoop expIdx = do
              -- We use the either to break out of the current experiment, and either exit
              -- or switch to a different one
              r <- runEitherT $ do
                  -- Because of the existential type we have to call withExperiment from
                  -- inside the lambda where we pattern match it out of the AnyWithExperiment.
                  -- Also use monad-control to bring our stack across the IO of withExperiment
                  curExp <- (!! expIdx) <$> view aeExperiments
                  control $ \runMonad ->
                      (\(AnyWithExperiment withExperiment') ->
                          liftIO $ withExperiment' (runMonad . withExperimentInner expIdx)
                      ) curExp
              numExp <- length <$> view aeExperiments
              -- Exit or keep running with a different experiment?
              case r of
                  Left ExpNext -> experimentLoop $ wrapExpIdx (expIdx + 1) numExp
                  Left ExpPrev -> experimentLoop $ wrapExpIdx (expIdx - 1) numExp
                  Left ExpExit -> return ()
                  Right ()     -> return ()
                where wrapExpIdx idx numExp | idx < 0       = numExp - 1
                                            | idx >= numExp = 0
                                            | otherwise     = idx
          -- Experiment setup complete, store state and enter main loop
          withExperimentInner :: Experiment e => Int -> e -> AppIO ()
          withExperimentInner expIdx expState = do
              let name = experimentName expState
              liftIO . traceS TLInfo $ "Switching to experiment: " ++ name
              numExp <- length <$> view aeExperiments
              asExperimentDesc .= printf "%i/%i: %s" (expIdx + 1) numExp name
              asExperiment     .= AnyExperiment expState
              mainLoop
          -- Main loop
          mainLoop :: AppIO ()
          mainLoop = do
              window <- view aeWindow
              asCurTick <~ liftIO getTick
              tqGLFW <- view aeGLFWEventsQueue
              processAllEvents tqGLFW processGLFWEvent
              -- GLFW / OpenGL
              draw
              liftIO $ {-# SCC swapAndPoll #-} do
                  -- GL.flush
                  -- GL.finish
                  GLFW.swapBuffers window
                  GLFW.pollEvents
                  traceOnGLError $ Just "main loop"
              -- Drop the first three frame deltas, they are often outliers
              use asFrameIdx >>= \idx -> when (idx < 3) (asFrameTimes %= BS.clear)
              asFrameIdx += 1
              -- Done?
              flip unless mainLoop =<< liftIO (GLFW.windowShouldClose window)
  
  