Render.hs

-- | 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

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

setCol :: Col -> IO ()
setCol !(Col r g b) = color (Color3 r g b)

setColAlpha :: Col -> Float -> IO ()
setColAlpha !(Col r g b) !a = color (Color4 r g b a)

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

renderQuad :: Quad -> IO ()
renderQuad (Quad (x1,y1) (x2,y2)) = 
  renderPrimitive Quads $ do
    vertex (Vertex2 x1 y1)
    vertex (Vertex2 x2 y1)
    vertex (Vertex2 x2 y2)
    vertex (Vertex2 x1 y2)

-- | Renders the outer box as a quad
renderOuterBoxQuad :: AbsBox -> IO ()
renderOuterBoxQuad = renderQuad . absboxOuterQuad

-- | Renders the inner box as a quad
renderInnerBoxQuad :: AbsBox -> IO ()
renderInnerBoxQuad = renderQuad . absboxInnerQuad

-- | Renders the gap quad (useful for debugging)
renderGapBoxQuad :: AbsBox -> IO ()
renderGapBoxQuad = renderQuad . absboxGapQuad

-- | Renders the bounding box quad (useful for debugging)
renderBoundingBoxQuad :: AbsBox -> IO ()
renderBoundingBoxQuad = renderQuad . absboxBoundingQuad

--------------------------------------------------------------------------------
-- * Render box outlines

renderQuadOutline :: Quad -> IO ()
renderQuadOutline (Quad (x1,y1) (x2,y2)) = 
  renderPrimitive LineLoop $ do
    vertex (Vertex2 x1 y1)
    vertex (Vertex2 x2 y1)
    vertex (Vertex2 x2 y2)
    vertex (Vertex2 x1 y2)

-- | Renders the outer box as a quad
renderOuterBoxOutline :: AbsBox -> IO ()
renderOuterBoxOutline  = renderQuadOutline . absboxOuterQuad

-- | Renders the inner box as a quad
renderInnerBoxOutline  :: AbsBox -> IO ()
renderInnerBoxOutline  = renderQuadOutline . absboxInnerQuad

-- | Renders the gap quad (useful for debugging)
renderGapBoxOutline :: AbsBox -> IO ()
renderGapBoxOutline = renderQuadOutline . absboxGapQuad

-- | Renders the bounding box quad (useful for debugging)
renderBoundingBoxOutline :: AbsBox -> IO ()
renderBoundingBoxOutline = renderQuadOutline . absboxBoundingQuad

--------------------------------------------------------------------------------
-- * Render lines

-- TODO: finetune line rendering (retina display, antialising, position hinting based on width, etc...)
renderLine :: Col -> Double -> Pos -> Pos -> IO ()
renderLine !col !lwidth !(Pos x1 y1) !(Pos x2 y2) = do
  setCol col
  lineWidth $= double2Float lwidth
  let hwidth = 0.5 * lwidth  
  renderPrimitive Lines $ do
    vertex $ Vertex2 (dround x1) (dround y1) 
    vertex $ Vertex2 (dround x2) (dround y2)
  where
    dround :: Double -> Double
    dround !x = fromIntegral (round x :: Int)

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

-- | Renders a multifont glyph with the given color.
renderMFG :: Pos -> Col -> MultiFontGlyph -> IO ()
renderMFG !pos !col !(MFG ftex bufloc) = do
  setCol col
  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 ()

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