-- | Boxes are rectangular shapes used for layouting. They are consisting of 
-- several quads having a relative position to each other:
--
-- * \"inner boxes\" are used for aligning several boxes together
--
-- * \"outer boxes\" describe the logical extent 
-- 
-- * \"bounding boxes\" are the bounding boxes of the actual content abstracted
--   by the box
--
-- * \"gap boxes\" control the gap between boxes placed next to each other.
--
-- Relative boxes has their origin at the top-left corner of their inner box.
-- Absolute boxes has an absolute offset.
--
-- We use screen-space coordinate system (Y increase downwards).
--
-- In case of font glyphs, the inner box has height 0, and it coincides with
-- the base line of the glyph; while the outer box is defined by the ascent
-- and the descent. Both have horizontal dimensions equal to the advance width.
-- 

{-# LANGUAGE CPP, BangPatterns #-}
module Graphics.Rendering.MiniTypeset.Box where

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

import Data.List

-- Semigroup became a superclass of Monoid at base 4.11
-- there are also conflicts between Monoid and Semigroup :(
#if MIN_VERSION_base(4,11,0)     
import Data.Semigroup
#else
import Data.Monoid
#endif

import Graphics.Rendering.MiniTypeset.Common

--------------------------------------------------------------------------------
-- * Quads

-- | A quad is a rectangular region, defined by its top-left and bottom-right corner
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)

-- | Least upper bounding quad
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

-- | Because it really should be a semigroup and not a monoid, it's important
-- that it's not implemented with foldl..
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)

--------------------------------------------------------------------------------
-- monoid/semigroup instance

-- Semigroup became a superclass of Monoid
#if MIN_VERSION_base(4,11,0)        

instance Semigroup Quad where
  (<>) = quadLUB

instance Monoid Quad where
  mempty = zeroQuad

#else

-- It probably should be a semigroup only, but I don't care too much 
-- (also backward compatibility is problematic)
instance Monoid Quad where
  mempty  = zeroQuad
  mappend = quadLUB
  mconcat = quadsLUB

#endif

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

-- | Extend a quad with margins
marginQuad :: Margin -> Quad -> Quad
marginQuad (Margin l r t b) (Quad (x1,y1) (x2,y2)) = Quad (x1-l,y1-t) (x2+r,y2+b)

--------------------------------------------------------------------------------
-- * Boxes

-- | A (relative) box
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

-- | Translates the quads relative to the inner quad.
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

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

-- | Enumerating the four different quads in a 'Box'
data WhichQuad
  = InnerQuad
  | OuterQuad
  | BoundingQuad
  | GapQuad
  deriving (Eq,Ord,Show)

-- | Replace the inner box by the given box. Since the inner box is used for
-- alignment, this amounts to changing the alignment 
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

-- | Replace the outer and gap boxes by the bounding box
trimBox :: Box -> Box
trimBox box@(Box size _ bounding _) = Box size bounding bounding bounding

--------------------------------------------------------------------------------
-- * Absolute boxes

-- | An absolute box
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

--------------------------------------------------------------------------------
-- * Concatenating boxes

-- | Concatantes two boxes horizontally, using the inner boxes to align them.
-- The two positions we return are relative positions of the two boxes from
-- the origin (top-left inner corner) of the concatenated box.
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

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

-- | Concatantes two boxes vertically, using the inner boxes to align them.
-- The two positions we return are relative positions of the two boxes from
-- the origin (top-left inner corner) of the concatenated box.
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)

--------------------------------------------------------------------------------
-- * Overlay boxes

-- | Overlay two boxes (so the corners given by the alignments coincide)
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)

--------------------------------------------------------------------------------
-- * Subscripts and superscripts

-- | Subscripts\/superscripts are special enough that it seems simpler to 
-- just add a specific combinator for them.
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

--------------------------------------------------------------------------------
-- * Above and below

-- | Positions are relative!
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

--------------------------------------------------------------------------------
-- * Fraction

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  -- + h2      -- ???

  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

--------------------------------------------------------------------------------
-- * delimiters

-- we have to vertically center the delimiters wrt. the bounding boxes 
-- of the rest, and ignore them while computing the inner/outer boxes 
-- (but include them for the bounding/gap boxes)
--
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 )   -- delimiters are trimmed
  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 []  = []

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