{-# LANGUAGE ScopedTypeVariables        #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Core.OutputSVG
-- Copyright   :  (c) Stephen Tetley 2009-2010
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Output SVG. 
--
-- This is complicated by two differences with PostScript.
--
-- 1. The coordinate space of SVG is /origin top-left/, for 
-- PostScript it is /origin bottom-left/.
-- 
-- 2. Clipping in SVG uses /tagging/. A clipPath element is 
-- declared and named, subsequent elements within the clipping 
-- area reference it via the clip-path attribute - 
-- @clip-path=\"url(#clip_path_tag)\"@.
--
--
--------------------------------------------------------------------------------

module Wumpus.Core.OutputSVG 
  (

  -- * Output SVG
    writeSVG

  , writeSVG_defs


  ) where

import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicProps
import Wumpus.Core.PageTranslation
import Wumpus.Core.PictureInternal
import Wumpus.Core.SVGDoc
import Wumpus.Core.TrafoInternal
import Wumpus.Core.Text.Base
import Wumpus.Core.Text.GlyphIndices
import Wumpus.Core.Utils.Common
import Wumpus.Core.Utils.FormatCombinators
import Wumpus.Core.Utils.JoinList

import Data.AffineSpace                         -- package: vector-space

import Control.Applicative hiding ( empty, some )
import Data.Char
import Data.List ( mapAccumL )
import qualified Data.Map as Map
import Data.Maybe

-- SvgMonad is two Readers plus Int state for clip paths...
--

type ClipCount = Int

newtype SvgMonad a = SvgMonad { 
          getSvgMonad :: GraphicsState -> ClipCount -> (a,ClipCount) }



instance Functor SvgMonad where
  fmap f mf = SvgMonad $ \r s -> let (a,s1) = getSvgMonad mf r s
                                 in (f a,s1)

instance Applicative SvgMonad where
  pure a    = SvgMonad $ \_ s -> (a,s)
  mf <*> ma = SvgMonad $ \r s -> let (f,s1) = getSvgMonad mf r s
                                     (a,s2) = getSvgMonad ma r s1
                                 in (f a, s2)

instance Monad SvgMonad where
  return a  = SvgMonad $ \_ s -> (a,s)
  m >>= k   = SvgMonad $ \r s -> let (a,s1) = getSvgMonad m r s
                                 in (getSvgMonad . k) a r s1
                            


runSvgMonad :: SvgMonad a -> a
runSvgMonad mf = fst $ getSvgMonad mf zeroGS 0

newClipLabel :: SvgMonad String
newClipLabel = SvgMonad $ \_ s -> ('c':'l':'i':'p':show s, s+1)



-- This is different to the PsMonad version, as SVG is nested 
-- (and /graphics state/ is via a Reader), so it is the same as 
-- local with a Reader monad.
--
runLocalGS :: (GraphicsState -> GraphicsState) -> SvgMonad a -> SvgMonad a
runLocalGS upd mf = 
    SvgMonad $ \r s -> getSvgMonad mf (upd r) s


askGraphicsState :: SvgMonad GraphicsState
askGraphicsState = SvgMonad $ \r s -> (r,s)

asksGraphicsState :: (GraphicsState -> a) -> SvgMonad a
asksGraphicsState fn = fmap fn askGraphicsState

askFontAttr :: SvgMonad FontAttr
askFontAttr = asksGraphicsState $ \r -> 
                FontAttr (gs_font_size r) (gs_font_face r)

askLineWidth    :: SvgMonad Double
askLineWidth    = asksGraphicsState (line_width . gs_stroke_attr)

askMiterLimit   :: SvgMonad Double
askMiterLimit   = asksGraphicsState (miter_limit . gs_stroke_attr)

askLineCap      :: SvgMonad LineCap
askLineCap      = asksGraphicsState (line_cap . gs_stroke_attr)

askLineJoin     :: SvgMonad LineJoin
askLineJoin     = asksGraphicsState (line_join . gs_stroke_attr)

askDashPattern  :: SvgMonad DashPattern
askDashPattern  = asksGraphicsState (dash_pattern . gs_stroke_attr)


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


svgChar :: EscapedChar -> Doc
svgChar (CharLiteral c) | ord c < 0x80  = char c
svgChar (CharLiteral c)                 = escapeSpecial $ ord c
svgChar (CharEscInt i)                  = escapeSpecial i
svgChar (CharEscName s)                 = 
   escapeSpecial $ fromMaybe 0x0020 $ Map.lookup s ps_glyph_indices 

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

-- | Output a picture to a SVG file. 
--
writeSVG :: (Real u, Floating u, PSUnit u) 
         => FilePath -> Picture u -> IO ()
writeSVG filepath pic = 
    writeFile filepath $ show $ svgDraw Nothing pic 

-- | 'writeSVG_defs' : @ file_name -> defs -> picture -> IO () @
--
-- Output a picture to a SVG file the supplied /defs/ are
-- written into the defs section of SVG file verbatim. 
--
writeSVG_defs :: (Real u, Floating u, PSUnit u) 
              => FilePath -> String -> Picture u -> IO ()
writeSVG_defs filepath ss pic = 
    writeFile filepath $ show $ svgDraw (Just ss) pic 


svgDraw :: (Real u, Floating u, PSUnit u) 
        => Maybe String -> Picture u -> Doc
svgDraw mb_defs original_pic = 
    let pic          = trivialTranslation original_pic
        (_,imgTrafo) = imageTranslation pic
        body         = runSvgMonad $ picture pic
        mkSvg        = maybe elem_svg elem_svg_defs mb_defs
    in vcat [ xml_version, doctype, mkSvg $ imgTrafo body ]



imageTranslation :: (Ord u, PSUnit u) 
                 => Picture u -> (BoundingBox u, Doc -> Doc)
imageTranslation pic = case repositionDeltas pic of
  (bb, Nothing) -> (bb, id)
  (bb, Just v)  -> let attr = attr_transform (val_translate v) 
                   in (bb, elem_g attr)

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


picture :: (Real u, Floating u, PSUnit u) => Picture u -> SvgMonad Doc
picture (Leaf    (_,xs) ones)   = bracketTrafos xs $ oneConcat primitive ones
picture (Picture (_,xs) ones)   = bracketTrafos xs $ oneConcat picture ones
picture (Clip    (_,xs) cp pic) = 
    bracketTrafos xs $ do { lbl <- newClipLabel
                          ; let d1 = clipPath lbl cp
                          ; d2  <- picture pic
                          ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2))
                          } 




