{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
module Graphics.Rendering.MiniTypeset.Layout where
import Data.List ( intersperse )
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.Delimiters
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.29 :: Double
horizLineWidth = 0.045 :: Double
abovePos = 0.15 :: Double
belowPos = -0.15 :: Double
fractionSize = 0.9 :: Double
fracLinePos = 0.32 - 0.08 :: Double
fracYMargin = 0.08 :: Double
data SizeIndex
= NormalSize
| FractionSize
| ScriptSize1
| ScriptSize2
| ScriptSize3
| CustomSize !(Double,Double) !SizeIndex
deriving (Eq,Ord,Show)
scriptSuccSizeIndex :: SizeIndex -> SizeIndex
scriptSuccSizeIndex idx = case idx of
NormalSize -> ScriptSize1
FractionSize -> ScriptSize1
ScriptSize1 -> ScriptSize2
ScriptSize2 -> ScriptSize3
ScriptSize3 -> ScriptSize3
CustomSize {} -> error "scriptSuccSizeIndex: Custom"
fracSuccSizeIndex :: SizeIndex -> SizeIndex
fracSuccSizeIndex idx = case idx of
NormalSize -> FractionSize
FractionSize -> ScriptSize1
ScriptSize1 -> ScriptSize2
ScriptSize2 -> ScriptSize3
ScriptSize3 -> ScriptSize3
CustomSize {} -> error "fracSuccSizeIndex: Custom"
calculateSizeXHeight :: Height -> SizeIndex -> Int
calculateSizeXHeight ht@(Height height) idx = case idx of
CustomSize (x,y) si -> round (fromIntegral (calculateSizeXHeight ht si) * x)
_ -> calculateSizeYHeight (Height height) idx
calculateSizeYHeight :: Height -> SizeIndex -> Int
calculateSizeYHeight ht@(Height height) idx = case idx of
NormalSize -> height
FractionSize -> round (fromIntegral height * fractionSize)
ScriptSize1 -> round (fromIntegral height * subSupSize)
ScriptSize2 -> round (fromIntegral height * subSupSize * subSupSize)
ScriptSize3 -> round (fromIntegral height * subSupSize * subSupSize * 0.8)
CustomSize (x,y) si -> round (fromIntegral (calculateSizeYHeight ht si) * y)
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
, _hlineWhichQuad :: !WhichQuad
, _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 whichquad valign vpos lwidth -> do
let Quad (x1,y1) (x2,y2) = absboxSelectQuad whichquad 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 = NormalSize
, _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
sizeXHeight, sizeYHeight :: SizeIndex -> Int
sizeXHeight = calculateSizeXHeight height
sizeYHeight = calculateSizeYHeight height
fsizeYHeight :: SizeIndex -> Double
fsizeYHeight = fromIntegral . sizeYHeight
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 = fsizeYHeight (_currentSize cfg)
lwidth = horizLineWidth * ht
ldecor = case decor of
Underline -> HorizLine col BoundingQuad AlignBottom (underlinePos * ht) lwidth
Overline -> HorizLine col BoundingQuad AlignTop (overlinePos * ht) lwidth
StrikeThrough -> HorizLine col InnerQuad 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 = scriptSuccSizeIndex (_currentSize cfg) }
(box1,lout1) <- go cfg' doc1
(box2,lout2) <- go cfg' doc2
let ht = fsizeYHeight (_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 = scriptSuccSizeIndex (_currentSize cfg) }
(box1,lout1) <- go cfg' doc1
(box2,lout2) <- go cfg' doc2
let ht = fsizeYHeight (_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)
Delimited delim docs -> do
let h = sizeYHeight (_currentSize cfg)
(box0,_) <- go cfg (HorzCat AlignBottom docs)
let outer = boxOuterQuad box0
tgt = quadHeight outer
vofs = 0
let left = finalDelim' vofs (Height h) delim tgt LeftDelim
right = finalDelim' vofs (Height h) delim tgt RightDelim
mid = finalDelim' vofs (Height h) VertSingle tgt RightDelim
(bl,loutl) <- go cfg left
(bm,loutm) <- go cfg mid
(br,loutr) <- go cfg right
(boxes,louts) <- unzip <$> mapM (go cfg) docs
let (box,poslist) = delimiterBox (bl,bm,br) boxes
lout = LoutGroup box
$ zipWith translate poslist
$ (loutl : intersperse loutm louts ++ loutr : [])
return (box,lout)
Realign which doc -> do
(box , lout) <- go cfg doc
let (ofs, box') = realignBox which box
return (box', reboxLayout box' $ translateLayout ofs $ lout)
Fraction drawline doc1 doc2 -> do
let csiz = _currentSize cfg
let cfg' = cfg { _currentSize = fracSuccSizeIndex csiz }
mbtrim = case csiz of { NormalSize -> id ; _ -> Trim }
(box1,lout1) <- go cfg' $ mbtrim doc1
(box2,lout2) <- go cfg' $ mbtrim doc2
let (w1,h1) = quadSize $ boxBoundingQuad box1
(w2,h2) = quadSize $ boxBoundingQuad box2
w = max w1 w2
let ht = fsizeYHeight (_currentSize cfg)
ymarg = (ht * fracYMargin)
let (box,(pos1,pos2)) = fractionBox ymarg box1 box2
lout0 = LoutGroup box [ translate pos1 lout1 , translate pos2 lout2 ]
let col = _currentColor cfg
lwidth = horizLineWidth * ht
let yofs = - fracLinePos * ht
pos = Pos 0 yofs
let lout = case drawline of
False -> lout0
True -> LoutDecor (HorizLine col InnerQuad AlignBottom (0) lwidth) lout0
return (shiftBox pos box, translateLayout pos lout)
Trim doc -> do
(box , lout) <- go cfg doc
let box' = trimBox 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)
RePosition pos doc -> do
(box , lout) <- go cfg doc
return (shiftBox pos box, translateLayout pos lout)
UnsafeResize (x,y) doc -> do
let sidx = _currentSize cfg
cfg' = cfg { _currentSize = CustomSize (x,y) sidx }
go cfg' doc
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 (sizeXHeight size, sizeYHeight 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