-- | A simple layout engine to render text (and later also mathematics).

{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
module Graphics.Rendering.MiniTypeset.Layout where

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

import Control.Monad
import Data.IORef

import qualified Data.Map as Map ; import Data.Map (Map)

import GHC.Float

import Graphics.Rendering.TrueType.STB

import Graphics.Rendering.OpenGL as GL hiding ( Height , translate )

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

--------------------------------------------------------------------------------
-- * Relative position and size constants (mathematical coordinate system!)

subSupSize =  0.65 :: Double          -- Subscript \/ superscript relative sizes
supPos     =  0.40 :: Double          -- Superscript relative position
subPos     = -0.20 :: Double          -- Subscript relative position

underlinePos     = -0.10 :: Double      -- Underline relative position
overlinePos      =  0.10 :: Double      -- Overline relative position
strikeThroughPos = 0.48  :: Double      -- Strike-through relative position
horizLineWidth   = 0.045 :: Double      -- Text decoration line width

abovePos  =  0.15 :: Double
belowPos  = -0.15 :: Double

--------------------------------------------------------------------------------
-- * Subscript size indexing

-- | 0 is the default size, 1 is smaller, 2 is even smaller, etc (each subscript 
newtype SizeIndex
  = SizeIndex Int
  deriving (Eq,Ord,Show) 
 
succSizeIndex :: SizeIndex -> SizeIndex
succSizeIndex (SizeIndex n) = SizeIndex (n+1)

calculateSizeHeight :: Height -> SizeIndex -> Int
calculateSizeHeight (Height height) = go where
  go (SizeIndex n)
    | n == 0  = height
    | n == 1  = round (fromIntegral height * subSupSize)
    | n == 2  = round (fromIntegral height * subSupSize * subSupSize)
    | n == 3  = round (fromIntegral height * subSupSize * subSupSize * 0.8)
    | n >  3  = go (SizeIndex 3) 

--------------------------------------------------------------------------------
-- * The layout data type

-- | This data type is the output of the layout engine. The ``identifying'' part 
-- is retained, because everything is still relative, and only during the rendering
-- will positions become absolute. See 'dryrunLayout'
data Layout ident style
  = LoutGlyph !Pos !style !Col !Char !MultiFontGlyph
  | LoutGroup !Box   [Layout ident style]
  | LoutBox   !Box   (Layout ident style)
  | LoutOfs   !Pos   (Layout ident style)
  | LoutIdent !ident (Layout ident style)
  | LoutDecor !LayoutDecoration (Layout ident style)
  | LoutEmpty
  deriving (Show)  

data LayoutDecoration 
  = HorizLine 
      { _hlineCol       :: !Col 
      , _hlineVAlign    :: !VAlign
      , _hlineVPos      :: !Double 
      , _hlineLineWidth :: !Double 
      }
  deriving (Show)  

instance Translate (Layout ident style) where
  translate = translateLayout 

translateLayout :: Pos -> Layout ident style -> Layout ident style
translateLayout ofs layout = case layout of
  LoutGlyph ofs0 sty col ch mfg -> LoutGlyph (ofs0+ofs) sty col ch mfg   -- minor optimization
  LoutOfs   ofs0 lout           -> LoutOfs   (ofs0+ofs) lout             -- minor optimization
  _                             -> LoutOfs   ofs layout

reboxLayout :: Box -> Layout ident style -> Layout ident style
reboxLayout box layout = case layout of 
  LoutGroup _ louts -> LoutGroup box louts
  LoutBox   _ lout  -> LoutBox   box lout
  _                 -> LoutBox   box layout

--------------------------------------------------------------------------------
-- * The box of a glyph

mfgRelBox :: MultiFontGlyph -> Box
mfgRelBox (MFG ftex bufloc) = Box (width,height) outer bound gap where
  vm  = _ftexVM ftex
  hm  = _locHM  bufloc

  top     = - float2Double (ascent  vm)          -- ascent is normally positive
  bottom  = - float2Double (descent vm)          -- descent is normally negative
  lgap    = float2Double (lineGap vm) * lgapfactor
  width   = float2Double (advanceWidth hm)
  height  = 0
  lgapfactor = _ftexLGapFactor ftex

  outer = Quad (0,top) (width,bottom)
  gap   = Quad (0,top) (width,bottom+lgap)

  bound = Quad (fi ofsx , fi ofsy) (fi (ofsx+sizx) , fi (ofsy+sizy))

  (ofsx,ofsy) = _locBufOfs bufloc
  (sizx,sizy) = _locBufSiz bufloc

  fi = fromIntegral :: Int -> Double

--------------------------------------------------------------------------------
-- * Rendering a layout

-- | Renders the layout to the OpenGL framebuffer.
--
-- Note: you should set up the OpenGL coordinate transformation matrices
-- so that the coordinate system is screen-space, measured in pixels. For
-- example something like
--
-- > matrixMode $= Projection
-- > loadIdentity
-- > ortho 0 xres yres 0 (-1) 1 
-- > matrixMode $= Modelview 0
-- > loadIdentity
--
-- should do.
--
renderLayout :: Ord ident => Layout ident style -> Pos -> IO ()
renderLayout lout pos = void (renderLayout' False lout pos)

-- | Does not actually render, but computes the bounding boxes of the identified 
-- parts of the layout.
dryrunLayout :: Ord ident => Layout ident style -> Pos -> IO (Map ident AbsBox)
dryrunLayout lout pos = renderLayout' True lout pos

renderLayout' 
  :: forall ident style. Ord ident
  => Bool                     -- ^ @True@ = dryrun (do not render); @False@ = do the rendering
  -> Layout ident style
  -> Pos 
  -> IO (Map ident AbsBox )
renderLayout' dryrun layout pos0 = 
  do
    table <- newIORef Map.empty
    _ <- go table pos0 layout 
    readIORef table

  where
    go :: IORef (Map ident AbsBox) -> Pos -> Layout ident style -> IO AbsBox 
    go !table !pos layout = case layout of

      LoutGlyph ofs _ col _ mfg -> do
        unless dryrun $ renderMFG (pos+ofs) col mfg
        return (AbsBox pos $ mfgRelBox mfg)

      LoutDecor decor lout -> do
        absbox <- go table pos lout
        unless dryrun $ renderLayoutDecoration absbox decor
        return absbox

      LoutGroup relbox louts -> do
        mapM_ (go table pos) louts
        return (AbsBox pos relbox)

      LoutBox relbox lout -> do
        go table pos lout
        return (AbsBox pos relbox)

      LoutOfs ofs lout -> go table (pos + ofs) lout

      LoutIdent ident lout -> do
        box <- go table pos lout
        modifyIORef table (Map.insert ident box) 
        return box

      LoutEmpty -> return (AbsBox pos emptyBox)

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

renderLayoutDecoration :: AbsBox -> LayoutDecoration -> IO ()
renderLayoutDecoration absbox decor = case decor of

  HorizLine col valign vpos lwidth -> do
    let Quad (x1,y1) (x2,y2) = absboxBoundingQuad absbox
    let y = case valign of
              AlignTop    -> y1 - vpos
              AlignBottom -> y2 - vpos 
    renderLine col (max 1 lwidth) (Pos x1 y) (Pos x2 y)      

--------------------------------------------------------------------------------
-- * Creating a layouting

-- | Creates a layout from a document. Then you can render the resulting layout
-- with 'renderLayout'
createLayout
  :: forall fontfile style ident. (Ord fontfile, Ord ident)  
  => MultiFont fontfile style 
  -> Height 
  -> Document ident 
  -> IO (Layout ident style)
createLayout multifont height doc = do
  (box0,lout0) <- createLayout' multifont height doc
  -- The layout origin is not the top-left corner, but the baseline of the first line.
  -- Normally you want to shift it down so that the first line is visible, too.
  let outer@(Quad (l,t) _) = boxOuterQuad box0
  let ofs = Pos (-l) (-t)
  return $ translate ofs lout0

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

-- | A type used by 'createLayout'
data Cfg = Cfg
  { _currentSize  :: !SizeIndex
  , _currentStyle :: !BasicStyle
  , _currentColor :: !Col
  }

defaultCfg :: Cfg
defaultCfg = Cfg
  { _currentSize  = SizeIndex 0
  , _currentStyle = Regular
  , _currentColor = Col 0 0 0
  }

-- Note: the layout origin is not the top-left corner, but the baseline of the first line.
-- The function 'createLayout' does the necessary shift for you.
createLayout' 
  :: forall fontfile style ident. (Ord fontfile, Ord ident)  
  => MultiFont fontfile style 
  -> Height 
  -> Document ident 
  -> IO (Box, Layout ident style)
createLayout' multifont height doc = go initialCfg doc where

  styleMap =  (_ufcStyleMap . _mfUserConfig) multifont

  initialCfg = defaultCfg 

  sizeHeight :: SizeIndex -> Int
  sizeHeight = calculateSizeHeight height

  fsizeHeight :: SizeIndex -> Double
  fsizeHeight = fromIntegral . sizeHeight

  relativePlacement :: ([Box] -> (Box,[AbsBox])) -> Cfg -> [Document ident] -> IO (Box, Layout ident style)
  relativePlacement place !cfg docs  = case docs of
    []  -> return (emptyBox, LoutEmpty)
    [d] -> go cfg d 
    _   -> do
      bls <- mapM (go cfg) docs
      let (boxes,louts) = unzip bls
          (box,aboxes)  = place boxes
          offsets       = map _aboxOffset aboxes
      return (box, LoutGroup box (zipWith translate offsets louts))

  go :: Cfg -> Document ident -> IO (Box, Layout ident style)
  go cfg doc = case doc of

    EmptyDoc           -> return (emptyBox, LoutEmpty)

    WithColor  col doc -> go cfg' doc where cfg' = cfg { _currentColor = col }
    WithStyle  sty doc -> go cfg' doc where cfg' = cfg { _currentStyle = sty }

    Decorated decor doc -> do  
      (box,lout) <- go cfg doc 
      let col    =              _currentColor cfg
          ht     = fsizeHeight (_currentSize  cfg)
          lwidth = horizLineWidth * ht
          ldecor = case decor of
            Underline     -> HorizLine col AlignBottom (underlinePos     * ht) lwidth
            Overline      -> HorizLine col AlignTop    (overlinePos      * ht) lwidth
            StrikeThrough -> HorizLine col AlignBottom (strikeThroughPos * ht) lwidth
      return (box, LoutDecor ldecor lout)

    SubSupScript subsup doc -> do
      let (doc1,doc2) = subSupDocs subsup
      (box0,lout0) <- go cfg  doc
      let cfg' = cfg { _currentSize = succSizeIndex (_currentSize cfg) }
      (box1,lout1) <- go cfg' doc1 
      (box2,lout2) <- go cfg' doc2
      let ht     = fsizeHeight (_currentSize  cfg)
          ofs1   = - subPos * ht
          ofs2   = - supPos * ht
      let (box,(pos1,pos2)) = subSupScriptBox box0 (ofs1,box1) (ofs2,box2)
          lout = LoutGroup box [ lout0, translate pos1 lout1 , translate pos2 lout2 ]
      return (box,lout)

    AboveBelow aboveBelow doc -> do
      let (doc1,doc2) = aboveBelowDocs aboveBelow
      (box0,lout0) <- go cfg  doc
      let cfg' = cfg { _currentSize = succSizeIndex (_currentSize cfg) }
      (box1,lout1) <- go cfg' doc1 
      (box2,lout2) <- go cfg' doc2
      let ht     = fsizeHeight (_currentSize  cfg)
          ofs1   = Pos 0 (- abovePos * ht)
          ofs2   = Pos 0 (- belowPos * ht)
      let (box,(pos1,pos2)) = aboveBelowBox box0 (ofs1,box1) (ofs2,box2)
          lout = LoutGroup box [ lout0, translate pos1 lout1 , translate pos2 lout2 ]
      return (box,lout)

    Realign which doc -> do
      (box , lout) <- go cfg doc 
      let box' = realignBox which box 
      return (box', reboxLayout box' lout)

    AddMargin margin doc -> do
      (Box siz outer bound gap , lout) <- go cfg doc 
      let outer' = marginQuad margin outer      -- should we also extend the outer box or not??
          gap'   = marginQuad margin gap
          box' = Box siz outer' bound gap'
      return (box' , reboxLayout box' lout)

    Identified uid doc -> do
      (box, lout) <- go cfg doc
      return (box, LoutIdent uid lout)

    Symbol char -> do
      let Cfg size style0 col = cfg
          style = styleMap style0
      mfg@(MFG ftex bufloc) <- lkpMultiFont multifont (sizeHeight size) style char 
      let relbox = mfgRelBox mfg
          lout = LoutGlyph (Pos 0 0) style col char mfg
      return (relbox, lout)

    Space -> go cfg (Symbol ' ')

    String chars -> go cfg (HorzCat AlignBottom $ map Symbol chars)

    HorzCat valign  docs -> relativePlacement (hcatBoxes   valign) cfg docs
    VertCat halign  docs -> relativePlacement (vcatBoxes   halign) cfg docs
    Overlay (ha,va) docs -> relativePlacement (overlayBoxes ha va) cfg docs

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