oneConcat :: (a -> SvgMonad Doc) -> JoinList a -> SvgMonad Doc
oneConcat fn ones = outstep (viewl ones)
  where
    outstep (e :< rest)   = fn e >>= \a -> instep a (viewl rest)
    outstep (OneL e)      = fn e
    
    instep ac (OneL e)    = fn e >>= \a -> return (ac `vconcat` a)
    instep ac (e :< rest) = fn e >>= \a -> instep (ac `vconcat` a) (viewl rest)


primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc
primitive (PPath props pp)      
    | isEmptyPath pp            = pure empty
    | otherwise                 = primPath props pp

primitive (PLabel props lbl)    
    | isEmptyLabel lbl          = pure empty
    | otherwise                 = primLabel props lbl

primitive (PEllipse props ell)  = primEllipse props ell

primitive (PContext fa chi)     = bracketGS fa (primitive chi)

primitive (PSVG anno chi)       = svgAnnoPrim anno <$> primitive chi

primitive (PGroup ones)         = oneConcat primitive ones
 

svgAnnoPrim :: SvgAnno -> Doc -> Doc
svgAnnoPrim (ALink hypl)    d = drawXLink hypl d
svgAnnoPrim (GAnno xs)      d = drawGProps xs d
svgAnnoPrim (SvgAG hypl xs) d = drawXLink hypl $ drawGProps xs d 


drawXLink :: XLink -> Doc -> Doc
drawXLink (XLink href) doc = elem_a_xlink href doc

drawGProps :: [SvgAttr] -> Doc -> Doc
drawGProps [] d = d 
drawGProps xs d = elem_g attrs_doc d
  where
    attrs_doc = hsep $ map svgAttribute xs

svgAttribute :: SvgAttr -> Doc
svgAttribute (SvgAttr n v) = svgAttr n $ text v
 
