-- | 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.FontTexture
import Graphics.Rendering.MiniTypeset.MultiFont
import Graphics.Rendering.MiniTypeset.Render

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

-- | Subscript \/ superscript relative sizes
subSuperSize =  0.66 :: Double
superPos     =  0.27 :: Double
subPos       = -0.16 :: Double

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

-- | This data type describes what the user want to render.
--
-- The type parameter @ident@ is used when the user want to know positions (bounding boxes) of
-- different parts of the rendered text. It must have an 'Ord' instance.
--
data Document ident
  = Symbol      !Char
  | String      !String
  | Space
  | HorzCat     !VAlign      [Document ident]
  | VertCat     !HAlign      [Document ident]
  | WithColor   !Col        !(Document ident)
  | WithStyle   !BasicStyle !(Document ident)
  | Identified  !ident      !(Document ident)     -- ^ user identifier so that the layout engine can return position information
  deriving (Eq,Ord,Show)

--  | SubScript   !Document !Document !LeftRight
--  | SuperScript !Document !Document !LeftRight
--  | Above       !Document !Document !Bool     -- choose or fraction (the bool is separator line)
--  | InBrackets  !Bracket !Document

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

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

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

mfgRelBox :: MultiFontGlyph -> Box
mfgRelBox (MFG ftex bufloc) = Box width height 0 0 top bottom 0 lgap where
  vm  = _ftexVM ftex
  hm  = _locHM  bufloc
  top     =          float2Double (ascent  vm)
  bottom  = negate $ float2Double (descent vm)     -- note: we change the sign here!!!
  lgap    = float2Double (lineGap vm)
  width   = float2Double (advanceWidth hm)
  height  = 0

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

-- | 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]
  | LoutOfs   Pos   (Layout ident style)
  | LoutIdent ident (Layout ident style)
  | LoutEmpty
  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

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

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

      LoutGroup relbox louts -> do
        mapM_ (go table pos) louts
        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)

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

-- | 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 ofs = Pos (_rboxLeftMarg box0) (_rboxTopMarg box0)
  return $ translate ofs lout0

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

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 height) doc = go initialCfg doc where

  styleMap =  (_ufcStyleMap . _mfUserConfig) multifont

  initialCfg = defaultCfg

  sizeHeight :: SizeIndex -> Int
  sizeHeight (SizeIndex n)
    | n == 0  = height
    | n == 1  = round (fromIntegral height * subSuperSize)
    | n == 2  = round (fromIntegral height * subSuperSize * subSuperSize)
    | n == 3  = round (fromIntegral height * subSuperSize * subSuperSize * 0.8)
    | n >  3  = sizeHeight (SizeIndex 3)

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

  vcat :: Cfg -> HAlign -> [Document ident] -> IO (Box, Layout ident style)
  vcat !cfg !halign docs = case docs of
    []  -> return (emptyBox, LoutEmpty)
    [d] -> go cfg d
    _   -> do
      bls <- mapM (go cfg) docs
      let (boxes,louts) = unzip bls
          (box,aboxes)  = vcatBoxes halign 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

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

    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 -> hcat cfg valign docs
    VertCat halign docs -> vcat cfg halign docs

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