{-# 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_latin1

  ) 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.Text.DefaultEncoder
import Wumpus.Core.Text.Encoder
import Wumpus.Core.Text.TextInternal
import Wumpus.Core.TrafoInternal
import Wumpus.Core.Utils.Common
import Wumpus.Core.Utils.FormatCombinators
import Wumpus.Core.Utils.JoinList

import Control.Applicative hiding ( empty, some )
import Data.Maybe

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


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



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

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

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


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

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


getGlyphName :: FontEncoderName -> String -> SvgMonad (Either GlyphName GlyphName)
getGlyphName fen glyname = SvgMonad $ \r1 _ s -> 
    case lookupByGlyphName fen glyname r1 of
      Just a  -> (Right $ escapeSpecial a, s)
      Nothing -> (Left  $ escapeSpecial $ getSvgFallback fen r1, s)

-- 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 $ \r1 r2 s -> getSvgMonad mf r1 (upd r2) s


askGraphicsState :: SvgMonad GraphicsState
askGraphicsState = SvgMonad $ \_ r2 s -> (r2,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)



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

-- | Output a picture to a SVG file. 
--
-- Generally an encoder should always support the principal
-- encoders for the fonts used (e.g. Latin1) /and/ the encoder for
-- the Symbol font, as characters from the Symbol font may be used 
-- as decorations for plot marks, etc.
--
writeSVG :: (Real u, Floating u, PSUnit u) 
         => FilePath -> TextEncoder -> Picture u -> IO ()
writeSVG filepath enc pic = 
    writeFile filepath $ show $ svgDraw enc pic 

-- | Version of 'writeSVG' - using Latin1 and Symbol font encoders. 
--
-- Generally an encoder should always support the principal
-- encoders for the fonts used (e.g. Latin1) /and/ the encoder for 
-- the Symbol font, as characters from the Symbol font may be used 
-- as decorations for plot marks, etc.
--
writeSVG_latin1 :: (Real u, Floating u, PSUnit u) 
                => FilePath -> Picture u -> IO ()
writeSVG_latin1 filepath = writeSVG filepath defaultEncoder

svgDraw :: (Real u, Floating u, PSUnit u) 
        => TextEncoder -> Picture u -> Doc
svgDraw enc original_pic = 
    let pic          = trivialTranslation original_pic
        (_,imgTrafo) = imageTranslation pic
        body         = runSvgMonad enc $ picture pic
    in vcat [ xml_version, doctype, elem_svg $ 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)

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

-- Note - it will be wise to make coordinate remapping and output
-- separate passes (unlike in Wumpus-Core). Then I\'ll at least 
-- be able to debug the remapped Picture.
--



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
                          ; 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)      = primPath props pp
primitive (PLabel props lbl)    = primLabel props lbl
primitive (PEllipse props ell)  = primEllipse props ell
primitive (PContext fa chi)     = bracketGS fa (primitive chi)
primitive (PLink hypl chi)      = drawXLink hypl <$> primitive chi
primitive (PGroup ones)         = oneConcat primitive ones
 

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

clipPath :: PSUnit u => String -> PrimPath u -> SvgMonad Doc
clipPath clip_id pp = 
    (\doc -> elem_clipPath (attr_id clip_id) (elem_path_no_attrs doc)) 
      <$> path pp


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


path :: PSUnit u => PrimPath u -> SvgMonad Doc
path (PrimPath start xs) = 
    pure $ path_m start <+> hsep (map seg xs)
  where
    seg (PLineTo pt)        = path_l pt
    seg (PCurveTo p1 p2 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 pt hw hh ctm) 
    | hw == hh  = (\a b -> elem_circle (a <+> circle_radius <+> b))
                    <$> bracketPrimCTM pt ctm mkCXCY <*> ellipseProps props
    | otherwise = (\a b -> elem_ellipse (a <+> ellipse_radius <+> b))
                    <$> bracketPrimCTM pt 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 pt body ctm) = 
    (\fa ca dtxt -> elem_text (fa <+> ca) (makeTspan rgb dtxt))
      <$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm (labelBodyCoords body)
                               <*> labelBodyText fen body
  where
    fen = font_enc_name $ font_face attrs    


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

labelBodyText :: FontEncoderName -> LabelBody u -> SvgMonad Doc
labelBodyText nm (StdLayout enctext) = encodedText nm enctext
labelBodyText nm (KernTextH xs)      = hcat <$> mapM (kerningChar nm) xs
labelBodyText nm (KernTextV xs)      = hcat <$> mapM (kerningChar nm) xs


encodedText :: FontEncoderName -> EncodedText -> SvgMonad Doc
encodedText nm enctext = hcat <$> mapM (textChunk nm) (getEncodedText enctext)

textChunk :: FontEncoderName -> TextChunk -> SvgMonad Doc
textChunk _  (TextSpan s)    = pure $ text s
textChunk _  (TextEscInt i)  = pure $ text $ escapeSpecial i
textChunk nm (TextEscName s) = either text text <$> getGlyphName nm s 

kerningChar :: FontEncoderName -> KerningChar u -> SvgMonad Doc
kerningChar _  (_, CharLiteral c) = pure $ char c
kerningChar _  (_, CharEscInt i)  = pure $ text $ escapeSpecial i
kerningChar nm (_, CharEscName s) = either text text <$> getGlyphName nm s 


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


bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u)
               => Point2 u -> PrimCTM u 
               -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc
bracketPrimCTM pt@(P2 x y) ctm pf 
    | ctm == identityCTM  = pf pt
    | otherwise           = (\xy -> xy <+> attr_transform mtrx) <$> pf zeroPt'
  where
    zeroPt' :: Point2 u
    zeroPt' = zeroPt

    mtrx  = val_matrix $ translMatrixRepCTM x y ctm