clipPath :: PSUnit u => String -> PrimPath u -> Doc
clipPath clip_id pp = 
    elem_clipPath (attr_id clip_id) (elem_path_no_attrs $ path pp) 


primPath :: PSUnit u => PathProps -> PrimPath u -> SvgMonad Doc
primPath props pp = (\(a,f) -> elem_path a (f $ path pp)) <$> pathProps props

--
-- Paths are printed as absolute paths. Internally they are 
-- relative paths, but client code specifies them as absolute 
-- paths. So, here at least, the output matches the input.
-- 
-- Also, the SVG syntax for distinguishing between absolute and 
-- relative paths is is horrible (upper case char versus its 
-- corresponding lower case char). As Wumpus used absolute paths 
-- internally up to version 0.40.0, the horrible syntax was not
-- an encouragement to change when it moved to relative ones. 
-- 

path :: PSUnit u => PrimPath u -> Doc
path (PrimPath start xs) = 
    path_m start <+> hsep (snd $ mapAccumL step start xs)
  where
    step pt (RelLineTo v)         = let p1 = pt .+^ v in (p1, path_l p1)
    step pt (RelCurveTo v1 v2 v3) = let p1 = pt .+^ v1 
                                        p2 = p1 .+^ v2
                                        p3 = p2 .+^ v3
                                    in (p3, path_c p1 p2 p3)


-- Return - drawing props, plus a function to close the path (or not). 
--
pathProps :: PathProps -> SvgMonad (Doc, Doc -> Doc)
pathProps props = fn props
  where
    fn (CFill rgb)                = pure (fillNotStroke rgb, close) 

    fn (CStroke attrs rgb)        = 
        (\a -> (strokeNotFill rgb <+> a, close))   <$> deltaStrokeAttrs attrs

    fn (OStroke attrs rgb)        = 
        (\a -> (strokeNotFill rgb <+> a, id))      <$> deltaStrokeAttrs attrs

    fn (CFillStroke fc attrs sc)  =
        (\a -> (fillAndStroke fc sc <+> a, close)) <$> deltaStrokeAttrs attrs

    fillNotStroke rgb             = attr_fill rgb   <+> attr_stroke_none 
    strokeNotFill rgb             = attr_stroke rgb <+> attr_fill_none
    fillAndStroke a b             = attr_fill a     <+> attr_stroke b
    close                         = (<+> char 'Z')
 



-- Note - if hw==hh then draw the ellipse as a circle.
--
primEllipse :: (Real u, Floating u, PSUnit u)
            => EllipseProps -> PrimEllipse u -> SvgMonad Doc
primEllipse props (PrimEllipse hw hh ctm) 
    | hw == hh  = (\a b -> elem_circle (a <+> circle_radius <+> b))
                    <$> bracketEllipseCTM ctm mkCXCY <*> ellipseProps props
    | otherwise = (\a b -> elem_ellipse (a <+> ellipse_radius <+> b))
                    <$> bracketEllipseCTM ctm mkCXCY <*> ellipseProps props
  where
   mkCXCY (P2 x y) = pure $ attr_cx x <+> attr_cy y
   
   circle_radius   = attr_r hw
   ellipse_radius  = attr_rx hw <+> attr_ry hh

 

ellipseProps :: EllipseProps -> SvgMonad Doc
ellipseProps (EFill rgb)                   = 
    pure (attr_fill rgb <+> attr_stroke_none)

ellipseProps (EStroke attrs rgb)           = 
    (\a -> attr_stroke rgb <+> attr_fill_none <+> a)  <$> deltaStrokeAttrs attrs

ellipseProps (EFillStroke frgb attrs srgb) = 
    (\a -> attr_fill frgb <+> attr_stroke srgb <+> a) <$> deltaStrokeAttrs attrs



-- Note - Rendering coloured text seemed convoluted 
-- (mandating the tspan element). 
--
-- TO CHECK - is this really the case?
-- 
--

primLabel :: (Real u, Floating u, PSUnit u) 
      => LabelProps -> PrimLabel u -> SvgMonad Doc
