{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Text.Base.DocTextZero
-- Copyright   :  (c) Stephen Tetley 2011
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Flexible text type, composable with @pretty-print@ style 
-- operators.
-- 
-- Direction zero (left-to-right) only.
-- 
--------------------------------------------------------------------------------

module Wumpus.Drawing.Text.Base.DocTextZero
  ( 

    Doc 
  , TextFrame
  , render 

  , leftAlign
  , centerAlign
  , rightAlign

  , blank
  , space
  , string
  , escaped
  , int
  , integer
  , float
  , ffloat

  , (<>)
  , (<+>) 
  , vcatl
  , vcatc 
  , vcatr

  , lfill
  , rfill
  , centerfill

  , fontColour
  , textSize
  , bold
  , italic
  , boldItalic  
  , strikethrough
  , underline
  , highlight

  ) where

import Wumpus.Drawing.Text.Base.Common

import Wumpus.Basic.Kernel                      -- package: wumpus-basic

import Wumpus.Core                              -- package: wumpus-core

import Control.Applicative
import Data.Char ( ord )
import Numeric


-- | Space is the width of a space in the current font - it is 
-- filled in during interpretation.
--
data Doc u = Empty
           | Space 
           | Text EscapedText
           | Cat (Doc u) (Doc u)
           | VCat VAlign (Doc u) (Doc u)
           | Fill VAlign u (Doc u)
           | DLocal DrawingContextF (Doc u)
           | TLocal (TextContextF u) (Doc u)
           | Mono (WidthQuery u) [EscapedChar]
           | AElab (AElaborateF u) (Doc u)

type WidthQuery u = Query u (AdvanceVec u)

type TextContextF u = TextContext u -> TextContext u

type AElaborateF u = Orientation u -> LocGraphic u



-- | TextFrame is the result Graphic made from rendering multiple
-- lines of DocText.
--
type TextFrame u = RectAddress -> LocImage u (BoundingBox u)


-- NOTE - should the API use @em@ for fill, padding etc.?

blank       :: Doc u
blank       = Empty

space       :: Doc u
space       = Space

string      :: String -> Doc u
string      = Text . escapeString

escaped     :: EscapedText -> Doc u
escaped     = Text



int :: InterpretUnit u => Int -> Doc u
int i = integer $ fromIntegral i


integer :: InterpretUnit u => Integer -> Doc u
integer i = Mono (charVector $ CharLiteral '0') (map CharLiteral $ show i)

-- | Specialized version of 'ffloat' - the answer is always 
-- rendered at \"full precision\".
--
float :: (RealFloat a, InterpretUnit u) => a -> Doc u
float = ffloat Nothing


-- | This is equivalent to 'showFFloat' in the Numeric module.
-- 
-- Like 'showFFloat', the answer is rendered to supplied 
-- precision. @Nothing@ indicated full precision.
--
ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> Doc u
ffloat mb d = Mono (charVector $ CharLiteral '0') xs
  where
    xs = (map CharLiteral $ ($ []) $ showFFloat mb d)




infixr 6 <>, <+>


-- | Concatenate two DocTexts separated with no spacing.
--
-- (infixr 6)
--
(<>) :: Doc u -> Doc u -> Doc u
a <> b = Cat a b
 

-- | Concatenate two Docs separated with a space.
--
-- (infixr 6)
--
(<+>) :: Doc u -> Doc u -> Doc u
a <+> b = a <> space <> b 

infixr 5 `vcatl`, `vcatc`, `vcatr`

-- | Vertically concatenate - aligning left.
-- 
-- (infixr 5) 
--
vcatl :: Doc u -> Doc u -> Doc u
vcatl = VCat VLeft

-- | Vertically concatenate - aligning center.
-- 
-- (infixr 5) 
--
vcatc :: Doc u -> Doc u -> Doc u
vcatc = VCat VCenter

-- | Vertically concatenate - aligning right.
-- 
-- (infixr 5) 
--
vcatr :: Doc u -> Doc u -> Doc u
vcatr = VCat VRight

leftAlign  :: [Doc u] -> Doc u
leftAlign  = multiline vcatl

centerAlign  :: [Doc u] -> Doc u
centerAlign  = multiline vcatc

rightAlign  :: [Doc u] -> Doc u
rightAlign  = multiline vcatr


multiline :: (Doc u -> Doc u -> Doc u) -> [Doc u] -> Doc u
multiline _  []     = blank 
multiline op (x:xs) = go x xs
  where
    go a [] = a
    go a (b:bs) = go (a `op` b) bs




rfill :: u -> Doc u -> Doc u
rfill = Fill VLeft

lfill :: u -> Doc u -> Doc u
lfill = Fill VRight


centerfill :: u -> Doc u -> Doc u
centerfill = Fill VCenter



fontColour :: RGBi -> Doc u -> Doc u
fontColour rgb = DLocal (text_colour rgb)



textSize :: Int -> Doc u -> Doc u
textSize sz = DLocal (set_font_size sz)



bold        :: Doc u -> Doc u
bold        = TLocal (\s -> s { text_bold = True, text_italic = False })

italic      :: Doc u -> Doc u
italic      = TLocal (\s -> s { text_bold = False, text_italic = True })

boldItalic  :: Doc u -> Doc u
boldItalic  = TLocal (\s -> s { text_bold = True, text_italic = True })


strikethrough :: Doc u -> Doc u
strikethrough = TLocal (\s -> s { text_strikethrough = True })

underline :: Doc u -> Doc u
underline = TLocal (\s -> s { text_underline = True })

-- | Background fill.
--
highlight :: (Fractional u, InterpretUnit u) 
          => RGBi -> Doc u -> Doc u
highlight rgb = AElab (drawBackfill rgb)



render :: (Real u, Floating u, InterpretUnit u) 
       => FontFamily -> Doc u -> (RectAddress -> LocImage u (BoundingBox u))
render ff doc = \raddr -> localize (set_font $ regularWeight ff) $
    textlineSpace               >>= \sep -> 
    let po = runEvalM (initTextCtx sep ff) (interpret doc) 
    in posTextWithMargins po raddr


data TextContext u = TextContext
      { text_strikethrough      :: Bool
      , text_underline          :: Bool
      , text_sep                :: u
      , text_font_family        :: FontFamily
      , text_bold               :: Bool
      , text_italic             :: Bool
      }
  


initTextCtx :: u -> FontFamily -> TextContext u
initTextCtx sep ff = TextContext 
    { text_strikethrough      = False
    , text_underline          = False
    , text_sep                = sep
    , text_font_family        = ff
    , text_bold               = False
    , text_italic             = False 
    }

newtype EvalM u a = EvalM { getEvalM :: TextContext u -> a }


instance Functor (EvalM u) where
  fmap f mf = EvalM $ \ctx -> f $ getEvalM mf ctx


instance Applicative (EvalM u) where
  pure a    = EvalM $ \_   -> a
  mf <*> ma = EvalM $ \ctx -> 
                let f = getEvalM mf ctx
                    a = getEvalM ma ctx
                in f a

instance Monad (EvalM u) where
  return a  = EvalM $ \_   -> a
  ma >>= k  = EvalM $ \ctx -> 
                let a = getEvalM ma ctx
                in (getEvalM . k) a ctx

asks :: (TextContext u -> a) -> EvalM u a
asks f = EvalM $ \ctx -> f ctx

lineSpace :: EvalM u u
lineSpace = asks text_sep

local :: (TextContext u -> TextContext u) -> EvalM u a -> EvalM u a
local upd mf = EvalM $ \ctx -> getEvalM mf (upd ctx)

runEvalM :: TextContext u -> EvalM u a -> a
runEvalM ctx mf = getEvalM mf ctx



interpret :: (Fractional u, Ord u, InterpretUnit u) 
          => Doc u -> EvalM u (PosObject u)
interpret Empty             = interpEmpty
interpret Space             = interpSpace
interpret (Text esc)        = interpText esc
interpret (Cat a b)         = hconcat <$> interpret a <*> interpret b
interpret (VCat va a b)     = 
    valignSpace va  <$> lineSpace <*> interpret a <*> interpret b

interpret (Fill va w a)     = ppad va w <$> interpret a
interpret (DLocal upd a)    = localPosObject upd <$> interpret a
interpret (TLocal upd a)    = local upd (interpret a)
interpret (Mono q1 xs)      = interpMono q1 xs
interpret (AElab fn a)      = decoPosObject fn ANTERIOR <$> interpret a




interpEmpty :: InterpretUnit u => EvalM u (PosObject u)
interpEmpty = 
    return $ makePosObject (pure $ Orientation 0 0 0 0) emptyLocImage



-- | Note - the current way of seeding the LocGraphic with the 
-- DrawingContext looks dodgy (substantial copying). 
-- 
-- Maybe EvalM should have a private, much smaller 
-- DrawingContext...
--
interpText :: (Fractional u, InterpretUnit u) 
           => EscapedText -> EvalM u (PosObject u)
interpText esc = interpretLeaf $
    makePosObject (textOrientationZero esc) (dcEscapedlabel esc)
   



-- | Note - a space character is not draw in the output, instead 
-- 'space' advances the width vector by the width of a space in 
-- the current font.
--
interpSpace :: InterpretUnit u 
            => EvalM u (PosObject u)
interpSpace = return $ makePosObject qy1  emptyLocImage
  where
    qy1 = charOrientationZero $ CharEscInt $ ord ' '


ppad :: (Fractional u, Ord u) 
     => VAlign -> u -> PosObject u -> PosObject u
ppad VLeft   du = mapOrientation (padXMinor du)
ppad VCenter du = mapOrientation (padHEven $ 0.5 * du)
ppad VRight  du = mapOrientation (padXMajor du)


interpMono :: (Fractional u, InterpretUnit u)
           => Query u (AdvanceVec u) -> [EscapedChar] 
           -> EvalM u (PosObject u)
interpMono avq chs = 
    interpretLeaf $ makePosObject (qChars >>= hkernOrientationZero) 
                                  (promoteLoc $ \pt -> 
                                    zapQuery qChars >>= \ks -> hkernLine ks `at` pt)
  where
    qChars = (\v1 -> monoSpace (advanceH v1) chs) <$> avq

                        


interpretLeaf :: (Fractional u, InterpretUnit u)
              => PosObject u -> EvalM u (PosObject u)
interpretLeaf po = 
    (\f1 f2 sty -> f1 $ f2 $ localPosObject sty po) 
       <$> (fmap (condE drawUnderline)       $ asks text_underline)
       <*> (fmap (condE drawStrikethrough)   $ asks text_strikethrough)
       <*> textstyle
   where
     condE f b = if b then decoPosObject f SUPERIOR else id

textstyle :: EvalM u DrawingContextF
textstyle = 
    fn <$> asks text_font_family <*> asks text_bold <*> asks text_italic
  where
    fn ff False False = set_font $ regularWeight ff
    fn ff True  False = set_font $ boldWeight ff
    fn ff False True  = set_font $ italicWeight ff
    fn ff _     _     = set_font $ boldItalicWeight ff

--------------------------------------------------------------------------------
-- Helpers


monoSpace :: Num u => u -> [EscapedChar] -> [KernChar u]
monoSpace w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs
monoSpace _  []     = []

           

-- API might be simple if we conditionally apply strikethrough on 
-- interpText (possibly including spaces), but never on interpSpace.
--
-- Might want to derive stroke_colour from text_colour and linewidth
-- fromf font size as well...
--
drawStrikethrough :: (Fractional u, InterpretUnit u) 
              => Orientation u -> LocGraphic u
drawStrikethrough (Orientation xmin xmaj _ ymaj) = 
    linestyle $ moveStart (vec (-xmin) vpos) hline 
  where
    vpos  = 0.45 * ymaj
    hline = locStraightLine (hvec $ xmin + xmaj)



drawUnderline :: (Fractional u, InterpretUnit u) 
              => Orientation u -> LocGraphic u
drawUnderline (Orientation xmin xmaj ymin _) = 
    linestyle $ moveStart (vec (-xmin) vpos) hline 
  where
    vpos  = negate $ 0.45 * ymin
    hline = locStraightLine (hvec $ xmin + xmaj)

linestyle :: LocGraphic u -> LocGraphic u
linestyle mf = 
    pointSize >>= \sz -> 
    localize (stroke_use_text_colour . set_line_width (lim sz)) mf
  where
    lim i | i < 10    = 1.0
          | otherwise = (fromIntegral i) / 15.0 


-- | Note - halving the TextMargin looks good.
--
drawBackfill :: (Fractional u, InterpretUnit u) 
              => RGBi -> Orientation u -> LocGraphic u
drawBackfill rgb (Orientation xmin xmaj ymin ymaj) = 
    textMargin >>= \(dx,dy) -> 
    let hdx = 0.5 * dx
        hdy = 0.5 * dy 
    in localize (fill_colour rgb) $ moveStart (mkVec hdx hdy) (mkRect hdx hdy)
  where
    mkVec  dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy)
    mkRect dx dy = let w = dx + xmin + xmaj + dx
                       h = dy + ymin + ymaj + dy
                   in dcRectangle FILL w h