-- | Low-level rendering. 
--
-- You shouldn't normally need to use this directly,
-- though boxes can be useful for highlighting.

{-# LANGUAGE BangPatterns #-}
module Graphics.Rendering.MiniTypeset.Render where

--------------------------------------------------------------------------------

import Data.Word
import Data.Char

import GHC.Float

import Control.Monad
import Data.IORef

import Graphics.Rendering.OpenGL as GL

import Graphics.Rendering.TrueType.STB

import Graphics.Rendering.MiniTypeset.Common
import Graphics.Rendering.MiniTypeset.Box
import Graphics.Rendering.MiniTypeset.FontTexture
import Graphics.Rendering.MiniTypeset.MultiFont

--------------------------------------------------------------------------------
-- * Render boxes

-- | Renders the outer box as a quad
renderOuterBoxQuad :: AbsBox -> IO ()
renderOuterBoxQuad (AbsBox (Pos x0 y0) (Box w h l r t b hgap vgap)) = do
  let x1 = x0 - l
      x2 = x0 + w + r
  let y1 = y0 - t
      y2 = y0 + h + b
  renderPrimitive Quads $ do
    vertex (Vertex2 x1 y1)
    vertex (Vertex2 x2 y1)
    vertex (Vertex2 x2 y2)
    vertex (Vertex2 x1 y2)

-- | Renders the inner box as a quad
renderInnerBoxQuad :: AbsBox -> IO ()
renderInnerBoxQuad (AbsBox (Pos x0 y0) (Box w h l r t b hgap vgap)) = do
  let x1 = x0
      x2 = x0 + w
  let y1 = y0 
      y2 = y0 + h
  renderPrimitive Quads $ do
    vertex (Vertex2 x1 y1)
    vertex (Vertex2 x2 y1)
    vertex (Vertex2 x2 y2)
    vertex (Vertex2 x1 y2)

-- | Renders the gap of a box (useful for debugging)
renderBoxGap :: AbsBox -> IO ()
renderBoxGap (AbsBox (Pos x0 y0) (Box w h l r t b hgap vgap)) = do

  renderPrimitive Quads $ do
 
    when (hgap > 0) $ do
      let x1 = x0 + w + r
          x2 = x1 + hgap
      let y1 = y0 - t
          y2 = y0 + h + b + vgap
      vertex (Vertex2 x1 y1)
      vertex (Vertex2 x2 y1)
      vertex (Vertex2 x2 y2)
      vertex (Vertex2 x1 y2)

    when (vgap > 0) $ do
      let x1 = x0 - l
          x2 = x0 + w + r {- + hgap -}  -- there should be no overlap, because it ruins blending
      let y1 = y0 + h + b
          y2 = y1 + vgap
      vertex (Vertex2 x1 y1)
      vertex (Vertex2 x2 y1)
      vertex (Vertex2 x2 y2)
      vertex (Vertex2 x1 y2)

--------------------------------------------------------------------------------
-- * Render characters

-- | Renders a multifont glyph with the given color.
renderMFG :: Pos -> Col -> MultiFontGlyph -> IO ()
renderMFG pos (Col colr colg colb) (MFG ftex bufloc) = do

  color (Color3 colr colg colb)
  renderChar' pos ftex bufloc 

--------------------------------------------------------------------------------

-- | Renders a single character. Note: the position will be the position
-- of the left end of the baseline of the character, not the top-left corner!
--
-- Returns the horizontal advancement.
--
renderCharAt :: Pos -> FontTexture -> Char -> IO Double
renderCharAt pos ftex ch = do
  bufloc <- lookupFontTexture ftex ch 
  renderChar' pos ftex bufloc
  let adv = advanceWidth (_locHM bufloc)
  return $ float2Double adv

renderCharAt_ :: Pos -> FontTexture -> Char -> IO ()
renderCharAt_ pos ftex ch = void $ renderCharAt pos ftex ch

--------------------------------------------------------------------------------
      
renderChar' :: Pos -> FontTexture -> BufLoc -> IO ()
renderChar' pos@(Pos x0 y0) ftex bufloc = do

  bufs <- readIORef (_ftexBufs ftex)
  let texBuf@(TexBuf texobj texsiz) = bufs!!(_locBufIdx bufloc)

  textureBinding Texture2D $=! Just texobj

  let (wi,hi) = _locBufSiz bufloc
      (s,t)   = _locBufXY  bufloc
      (p,q)   = _locBufOfs bufloc
      -- lsb     = leftSideBearing (_locHM bufloc)            -- already included in the offset?
      (x,y)   = (x0 + fromIntegral p , y0 + fromIntegral q)   -- tmp?
      wf = fromIntegral wi :: Double
      hf = fromIntegral hi :: Double

  texture Texture2D $=! Enabled
  blend     $=! Enabled
  blendFunc $=! (SrcAlpha,OneMinusSrcAlpha)

  let (texw,texh) = _ftexBufSize ftex
      ftexw = fromIntegral texw :: Double
      ftexh = fromIntegral texh :: Double
      fs, ft :: Int -> Double
      fs !j = (fromIntegral j + 1.0) / ftexw 
      ft !i = (fromIntegral i + 1.0) / ftexh 

  let g :: Double -> Double
      g x = fromIntegral (round x :: Int)

  let tc s t = texCoord (TexCoord2 (fs s) (ft t))
      vt x y = vertex   (Vertex2   (g  x) (g  y))

  renderPrimitive Quads $ do
    tc  s      t     ; vt  x      y
    tc (s+wi)  t     ; vt (x+wf)  y        
    tc (s+wi) (t+hi) ; vt (x+wf) (y+hf)        
    tc  s     (t+hi) ; vt  x     (y+hf)        

  blend $=! Disabled 
  texture Texture2D $=! Disabled

  return ()

--------------------------------------------------------------------------------