primLabel (LabelProps rgb attrs) (PrimLabel body ctm) = 
    (\fa ca -> elem_text (fa <+> ca) (makeTspan rgb dtext))
      <$> deltaFontAttrs attrs <*> bracketTextCTM ctm coordf
                               
  where
    coordf = \p0 -> pure $ labelBodyCoords body p0
    dtext  = labelBodyText body

labelBodyCoords :: PSUnit u => LabelBody u -> Point2 u -> Doc
labelBodyCoords (StdLayout _)  pt = makeXY pt
labelBodyCoords (KernTextH xs) pt = makeXsY pt xs        
labelBodyCoords (KernTextV xs) pt = makeXYs pt xs

labelBodyText :: LabelBody u -> Doc
labelBodyText (StdLayout enctext) = encodedText enctext
labelBodyText (KernTextH xs)      = kerningText xs
labelBodyText (KernTextV xs)      = kerningText xs


encodedText :: EscapedText -> Doc
encodedText enctext = hcat $ destrEscapedText (map svgChar) enctext

kerningText :: [KerningChar u] -> Doc
kerningText xs = hcat $ map (\(_,c) -> svgChar c) xs



makeTspan :: RGBi -> Doc -> Doc
makeTspan rgb body = elem_tspan (attr_fill rgb) body

makeXY :: PSUnit u => Point2 u -> Doc
makeXY (P2 x y) = attr_x x <+> attr_y y

-- This is for horizontal kerning text, the output is of the 
-- form:
-- 
-- > x="0 10 25 35" y="0"
--
makeXsY :: PSUnit u => Point2 u -> [KerningChar u] -> Doc
makeXsY (P2 x y) ks = attr_xs (step x ks) <+> attr_y y
  where 
    step ax ((d,_):ds) = let a = ax+d in a : step a ds 
    step _  []         = []


-- This is for vertical kerning text, the output is of the 
-- form:
-- 
-- > x="0 0 0 0" y="0 10 25 35"
--
-- Note - this is different to the horizontal version as the 
-- x-coord needs to be /realigned/ at each step.
--
makeXYs :: PSUnit u => Point2 u -> [KerningChar u] -> Doc
makeXYs (P2 x y) ks = attr_xs xcoords <+> attr_ys (step y ks)
  where 
    xcoords            = replicate (length ks) x
    step ay ((d,_):ds) = let a = ay+d in a : step a ds 
    step _  []         = []
    
    

--------------------------------------------------------------------------------
-- Stroke and font attribute delta

deltaStrokeAttrs :: StrokeAttr -> SvgMonad Doc
deltaStrokeAttrs sa = 
    (\d1 d2 d3 d4 d5 -> hsep $ catMaybes [d1,d2,d3,d4,d5])  
      <$> lw <*> ml <*> lc <*> lj <*> dp
  where
    lw = let d = line_width sa in
         askLineWidth >>= \inh -> 
         if d==inh then return Nothing 
                   else return (Just $ attr_stroke_width d) 
         
    ml = let d = miter_limit sa in
         askMiterLimit >>= \inh -> 
         if d==inh then return Nothing 
                   else return (Just $ attr_stroke_miterlimit d)

    lc = let d = line_cap sa in
         askLineCap >>= \inh -> 
         if d==inh then return Nothing 
                   else return (Just $ attr_stroke_linecap d)

    lj = let d = line_join sa in
         askLineJoin >>= \inh -> 
         if d==inh then return Nothing 
                   else return (Just $ attr_stroke_linejoin d)

    dp = let d = dash_pattern sa in 
         askDashPattern >>= \inh -> 
         if d==inh then return Nothing 
                   else return (Just $ makeDashPattern d) 

makeDashPattern :: DashPattern -> Doc
makeDashPattern Solid       = attr_stroke_dasharray_none
makeDashPattern (Dash n xs) = 
    attr_stroke_dashoffset n <+> attr_stroke_dasharray xs


data FontMatch = FullMatch | DeltaPtSize | DeltaFont
  deriving (Eq,Show,Ord) 


deltaFontAttrs :: FontAttr -> SvgMonad Doc
deltaFontAttrs fa = (\inh -> step $ fontMatch inh fa) <$> askFontAttr
  where
    step FullMatch      = empty
    step DeltaPtSize    = attr_font_size $ font_size fa
    step DeltaFont      = makeFontAttrs fa


