{-# LANGUAGE ScopedTypeVariables #-}{-# OPTIONS -Wall #-}---------------------------------------------------------------------------------- |-- Module : Wumpus.Core.OutputSVG-- Copyright : (c) Stephen Tetley 2009-2011-- License : BSD3---- Maintainer : stephen.tetley@gmail.com-- Stability : unstable-- Portability : GHC---- Output SVG. ---- Note - the coordinate systems of Wumpus and SVG are different.---- > Wumpus - (0,0) is bottom-left.---- > SVG - (0,0) is top-left.---- To accommodate this, Wumpus adds rectifying matrix -- transformations to the generated SVG code.----------------------------------------------------------------------------------moduleWumpus.Core.OutputSVG(-- * Output SVGwriteSVG,writeSVG_defs)whereimportWumpus.Core.BoundingBoximportWumpus.Core.ColourimportWumpus.Core.GeometryimportWumpus.Core.GraphicPropsimportWumpus.Core.PageTranslationimportWumpus.Core.PictureInternalimportWumpus.Core.SVGDocimportWumpus.Core.TrafoInternalimportWumpus.Core.Text.BaseimportWumpus.Core.Text.GlyphIndicesimportWumpus.Core.Utils.FormatCombinatorsimportWumpus.Core.Utils.JoinListimportData.AffineSpace-- package: vector-spaceimportControl.Applicativehiding(empty,some)importData.CharimportData.List(mapAccumL)importqualifiedData.MapasMapimportData.Maybe-- DESIGN NOTE---- SVG output 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)\"@.---- SvgMonad is two Readers plus Int state for clip paths...--typeClipCount=IntnewtypeSvgMonada=SvgMonad{getSvgMonad::GraphicsState->ClipCount->(a,ClipCount)}instanceFunctorSvgMonadwherefmapfmf=SvgMonad$\rs->let(a,s1)=getSvgMonadmfrsin(fa,s1)instanceApplicativeSvgMonadwherepurea=SvgMonad$\_s->(a,s)mf<*>ma=SvgMonad$\rs->let(f,s1)=getSvgMonadmfrs(a,s2)=getSvgMonadmars1in(fa,s2)instanceMonadSvgMonadwherereturna=SvgMonad$\_s->(a,s)m>>=k=SvgMonad$\rs->let(a,s1)=getSvgMonadmrsin(getSvgMonad.k)ars1runSvgMonad::SvgMonada->arunSvgMonadmf=fst$getSvgMonadmfzeroGS0newClipLabel::SvgMonadStringnewClipLabel=SvgMonad$\_s->('c':'l':'i':'p':shows,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)->SvgMonada->SvgMonadarunLocalGSupdmf=SvgMonad$\rs->getSvgMonadmf(updr)saskGraphicsState::SvgMonadGraphicsStateaskGraphicsState=SvgMonad$\rs->(r,s)asksGraphicsState::(GraphicsState->a)->SvgMonadaasksGraphicsStatefn=fmapfnaskGraphicsStateaskFontAttr::SvgMonadFontAttraskFontAttr=asksGraphicsState$\r->FontAttr(gs_font_sizer)(gs_font_facer)askLineWidth::SvgMonadDoubleaskLineWidth=asksGraphicsState(line_width.gs_stroke_attr)askMiterLimit::SvgMonadDoubleaskMiterLimit=asksGraphicsState(miter_limit.gs_stroke_attr)askLineCap::SvgMonadLineCapaskLineCap=asksGraphicsState(line_cap.gs_stroke_attr)askLineJoin::SvgMonadLineJoinaskLineJoin=asksGraphicsState(line_join.gs_stroke_attr)askDashPattern::SvgMonadDashPatternaskDashPattern=asksGraphicsState(dash_pattern.gs_stroke_attr)--------------------------------------------------------------------------------svgChar::EscapedChar->DocsvgChar(CharLiteralc)|ordc<0x80=charcsvgChar(CharLiteralc)=escapeSpecial$ordcsvgChar(CharEscInti)=escapeSpecialisvgChar(CharEscNames)=escapeSpecial$fromMaybe0x0020$Map.lookupsps_glyph_indices---------------------------------------------------------------------------------- | Output a picture to a SVG file. --writeSVG::FilePath->Picture->IO()writeSVGfilepathpic=writeFilefilepath$show$svgDrawNothingpic-- | '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. ---- This is considered an experimental feature, use 'writeSVG' -- instead.--writeSVG_defs::FilePath->String->Picture->IO()writeSVG_defsfilepathsspic=writeFilefilepath$show$svgDraw(Justss)picsvgDraw::MaybeString->Picture->DocsvgDrawmb_defsoriginal_pic=letpic=svgPageTranslationoriginal_pic(_,imgTrafo)=imageTranslationpicbody=runSvgMonad$picturepicmkSvg=maybeelem_svgelem_svg_defsmb_defsinvcat[xml_version,doctype,mkSvg$imgTrafobody]imageTranslation::Picture->(DBoundingBox,Doc->Doc)imageTranslationpic=caserepositionDeltaspicof(bb,Nothing)->(bb,id)(bb,Justv)->letattr=attr_transform(val_translatev)in(bb,elem_gattr)---------------------------------------------------------------------------------- Note - might be simpler to only print a @Picture Double@picture::Picture->SvgMonadDocpicture(Leaf(_,xs)ones)=bracketTrafosxs$oneConcatprimitiveonespicture(Picture(_,xs)ones)=bracketTrafosxs$oneConcatpictureonesoneConcat::(a->SvgMonadDoc)->JoinLista->SvgMonadDoconeConcatfnones=outstep(viewlones)whereoutstep(e:<rest)=fne>>=\a->instepa(viewlrest)outstep(OneLe)=fneinstepac(OneLe)=fne>>=\a->return(ac`vconcat`a)instepac(e:<rest)=fne>>=\a->instep(ac`vconcat`a)(viewlrest)primitive::Primitive->SvgMonadDocprimitive(PPathpropspp)|isEmptyPathpp=pureempty|otherwise=primPathpropsppprimitive(PLabelpropslbl)|isEmptyLabellbl=pureempty|otherwise=primLabelpropslblprimitive(PEllipsepropsell)=primEllipsepropsellprimitive(PContextfachi)=bracketGSfa(primitivechi)primitive(PSVGannochi)=svgAnnoPrimanno<$>primitivechiprimitive(PGroupones)=oneConcatprimitiveonesprimitive(PClipcpchi)=do{lbl<-newClipLabel;letd1=clipPathlblcp;d2<-primitivechi;return(vconcatd1(elem_g(attr_clip_pathlbl)d2))}svgAnnoPrim::SvgAnno->Doc->DocsvgAnnoPrim(ALinkhypl)d=drawXLinkhypldsvgAnnoPrim(GAnnoxs)d=drawGPropsxsdsvgAnnoPrim(SvgAGhyplxs)d=drawXLinkhypl$drawGPropsxsddrawXLink::XLink->Doc->DocdrawXLink(XLinkhref)doc=elem_a_xlinkhrefdocdrawGProps::[SvgAttr]->Doc->DocdrawGProps[]d=ddrawGPropsxsd=elem_gattrs_docdwhereattrs_doc=hsep$mapsvgAttributexssvgAttribute::SvgAttr->DocsvgAttribute(SvgAttrnv)=svgAttrn$textvclipPath::String->PrimPath->DocclipPathclip_idpp=elem_clipPath(attr_idclip_id)(elem_path_no_attrs$pathpp)primPath::PathProps->PrimPath->SvgMonadDocprimPathpropspp=(\(a,f)->elem_patha(f$pathpp))<$>pathPropsprops---- 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::PrimPath->Docpathppath=let(start,xs)=extractRelPathppathinpath_mstart<+>hsep(snd$mapAccumLstepstartxs)wheresteppt(RelLineTov)=letp1=pt.+^vin(p1,path_lp1)steppt(RelCurveTov1v2v3)=letp1=pt.+^v1p2=p1.+^v2p3=p2.+^v3in(p3,path_cp1p2p3)-- Return - drawing props, plus a function to close the path (or not). --pathProps::PathProps->SvgMonad(Doc,Doc->Doc)pathPropsprops=fnpropswherefn(CFillrgb)=pure(fillNotStrokergb,close)fn(CStrokeattrsrgb)=(\a->(strokeNotFillrgb<+>a,close))<$>deltaStrokeAttrsattrsfn(OStrokeattrsrgb)=(\a->(strokeNotFillrgb<+>a,id))<$>deltaStrokeAttrsattrsfn(CFillStrokefcattrssc)=(\a->(fillAndStrokefcsc<+>a,close))<$>deltaStrokeAttrsattrsfillNotStrokergb=attr_fillrgb<+>attr_stroke_nonestrokeNotFillrgb=attr_strokergb<+>attr_fill_nonefillAndStrokeab=attr_filla<+>attr_strokebclose=(<+>char'Z')-- Note - if hw==hh then draw the ellipse as a circle.--primEllipse::EllipseProps->PrimEllipse->SvgMonadDocprimEllipseprops(PrimEllipsehwhhctm)|hw==hh=(\ab->elem_circle(a<+>circle_radius<+>b))<$>bracketEllipseCTMctmmkCXCY<*>ellipsePropsprops|otherwise=(\ab->elem_ellipse(a<+>ellipse_radius<+>b))<$>bracketEllipseCTMctmmkCXCY<*>ellipsePropspropswheremkCXCY(P2xy)=pure$attr_cxx<+>attr_cyycircle_radius=attr_rhwellipse_radius=attr_rxhw<+>attr_ryhhellipseProps::EllipseProps->SvgMonadDocellipseProps(EFillrgb)=pure(attr_fillrgb<+>attr_stroke_none)ellipseProps(EStrokeattrsrgb)=(\a->attr_strokergb<+>attr_fill_none<+>a)<$>deltaStrokeAttrsattrsellipseProps(EFillStrokefrgbattrssrgb)=(\a->attr_fillfrgb<+>attr_strokesrgb<+>a)<$>deltaStrokeAttrsattrs-- Note - SVG rendering coloured text seemed convoluted -- mandating the tspan element in the output. ---- TO CHECK - is this really the case?-- --primLabel::LabelProps->PrimLabel->SvgMonadDocprimLabel(LabelPropsrgbattrs)(PrimLabelbodyctm)=(\faca->elem_text(fa<+>ca)(makeTspanrgbdtext))<$>deltaFontAttrsattrs<*>bracketTextCTMctmcoordfwherecoordf=\p0->pure$labelBodyCoordsbodyp0dtext=labelBodyTextbodylabelBodyCoords::LabelBody->DPoint2->DoclabelBodyCoords(StdLayout_)pt=makeXYptlabelBodyCoords(KernTextHxs)pt=makeXsYptxslabelBodyCoords(KernTextVxs)pt=makeXYsptxslabelBodyText::LabelBody->DoclabelBodyText(StdLayoutenctext)=encodedTextenctextlabelBodyText(KernTextHxs)=kerningTextxslabelBodyText(KernTextVxs)=kerningTextxsencodedText::EscapedText->DocencodedTextenctext=hcat$destrEscapedText(mapsvgChar)enctextkerningText::[KerningChar]->DockerningTextxs=hcat$map(\(_,c)->svgCharc)xsmakeTspan::RGBi->Doc->DocmakeTspanrgbbody=elem_tspan(attr_fillrgb)bodymakeXY::DPoint2->DocmakeXY(P2xy)=attr_xx<+>attr_yy-- This is for horizontal kerning text, the output is of the -- form:-- -- > x="0 10 25 35" y="0"--makeXsY::DPoint2->[KerningChar]->DocmakeXsY(P2xy)ks=attr_xs(stepxks)<+>attr_yywherestepax((d,_):ds)=leta=ax+dina:stepadsstep_[]=[]-- 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::DPoint2->[KerningChar]->DocmakeXYs(P2xy)ks=attr_xsxcoords<+>attr_ys(stepyks)wherexcoords=replicate(lengthks)xstepay((d,_):ds)=leta=ay+dina:stepadsstep_[]=[]---------------------------------------------------------------------------------- Stroke and font attribute deltadeltaStrokeAttrs::StrokeAttr->SvgMonadDocdeltaStrokeAttrssa=(\d1d2d3d4d5->hsep$catMaybes[d1,d2,d3,d4,d5])<$>lw<*>ml<*>lc<*>lj<*>dpwherelw=letd=line_widthsainaskLineWidth>>=\inh->ifd==inhthenreturnNothingelsereturn(Just$attr_stroke_widthd)ml=letd=miter_limitsainaskMiterLimit>>=\inh->ifd==inhthenreturnNothingelsereturn(Just$attr_stroke_miterlimitd)lc=letd=line_capsainaskLineCap>>=\inh->ifd==inhthenreturnNothingelsereturn(Just$attr_stroke_linecapd)lj=letd=line_joinsainaskLineJoin>>=\inh->ifd==inhthenreturnNothingelsereturn(Just$attr_stroke_linejoind)dp=letd=dash_patternsainaskDashPattern>>=\inh->ifd==inhthenreturnNothingelsereturn(Just$makeDashPatternd)makeDashPattern::DashPattern->DocmakeDashPatternSolid=attr_stroke_dasharray_nonemakeDashPattern(Dashnxs)=attr_stroke_dashoffsetn<+>attr_stroke_dasharrayxsdataFontMatch=FullMatch|DeltaPtSize|DeltaFontderiving(Eq,Show,Ord)deltaFontAttrs::FontAttr->SvgMonadDocdeltaFontAttrsfa=(\inh->step$fontMatchinhfa)<$>askFontAttrwherestepFullMatch=emptystepDeltaPtSize=attr_font_size$font_sizefastepDeltaFont=makeFontAttrsfafontMatch::FontAttr->FontAttr->FontMatchfontMatch(FontAttrs1f1)(FontAttrs2f2)|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->DocmakeFontAttrs(FontAttrszface)=attr_font_family(svg_font_familyface)<+>attr_font_sizesz<>suffix(svg_font_styleface)wheresuffixSVG_REGULAR=emptysuffixSVG_BOLD=space<>attr_font_weight"bold"suffixSVG_ITALIC=space<>attr_font_style"italic"suffixSVG_BOLD_ITALIC=space<>attr_font_weight"bold"<+>attr_font_style"italic"suffixSVG_OBLIQUE=space<>attr_font_style"oblique"suffixSVG_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->SvgMonadDoc->SvgMonadDocbracketGS(FontCtxnew_font)mf=(\oldbody->mkElem(old==new_font)body)<$>askFontAttr<*>runLocalGSupdateFmfwheremkElemTruebody=elem_g_no_attrsbodymkElem_body=leta=makeFontAttrsnew_fontinelem_gabodyupdateFs=s{gs_font_size=font_sizenew_font,gs_font_face=font_facenew_font}---------------------------------------------------------------------------------- Bracket matrix and PrimCTM trafosbracketTrafos::[AffineTrafo]->SvgMonadDoc->SvgMonadDocbracketTrafosxsma=bracketMatrix(concatTrafosxs)mabracketMatrix::Matrix3'3Double->SvgMonadDoc->SvgMonadDocbracketMatrixmtrxma|mtrx==identityMatrix=(\doc->elem_g_no_attrsdoc)<$>ma|otherwise=(\doc->elem_gtrafodoc)<$>mawheretrafo=attr_transform$val_matrixmtrx-- 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::PrimCTM->(DPoint2->SvgMonadDoc)->SvgMonadDocbracketTextCTMctm0pf=(\xy->xy<+>mtrx)<$>pfzeroPtwheremtrx=attr_transform$val_matrix$matrixRepCTMctm0-- 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::PrimCTM->(DPoint2->SvgMonadDoc)->SvgMonadDocbracketEllipseCTMctm0pf=step$unCTMctm0wherestep(p0,ctm)|ctm==flippedCTM=pfp0|otherwise=letmtrx=attr_transform$val_matrix$matrixRepCTMctm0in(\xy->xy<+>mtrx)<$>pfzeroPtflippedCTM::PrimCTMflippedCTM=PrimCTM{ctm_trans_x=0,ctm_trans_y=0,ctm_scale_x=1,ctm_scale_y=(-1),ctm_rotation=0}