{-# LANGUAGE CPP, BangPatterns #-}
module Graphics.Rendering.MiniTypeset.Box where
import Data.List
#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
quadsLUB :: [Quad] -> Quad
quadsLUB [] = zeroQuad
quadsLUB [q] = q
quadsLUB qs = foldl1 quadLUB qs
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
mconcat = quadsLUB
#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
boxInnerWidth, boxInnerHeight :: Box -> Double
boxInnerWidth = fst . boxInnerSize
boxInnerHeight = snd . boxInnerSize
emptyBox :: Box
emptyBox = Box (0,0) zeroQuad zeroQuad zeroQuad
shiftBox :: Pos -> Box -> Box
shiftBox ofs (Box sz outer bnd gap) = Box sz (translate ofs outer) (translate ofs bnd) (translate ofs gap)
boxSelectQuad :: WhichQuad -> Box -> Quad
boxSelectQuad which = case which of
InnerQuad -> boxInnerQuad
OuterQuad -> boxOuterQuad
BoundingQuad -> boxBoundingQuad
GapQuad -> boxGapQuad
data WhichQuad
= InnerQuad
| OuterQuad
| BoundingQuad
| GapQuad
deriving (Eq,Ord,Show)
realignBox :: WhichQuad -> Box -> (Pos,Box)
realignBox which box@(Box _ outer bounding gap) =
case which of
InnerQuad -> (Pos 0 0, box)
OuterQuad -> realign outer
BoundingQuad -> realign bounding
GapQuad -> realign gap
where
realign quad = (ofs, Box (quadSize quad) (f outer) (f bounding) (f gap)) where
ofs = negate (pairToPos $ quadTopLeft quad)
f :: Quad -> Quad
f = translate ofs
trimBox :: Box -> Box
trimBox box@(Box size _ bounding _) = Box size bounding bounding bounding
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)
absboxSelectQuad :: WhichQuad -> AbsBox -> Quad
absboxSelectQuad which = case which of
InnerQuad -> absboxInnerQuad
OuterQuad -> absboxOuterQuad
BoundingQuad -> absboxBoundingQuad
GapQuad -> absboxGapQuad
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
fractionBox :: Double -> Box -> Box -> (Box,(Pos,Pos))
fractionBox vmargin box1 box2 = (box,(pos1,pos2)) where
box = Box (w,h) outer bound gap
w = max w1 w2
h = h1
x1 = 0.5 * (w-w1)
x2 = 0.5 * (w-w2)
y1 = - quadB outer1 - vmargin
y2 = - quadT outer2 + vmargin
pos1 = Pos x1 y1
pos2 = Pos x2 y2
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
delimiterBox :: (Box,Box,Box) -> [Box] -> (Box,[Pos])
delimiterBox (left,mid,right) boxes = (box,posList) where
h = maximum $ map boxInnerHeight boxes
w = last gxs - quadWidth (boxGapQuad right) + boxInnerWidth right
allb = left : intersperse mid boxes ++ right : []
gxs = scanl (+) (quadL $ boxGapQuad left) $ map (quadWidth . boxGapQuad) allb
xs = zipWith (-) gxs $ map (quadL . boxGapQuad) allb
ys1 = [ h - boxInnerHeight b | b <- boxes ]
xs1 = odds xs
outers = zipWith3 (\x y b -> translate (Pos x y) (boxOuterQuad b)) xs1 ys1 boxes
outer1 = quadsLUB outers
ho = quadHeight outer1
yt = quadT outer1
yc = yt + 0.5*ho
yleft = yc - 0.5 * quadHeight (boxBoundingQuad left )
ymid = yc - 0.5 * quadHeight (boxBoundingQuad mid )
yright = yc - 0.5 * quadHeight (boxBoundingQuad right)
ys2 = yleft : replicate (length boxes - 1) ymid ++ yright : []
ys = interleave ys2 ys1
posList = zipWith Pos xs ys
aboxes = zipWith AbsBox posList allb
bnd = quadsLUB (map absboxBoundingQuad aboxes)
gap = quadsLUB (map absboxGapQuad aboxes)
Quad (ox1,_) (ox2,_) = quadsLUB $ map absboxOuterQuad $ aboxes
Quad (_,oy1) (_,oy2) = quadsLUB $ map absboxOuterQuad $ odds aboxes
outer = Quad (ox1,oy1) (ox2,oy2)
box = Box (w,h) outer bnd gap
interleave :: [a] -> [a] -> [a]
interleave (x:xs) (y:ys) = x:y:interleave xs ys
interleave xs [] = xs
interleave [] ys = ys
odds :: [a] -> [a]
odds (x:y:rest) = y : odds rest
odds [x] = []
odds [] = []
evens :: [a] -> [a]
evens (x:y:rest) = x : evens rest
evens [x] = [x]
evens [] = []