fontMatch :: FontAttr -> FontAttr -> FontMatch
fontMatch (FontAttr s1 f1) (FontAttr s2 f2) 
   | s1 == s2 && f1 == f2 = FullMatch
   | f1 == f2             = DeltaPtSize
   | otherwise            = DeltaFont

-- Note this is always adding FontSize - there are cases where 
-- this is redundant. 
--
makeFontAttrs :: FontAttr -> Doc
makeFontAttrs (FontAttr sz face) = 
    attr_font_family (svg_font_family face) <+> attr_font_size sz 
                                            <> suffix (svg_font_style face) 
  where  
    suffix SVG_REGULAR      = empty

    suffix SVG_BOLD         = space <> attr_font_weight "bold"

    suffix SVG_ITALIC       = space <> attr_font_style "italic"

    suffix SVG_BOLD_ITALIC  = 
        space <> attr_font_weight "bold" <+> attr_font_style "italic"

    suffix SVG_OBLIQUE      = space <> attr_font_style "oblique"

    suffix SVG_BOLD_OBLIQUE = 
        space <> attr_font_weight "bold" <+> attr_font_style "oblique"



-- Always update both the size and font-family even if only one
-- changes.
--
-- This seems more in the spirit of a font delta operation.
--
bracketGS :: FontCtx -> SvgMonad Doc -> SvgMonad Doc
bracketGS (FontCtx new_font) mf = 
    (\old body -> mkElem (old == new_font) body) 
        <$> askFontAttr <*> runLocalGS updateF mf
  where
    mkElem True body = elem_g_no_attrs body
    mkElem _    body = let a = makeFontAttrs new_font in elem_g a body

    updateF s = s { gs_font_size = font_size new_font
                  , gs_font_face = font_face new_font }
                


--------------------------------------------------------------------------------
-- Bracket matrix and PrimCTM trafos

bracketTrafos :: (Real u, Floating u, PSUnit u) 
              => [AffineTrafo u] -> SvgMonad Doc -> SvgMonad Doc
bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma 

bracketMatrix :: (Fractional u, PSUnit u) 
              => Matrix3'3 u -> SvgMonad Doc -> SvgMonad Doc
bracketMatrix mtrx ma 
    | mtrx == identityMatrix = (\doc -> elem_g_no_attrs doc) <$>  ma
    | otherwise              = (\doc -> elem_g trafo doc) <$> ma
  where
    trafo = attr_transform $ val_matrix mtrx


-- Note - there are versions of the /same/ function for text and 
-- ellipses.
-- 
-- For text we always want a matrix transformation in the 
-- generated SVG - wumpus has flipped the page coordinates, so
-- it must flip text accordingly.
--
-- For ellipses and circles we dont\'t have to bother with the
-- rectifying flip transformation /if/ the ellipse or circle has 
-- not been scaled or rotated.
--
bracketTextCTM :: forall u. (Real u, Floating u, PSUnit u)
               => PrimCTM u 
               -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc
bracketTextCTM ctm0 pf = (\xy -> xy <+> mtrx) <$> pf zeroPt
  where
    mtrx = attr_transform $ val_matrix $ matrixRepCTM ctm0


-- Note - the otherwise step uses the original ctm (ctm0).
-- 
-- Note v0.41.0 otherwise step always fires because the matrix 
-- has been transformed for SVG coordspace to [1,0,0,-1].
--
bracketEllipseCTM :: forall u. (Real u, Floating u, PSUnit u)
                  => PrimCTM u 
                  -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc
bracketEllipseCTM ctm0 pf = step $ unCTM ctm0
  where
    step (pt, ctm) 
        | ctm == flippedCTM   = pf pt
        | otherwise           = let mtrx = attr_transform $ 
                                             val_matrix $ matrixRepCTM ctm0
                                in (\xy -> xy <+> mtrx) <$> pf zeroPt


flippedCTM :: Num u => PrimCTM u
flippedCTM = PrimCTM { ctm_transl_x = 0,  ctm_transl_y = 0
                     , ctm_scale_x  = 1,  ctm_scale_y  = (-1)
                     , ctm_rotation = 0 }