{-# LANGUAGE CPP, BangPatterns #-}
module Graphics.Rendering.MiniTypeset.Box where
#if MIN_VERSION_base(4,11,0)
import Data.Semigroup
#else
import Data.Monoid
#endif
import Graphics.Rendering.MiniTypeset.Common
data Quad = Quad
{ quadTopLeft :: {-# UNPACK #-} !(Double,Double)
, quadBotRight :: {-# UNPACK #-} !(Double,Double)
}
deriving (Eq,Show)
quadTopRight :: Quad -> (Double,Double)
quadTopRight (Quad (_,y) (x,_)) = (x,y)
quadBotLeft :: Quad -> (Double,Double)
quadBotLeft (Quad (x,_) (_,y)) = (x,y)
quadL,quadR,quadT,quadB :: Quad -> Double
quadL = fst . quadTopLeft
quadT = snd . quadTopLeft
quadR = fst . quadBotRight
quadB = snd . quadBotRight
quadWidth :: Quad -> Double
quadWidth (Quad (l,t) (r,b)) = r-l
quadHeight :: Quad -> Double
quadHeight (Quad (l,t) (r,b)) = b-t
quadSize :: Quad -> (Double,Double)
quadSize (Quad (l,t) (r,b)) = (r-l , b-t)
instance Translate Quad where
translate ofs (Quad tl br) = Quad (translate ofs tl) (translate ofs br)
zeroQuad :: Quad
zeroQuad = Quad (0,0) (0,0)
quadLUB :: Quad -> Quad -> Quad
quadLUB (Quad (u1,v1) (u2,v2)) (Quad (p1,q1) (p2,q2)) = Quad (x1,y1) (x2,y2) where
x1 = min u1 p1
y1 = min v1 q1
x2 = max u2 p2
y2 = max v2 q2
ofsLUB :: (Pos,Quad) -> (Pos,Quad) -> Quad
ofsLUB (ofs1,quad1) (ofs2,quad2) = quadLUB (translate ofs1 quad1) (translate ofs2 quad2)
#if MIN_VERSION_base(4,11,0)
instance Semigroup Quad where
(<>) = quadLUB
instance Monoid Quad where
mempty = zeroQuad
#else
instance Monoid Quad where
mempty = zeroQuad
mappend = quadLUB
#endif
marginQuad :: Margin -> Quad -> Quad
marginQuad (Margin l r t b) (Quad (x1,y1) (x2,y2)) = Quad (x1-l,y1-t) (x2+r,y2+b)
data Box = Box
{ boxInnerSize :: {-# UNPACK #-} !(Double,Double)
, boxOuterQuad :: !Quad
, boxBoundingQuad :: !Quad
, boxGapQuad :: !Quad
}
deriving (Show)
boxInnerQuad :: Box -> Quad
boxInnerQuad (Box inner outer bounding gap) = Quad (0,0) inner
emptyBox :: Box
emptyBox = Box (0,0) zeroQuad zeroQuad zeroQuad
data WhichQuad
= InnerQuad
| OuterQuad
| BoundingQuad
| GapQuad
deriving (Eq,Ord,Show)
realignBox :: WhichQuad -> Box -> Box
realignBox which box@(Box _ outer bounding gap) =
case which of
InnerQuad -> box
OuterQuad -> realign outer
BoundingQuad -> realign bounding
GapQuad -> realign gap
where
realign quad = Box (quadSize quad) (f outer) (f bounding) (f gap) where
ofs = negate (pairToPos $ quadTopLeft quad)
f :: Quad -> Quad
f = translate ofs
data AbsBox = AbsBox
{ _aboxOffset :: !Pos
, _aboxRelBox :: !Box
}
deriving (Show)
instance Translate AbsBox where
translate ofs (AbsBox pos relbox) = AbsBox (ofs+pos) relbox
absboxInnerQuad :: AbsBox -> Quad
absboxInnerQuad (AbsBox ofs relbox) = translate ofs (boxInnerQuad relbox)
absboxOuterQuad :: AbsBox -> Quad
absboxOuterQuad (AbsBox ofs relbox) = translate ofs (boxOuterQuad relbox)
absboxBoundingQuad :: AbsBox -> Quad
absboxBoundingQuad (AbsBox ofs relbox) = translate ofs (boxBoundingQuad relbox)
absboxGapQuad :: AbsBox -> Quad
absboxGapQuad (AbsBox ofs relbox) = translate ofs (boxGapQuad relbox)
hcatBox :: VAlign -> Box -> Box -> (Box,(Pos,Pos))
hcatBox !valign !box1 !box2 = (box,(pos1,pos2)) where
box = Box (w,h) outer bound gap
(y1,y2) = case valign of { AlignTop -> (0,0) ; AlignBottom -> (h-h1 , h-h2) }
pos1 = Pos 0 y1
pos2 = Pos x y2
x = quadR gap1 - quadL gap2
w = x + w2
h = max h1 h2
outer = ofsLUB (pos1,outer1) (pos2,outer2)
bound = ofsLUB (pos1,bound1) (pos2,bound2)
gap = ofsLUB (pos1, gap1) (pos2, gap2)
Box (w1,h1) outer1 bound1 gap1 = box1
Box (w2,h2) outer2 bound2 gap2 = box2
vcatBox :: HAlign -> Box -> Box -> (Box,(Pos,Pos))
vcatBox !halign !box1 !box2 = (box,(pos1,pos2)) where
box = Box (w,h) outer bound gap
(x1,x2) = case halign of { AlignLeft -> (0,0) ; AlignRight -> (w-w1 , w-w2) }
pos1 = Pos x1 0
pos2 = Pos x2 y
y = quadB gap1 - quadT gap2
h = y + h2
w = max w1 w2
outer = ofsLUB (pos1,outer1) (pos2,outer2)
bound = ofsLUB (pos1,bound1) (pos2,bound2)
gap = ofsLUB (pos1, gap1) (pos2, gap2)
Box (w1,h1) outer1 bound1 gap1 = box1
Box (w2,h2) outer2 bound2 gap2 = box2
hcatBox2 :: VAlign -> Box -> Box -> (Box,(AbsBox,AbsBox))
hcatBox2 valign box1 box2 = (box, (AbsBox p1 box1, AbsBox p2 box2)) where (box,(p1,p2)) = hcatBox valign box1 box2
vcatBox2 :: HAlign -> Box -> Box -> (Box,(AbsBox,AbsBox))
vcatBox2 halign box1 box2 = (box, (AbsBox p1 box1, AbsBox p2 box2)) where (box,(p1,p2)) = vcatBox halign box1 box2
hcatBoxes :: VAlign -> [Box] -> (Box,[AbsBox])
hcatBoxes !valign boxes = case boxes of
[] -> ( emptyBox, [] )
[b] -> ( b, [AbsBox (Pos 0 0) b] )
(b1:b2:bs) -> let (b12,(ab1,ab2) ) = hcatBox2 valign b1 b2
(box,(ab12:abs)) = hcatBoxes valign (b12:bs)
p12 = _aboxOffset ab12
in (box, translate p12 ab1 : translate p12 ab2 : abs)
vcatBoxes :: HAlign -> [Box] -> (Box,[AbsBox])
vcatBoxes !halign boxes = case boxes of
[] -> ( emptyBox, [] )
[b] -> ( b, [AbsBox (Pos 0 0) b] )
(b1:b2:bs) -> let (b12,(ab1,ab2) ) = vcatBox2 halign b1 b2
(box,(ab12:abs)) = vcatBoxes halign (b12:bs)
p12 = _aboxOffset ab12
in (box, translate p12 ab1 : translate p12 ab2 : abs)
overlayBox :: HAlign -> VAlign -> Box -> Box -> (Box,(Pos,Pos))
overlayBox !halign !valign !box1 !box2 = (box,(pos1,pos2)) where
box = Box (w,h) outer bound gap
Box (w1,h1) outer1 bound1 gap1 = box1
Box (w2,h2) outer2 bound2 gap2 = box2
(x1,x2) = case halign of { AlignLeft -> (0,0) ; AlignRight -> (w-w1 , w-w2) }
(y1,y2) = case valign of { AlignTop -> (0,0) ; AlignBottom -> (h-h1 , h-h2) }
pos1 = Pos x1 y1
pos2 = Pos x2 y2
w = max w1 w2
h = max h1 h2
outer = ofsLUB (pos1,outer1) (pos2,outer2)
bound = ofsLUB (pos1,bound1) (pos2,bound2)
gap = ofsLUB (pos1, gap1) (pos2, gap2)
overlayBox2 :: HAlign -> VAlign -> Box -> Box -> (Box,(AbsBox,AbsBox))
overlayBox2 halign valign box1 box2 = (box, (AbsBox p1 box1, AbsBox p2 box2)) where
(box,(p1,p2)) = overlayBox halign valign box1 box2
overlayBoxes :: HAlign -> VAlign -> [Box] -> (Box,[AbsBox])
overlayBoxes !halign !valign boxes = case boxes of
[] -> ( emptyBox, [] )
[b] -> ( b, [AbsBox (Pos 0 0) b] )
(b1:b2:bs) -> let (b12,(ab1,ab2) ) = overlayBox2 halign valign b1 b2
(box,(ab12:abs)) = overlayBoxes halign valign (b12:bs)
p12 = _aboxOffset ab12
in (box, translate p12 ab1 : translate p12 ab2 : abs)
subSupScriptBox :: Box -> (Double,Box) -> (Double,Box) -> (Box,(Pos,Pos))
subSupScriptBox box0 (y1,box1) (y2,box2) = (box,(pos1,pos2)) where
box = Box (w,h) outer bound gap
pos1 = Pos x (h0+y1)
pos2 = Pos x (h0+y2)
x = max (quadR gap0 - quadL gap1)
(quadR gap0 - quadL gap2)
w = x + max w1 w2
h = h0
outer = outer0 <> ofsLUB (pos1,outer1) (pos2,outer2)
bound = bound0 <> ofsLUB (pos1,bound1) (pos2,bound2)
gap = gap0 <> ofsLUB (pos1, gap1) (pos2, gap2)
Box (w0,h0) outer0 bound0 gap0 = box0
Box (w1,h1) outer1 bound1 gap1 = box1
Box (w2,h2) outer2 bound2 gap2 = box2
aboveBelowBox :: Box -> (Pos,Box) -> (Pos,Box) -> (Box,(Pos,Pos))
aboveBelowBox box0 (Pos x1ofs y1ofs, box1) (Pos x2ofs y2ofs, box2) = (box,(pos1,pos2)) where
box = Box (w,h) outer bound gap
Quad (u1,v1) (u2,v2) = bound0
xc = 0.5 * (u1+u2)
x1 = xc - 0.5 * w1 + x1ofs - quadL bound1
x2 = xc - 0.5 * w2 + x2ofs - quadL bound2
y1 = v1 + y1ofs - quadB bound1
y2 = v2 + y2ofs - quadT bound2
pos1 = Pos x1 y1
pos2 = Pos x2 y2
w = w0
h = h0
outer = outer0 <> ofsLUB (pos1,outer1) (pos2,outer2)
bound = bound0 <> ofsLUB (pos1,bound1) (pos2,bound2)
gap = gap0 <> ofsLUB (pos1, gap1) (pos2, gap2)
Box (w0,h0) outer0 bound0 gap0 = box0
Box (w1,h1) outer1 bound1 gap1 = box1
Box (w2,h2) outer2 bound2 gap2 = box2