{-# 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
subSupSize = 0.65 :: Double
supPos = 0.40 :: Double
subPos = -0.20 :: Double
underlinePos = -0.10 :: Double
overlinePos = 0.10 :: Double
strikeThroughPos = 0.48 :: Double
horizLineWidth = 0.045 :: Double
abovePos = 0.15 :: Double
belowPos = -0.15 :: Double
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)
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
LoutOfs ofs0 lout -> LoutOfs (ofs0+ofs) lout
_ -> 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
mfgRelBox :: MultiFontGlyph -> Box
mfgRelBox (MFG ftex bufloc) = Box (width,height) outer bound gap where
vm = _ftexVM ftex
hm = _locHM bufloc
top = - float2Double (ascent vm)
bottom = - float2Double (descent vm)
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
renderLayout :: Ord ident => Layout ident style -> Pos -> IO ()
renderLayout lout pos = void (renderLayout' False lout pos)
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
-> 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)
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
let outer@(Quad (l,t) _) = boxOuterQuad box0
let ofs = Pos (-l) (-t)
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
}
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
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