diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2014, Tillmann Vogt + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Thomas M. DuBuisson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diagrams-input.cabal b/diagrams-input.cabal new file mode 100644 --- /dev/null +++ b/diagrams-input.cabal @@ -0,0 +1,56 @@ +Name: diagrams-input +Version: 0.1 +Synopsis: Parse raster and SVG files for diagrams +Description: Parse raster and SVG images for the diagrams DSL. +License: BSD3 +License-file: LICENSE +Author: Tillmann Vogt +Maintainer: diagrams-discuss@googlegroups.com +Copyright: Tillmann Vogt (2014) +Category: Graphics, Diagrams +Build-type: Simple +Cabal-version: >=1.10 +tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.1 +Source-repository head + type: git + location: http://github.com/diagrams/diagrams-input.git + +Library + Exposed-modules: Diagrams.TwoD.Input + Diagrams.SVG.ReadSVG + Diagrams.SVG.Arguments + Diagrams.SVG.Attributes + Diagrams.SVG.Path + Diagrams.SVG.Tree + Other-modules: Diagrams.SVG.Fonts.CharReference + Diagrams.SVG.Fonts.ReadFont + Build-depends: attoparsec >= 0.10 + , base == 4.* + , base64-bytestring + , blaze-builder + , blaze-markup + , bytestring + , colour + , conduit + , conduit-extra + , containers + , css-text + , data-default + , diagrams-core >= 1.3 && < 1.6 + , diagrams-lib >= 1.3 && < 1.5 + , digits + , either >= 4.4 + , JuicyPixels >= 3.1.5 && < 3.4 + , linear >= 1.11.3 + , resourcet + , semigroups + , split + , system-filepath + , text >= 0.11 + , transformers + , unordered-containers + , vector + , xml-conduit >= 1.3 + , xml-types == 0.3.* + Hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Diagrams/SVG/Arguments.hs b/src/Diagrams/SVG/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/SVG/Arguments.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Diagrams.SVG.Arguments + ( + -- * Attribute Parsing of classes of attributes + coreAttributes + , conditionalProcessingAttributes + , documentEventAttributes + , graphicalEventAttributes + , presentationAttributes + , filterPrimitiveAttributes + , xlinkAttributes + , xmlnsNameSpaces + -- * Attributes for basic structure elements + , svgAttrs + , gAttrs + , sAttrs + , descAttrs + , symbolAttrs + , useAttrs + , switchAttrs + -- * Attributes for basic shape elements + , rectAttrs + , circleAttrs + , ellipseAttrs + , lineAttrs + , polygonAttrs + , pathAttrs + -- * Other Attributes + , clipPathAttrs + , patternAttrs + , imageAttrs + , filterAttrs + , linearGradAttrs + , radialGradAttrs + , setAttrs + , stopAttrs + , textAttrs + , tspanAttrs + , namedViewAttrs + , perspectiveAttrs + -- * Font Attributes + , fontAttrs + , fontFaceAttrs + , glyphAttrs + , missingGlyphAttrs + , kernAttrs + -- * Filter Effect Attributes + , feBlendAttrs + , feColorMatrixAttrs + , feComponentTransferAttrs + , feCompositeAttrs + , feConvolveMatrixAttrs + , feDiffuseLightingAttrs + , feDisplacementMapAttrs + , feFloodAttrs + , feGaussianBlurAttrs + , feImageAttrs + , feMergeAttrs + , feMorphologyAttrs + , feOffsetAttrs + , feSpecularLightingAttrs + , feTileAttrs + , feTurbulenceAttrs + ) +where +import Text.XML.Stream.Parse +import Diagrams.SVG.Attributes + +coreAttributes = + do l <- mapM attr + [ "id", "base", "lang", "space"] -- "xml:base", "xml:lang", "xml:space"] + return $ (\[a,b,c,d] -> CA a b c d) l + +conditionalProcessingAttributes = + do l <- mapM attr + [ "requiredFeatures", "requiredExtensions", "systemLanguage"] + return $ (\[a,b,c] -> CPA a b c) l + +documentEventAttributes = + do l <- mapM attr + [ "onunload", "onabort", "onerror", "onresize", "onscroll", "onzoom"] + return $ (\[a,b,c,d,e,f] -> DEA a b c d e f) l + +graphicalEventAttributes = + do l <- mapM attr + [ "onfocusin", "onfocusout", "onactivate", "onclick", "onmousedown", "onmouseup", + "onmouseover", "onmousemove", "onmouseout", "onload"] + return $ (\[a,b,c,d,e,f,g,h,i,j] -> GEA a b c d e f g h i j) l + +presentationAttributes = + do l <- mapM attr + ["alignmentBaseline","baseline-shift","clip","clip-path", "clip-rule", + "color", "color-interpolation", "color-interpolation-filters", "color-profile", + "color-rendering", "cursor", "direction", "display", "dominant-baseline", "enable-background", + "fill", "fill-opacity", "fill-rule", "filter", "flood-color", "flood-opacity", "font-family", + "font-size", "font-size-adjust", "font-stretch", "font-style", "font-variant", "font-weight", + "glyph-orientation-horizontal", "glyph-orientation-vertical", "image-rendering", "kerning", + "letter-spacing", "lighting-color", "marker-end", "marker-mid", "marker-start", "mask", + "opacity", "overflow", "pointer-events", "shape-rendering", "stop-color", "stop-opacity", + "stroke", "stroke-dasharray", "stroke-dashoffset", "stroke-linecap", "stroke-linejoin", + "stroke-miterlimit", "stroke-opacity", "stroke-width", "text-anchor", "text-decoration", + "text-rendering", "unicode-bidi", "visibility", "word-spacing", "writing-mode"] + return $ + (\[a,b,c0,c1,c2,c3,c4,c5,c6,c7,c8,d0,d1,d2,e,f0,f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12, + g0,g1,i,k,l0,l1,m0,m1,m2,m3,o0,o1,p,s0,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,t0,t1,t2,u,v,w0,w1] -> + PA a b c0 c1 c2 c3 c4 c5 c6 c7 c8 d0 d1 d2 e f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 + g0 g1 i k l0 l1 m0 m1 m2 m3 o0 o1 p s0 s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 t0 t1 t2 u v w0 w1 ) l + +filterPrimitiveAttributes = + do l <- mapM attr + [ "x","y","widh","height","result"] + return $ (\[x,y,w,h,r] -> FPA x y w h r) l + + +-- prefix :: Maybe T.Text -> T.Text -> Data.XML.Types.Name +-- prefix ns attribute = Name attribute ns Nothing + +xlinkAttributes = -- xlinkNamespace is usually http://www.w3.org/1999/xlink + do l <- mapM attr + [ "{http://www.w3.org/1999/xlink}href", "{http://www.w3.org/1999/xlink}show", "{http://www.w3.org/1999/xlink}actuate", + "{http://www.w3.org/1999/xlink}type", "{http://www.w3.org/1999/xlink}role", "{http://www.w3.org/1999/xlink}arcrole", + "{http://www.w3.org/1999/xlink}title"] + return $ (\[a,b,c,d,e,f,g] -> XLA a b c d e f g) l + +xmlnsNameSpaces = + do l <- mapM attr + [ "{http://www.w3.org/2000/svg}xlink","{http://www.w3.org/2000/svg}dc", "{http://www.w3.org/2000/svg}cc", + "{http://www.w3.org/2000/svg}rdf", "{http://www.w3.org/2000/svg}svg", "{http://www.w3.org/2000/svg}sodipodi", + "{http://www.w3.org/2000/svg}inkscape" ] + return $ (\[xlink,dc,cc,rdf,svg,sodipodi,inkscape] -> NSP xlink dc cc rdf svg sodipodi inkscape) l + +xmlNameSpaces = + do l <- mapM attr + [ "{http://www.w3.org/XML/1998/namespace}space" ] -- the only attribute that seems to be used so far in the xml namespace is xml:space="preserve" + return $ (\[space] -> space) l + +-------------------------------------------------------------------------------------- +-- Attributes for basic structure tags, see http://www.w3.org/TR/SVG/struct.html +-------------------------------------------------------------------------------------- + +-- | Attributes for \, see +svgAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + xmlns <- xmlnsNameSpaces + xml <- xmlNameSpaces + l <- mapM attr + ["class","style","externalResourcesRequired","x","y","width","height","viewBox","preserveAspectRatio", + "zoomAndPan", "version", "baseProfile", "contentScriptType", "contentStyleType"] + ignoreAttrs + return $ (\[class_,style,ext,x,y,w,h,view,ar,zp,ver,baseprof,cScripT,cStyleT] -> + (cpa,ca,gea,pa,class_,style,ext,x,y,w,h,view,ar,zp,ver,baseprof,cScripT,cStyleT,xmlns,xml)) l + +-- | Attributes for \ and \, see +gAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + class_ <- attr "class" + style <- attr "style" + ext <- attr "externalResourceRequired" + tr <- attr "transform" + ignoreAttrs + return (cpa,ca,gea,pa,class_,style,ext,tr) + +-- | Attributes for \ and \, see +sAttrs = + do ca <- coreAttributes + type_ <- attr "type" + media <- attr "media" + title <- attr "title" + ignoreAttrs + return (ca,type_,media,title) + +-- | Attributes for \, see +descAttrs = + do ca <- coreAttributes + class_ <- attr "class" + style <- attr "style" + ignoreAttrs + return (ca,class_,style) + +-- | Attributes for \, see +symbolAttrs = + do ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","preserveAspectRatio","viewBox"] + ignoreAttrs + return $ (\[class_,style,ext,ar,viewbox] -> + (ca,gea,pa,class_,style,ext,ar,viewbox) ) l + +-- | Attributes for \, see +useAttrs = + do ca <- coreAttributes + cpa <- conditionalProcessingAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + xlink <- xlinkAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","transform","x","y","width","height"] + ignoreAttrs + return $ (\[class_,style,ext,tr,x,y,w,h] -> + (ca,cpa,gea,pa,xlink,class_,style,ext,tr,x,y,w,h)) l + +-- | Attributes for \, see +switchAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + class_ <- attr "class" + style <- attr "style" + ext <- attr "externalResourcesRequired" + tr <- attr "transform" + ignoreAttrs + return (cpa,ca,gea,pa,class_,style,ext,tr) + +-------------------------------------------------------------------------------------- +-- Attributes for basic shape tags +-------------------------------------------------------------------------------------- + +-- | Attributes for \, see +rectAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","preserveAspectRatio","transform","x","y", + "width","height","rx","ry"] + ignoreAttrs + return $ (\[class_,style,ext,ar,tr,x,y,w,h,rx,ry] -> + (cpa,ca,gea,pa,class_,style,ext,ar,tr,x,y,w,h,rx,ry) ) l + +-- | Attributes for \, see +circleAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","transform","r","cx","cy"] + ignoreAttrs + return $ (\[class_,style,ext,tr,r,cx,cy] -> + (cpa,ca,gea,pa,class_,style,ext,tr,r,cx,cy) ) l + +-- | Attributes for \, see +ellipseAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","transform","rx","ry","cx","cy"] + ignoreAttrs + return $ (\[class_,style,ext,tr,rx,ry,cx,cy] -> + (cpa,ca,gea,pa,class_,style,ext,tr,rx,ry,cx,cy) ) l + +-- | Attributes for \, see +lineAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","transform","x1","y1","x2","y2"] + ignoreAttrs + return $ (\[class_,style,ext,tr,x1,y1,x2,y2] -> + (cpa,ca,gea,pa,class_,style,ext,tr,x1,y1,x2,y2) ) l + +-- | Attributes for \, see +polygonAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","transform","points"] + ignoreAttrs + return $ (\[class_,style,ext,tr,points] -> + (cpa,ca,gea,pa,class_,style,ext,tr,points) ) l + +-- | Attributes for \, see +pathAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","transform","d","pathLength"] + ignoreAttrs + return $ (\[class_,style,ext,tr,d,pathLength] -> + (cpa,ca,gea,pa,class_,style,ext,tr,d,pathLength) ) l + +------------------------------------------------------------------------------------- +-- | Attributes for \, see +clipPathAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","transform","clipPathUnits"] + ignoreAttrs + return $ (\[class_,style,ext,tr,units] -> + (cpa,ca,pa,class_,style,ext,tr,units) ) l + +-- | Attributes for \, see +patternAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","viewBox","preserveAspectRatio","x","y", + "width","height","patternUnits","patternContentUnits","patternTransform"] + ignoreAttrs + return $ (\[class_,style,ext,view,ar,x,y,w,h,pUnits,pCUnits,pTrans] -> + (cpa,ca,pa,class_,style,ext,view,ar,x,y,w,h,pUnits,pCUnits,pTrans) ) l + +-- | Attributes for \, see +imageAttrs = + do ca <- coreAttributes + cpa <- conditionalProcessingAttributes + gea <- graphicalEventAttributes + xlink <- xlinkAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","preserveAspectRatio","transform", + "x","y","width","height"] + ignoreAttrs + return $ (\[class_,style,ext,ar,tr,x,y,w,h] -> + (ca,cpa,gea,xlink,pa,class_,style,ext,ar,tr,x,y,w,h) ) l + +-- | Attributes for \ +fontAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","horiz-origin-x","horiz-origin-y","horiz-adv-x", + "vert-origin-x","vert-origin-y","vert-adv-y"] + ignoreAttrs + return $ (\[class_,style,ext,horizOriginX,horizOriginY,horizAdvX,vertOriginX,vertOriginY,vertAdvY] -> + (ca,pa,class_,style,ext,horizOriginX,horizOriginY,horizAdvX,vertOriginX,vertOriginY,vertAdvY) ) l + +-- | Attributes for \ +fontFaceAttrs = + do ca <- coreAttributes + l <- mapM attr + ["font-family","font-style","font-variant","font-weight","font-stretch","font-size","unicode-range","units-per-em","panose-1", + "stemv","stemh","slope","cap-height","x-height","accent-height", "ascent", "descent", "widths", "bbox", "ideographic", + "alphabetic","mathematical", "hanging", "v-ideographic", "v-alphabetic", "v-mathematical", "v-hanging", "underline-position", + "underline-thickness", "strikethrough-position", "strikethrough-thickness", "overline-position", "overline-thickness"] + ignoreAttrs + return $ (\[fontFamily,fontStyle,fontVariant,fontWeight,fontStretch,fontSize,unicodeRange,unitsPerEm,panose1, + stemv,stemh,slope,capHeight,xHeight,accentHeight,ascent,descent,widths,bbox,ideographic,alphabetic,mathematical, + hanging,vIdeographic,vAlphabetic,vMathematical,vHanging,underlinePosition,underlineThickness,strikethroughPosition, + strikethroughThickness,overlinePosition,overlineThickness] -> + (ca,fontFamily,fontStyle,fontVariant,fontWeight,fontStretch,fontSize,unicodeRange,unitsPerEm,panose1, + stemv,stemh,slope,capHeight,xHeight,accentHeight,ascent,descent,widths,bbox,ideographic,alphabetic,mathematical, + hanging,vIdeographic,vAlphabetic,vMathematical,vHanging,underlinePosition,underlineThickness,strikethroughPosition, + strikethroughThickness,overlinePosition,overlineThickness) ) l + +missingGlyphAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","d","horiz-adv-x","vert-origin-x","vert-origin-y","vert-adv-y"] + ignoreAttrs + return $ (\[class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY] -> + (ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY) ) l + +glyphAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","d","horiz-adv-x","vert-origin-x","vert-origin-y","vert-adv-y","unicode","glyph-name", + "orientation","arabic-form","lang"] + ignoreAttrs + return $ (\[class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY,unicode,glyphName,orientation,arabicForm,lang] -> + (ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY,unicode,glyphName,orientation,arabicForm,lang) ) l + +kernAttrs = + do ca <- coreAttributes + l <- mapM attr + ["u1","g1","u2","g2","k"] + ignoreAttrs + return $ (\[u1,g1,u2,g2,k] -> + (ca,u1,g1,u2,g2,k) ) l + + +-- | Attributes for \, see +filterAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + xlink <- xlinkAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","x","y","width","height","filterRes","filterUnits","primitiveUnits"] + ignoreAttrs + return $ (\[class_,style,ext,x,y,w,h,filterRes,filterUnits,primUnits] -> + (ca,pa,xlink,class_,style,ext,x,y,w,h,filterRes,filterUnits,primUnits) ) l + +linearGradAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + xlink <- xlinkAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","x1","y1","x2","y2","gradientUnits","gradientTransform","spreadMethod"] + ignoreAttrs + return $ (\[class_,style,ext,x1,y1,x2,y2,gradientUnits,gradientTransform,spreadMethod] -> + (ca,pa,xlink,class_,style,ext,x1,y1,x2,y2,gradientUnits,gradientTransform,spreadMethod) ) l + +radialGradAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + xlink <- xlinkAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","cx","cy","r","fx","fy","gradientUnits","gradientTransform","spreadMethod"] + ignoreAttrs + return $ (\[class_,style,ext,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod] -> + (ca,pa,xlink,class_,style,ext,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod) ) l + +setAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + xlink <- xlinkAttributes + ignoreAttrs + return (ca,pa,xlink) + +stopAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + xlink <- xlinkAttributes + class_ <- attr "class" + style <- attr "style" + offset <- attr "offset" + ignoreAttrs + return $ (ca,pa,xlink,class_,style,offset) + +-- | Attributes for \, see +textAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","transform","lengthAdjust", + "x","y","dx","dy","rotate","textLength"] + ignoreAttrs + return $ (\[class_,style,ext,tr,la,x,y,dx,dy,rot,textlen] -> + (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) ) l + +tspanAttrs = + do cpa <- conditionalProcessingAttributes + ca <- coreAttributes + gea <- graphicalEventAttributes + pa <- presentationAttributes + p <- mapM attr + [ "class","style","externalResourcesRequired", "x", "y", "dx", "dy", "rotate", "textLength", "lengthAdjust", + "{http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd}role" ] + ignoreAttrs + return $ ( \[class_, style, ext, x, y, dx, dy, rotate, textlen, lAdjust, role] -> + (cpa,ca,gea,pa,class_,style,ext,x,y,dx,dy,rotate,textlen,lAdjust,role) ) p + +namedViewAttrs = + do l <- mapM attr + ["pagecolor","bordercolor","borderopacity","objecttolerance","gridtolerance", + "guidetolerance", "id","showgrid"] + inkscape <- mapM attr + [ "{http://www.inkscape.org/namespaces/inkscape}pageopacity", "{http://www.inkscape.org/namespaces/inkscape}pageshadow", + "{http://www.inkscape.org/namespaces/inkscape}window-width", "{http://www.inkscape.org/namespaces/inkscape}window-height", + "{http://www.inkscape.org/namespaces/inkscape}zoom", + "{http://www.inkscape.org/namespaces/inkscape}cx", "{http://www.inkscape.org/namespaces/inkscape}cy", + "{http://www.inkscape.org/namespaces/inkscape}window-x", "{http://www.inkscape.org/namespaces/inkscape}window-y", + "{http://www.inkscape.org/namespaces/inkscape}window-maximized", "{http://www.inkscape.org/namespaces/inkscape}current-layer"] + ignoreAttrs + return $ (\[pc,bc,bo,ot,gt,gut,id1,sg] [po,ps,ww,wh,zoom,cx,cy,wx,wy,wm,cl]-> + (pc,bc,bo,ot,gt,gut,po,ps,ww,wh,id1,sg,zoom,cx,cy,wx,wy,wm,cl) ) l inkscape + +{- +-} +perspectiveAttrs = + do p <- mapM attr + [ "{http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd}type", + "{http://www.inkscape.org/namespaces/inkscape}vp_x", + "{http://www.inkscape.org/namespaces/inkscape}vp_y", + "{http://www.inkscape.org/namespaces/inkscape}vp_z", + "{http://www.inkscape.org/namespaces/inkscape}persp3d-origin", + "id"] + ignoreAttrs + return $ (\[typ,vp_x,vp_y,vp_z,persp3d_origin,id_] -> + (typ,vp_x,vp_y,vp_z,persp3d_origin,id_) ) p + +------------------------------------------------------------------------------------------------------------- + +feBlendAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","in2","mode"] + ignoreAttrs + return $ (\[class_,style,in1,in2,mode] -> (ca,pa,fpa,class_,style,in1,in2,mode) ) l + +feColorMatrixAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","type","values"] + ignoreAttrs + return $ (\[class_,style,in1,type1,values] -> (ca,pa,fpa,class_,style,in1,type1,values) ) l + +feComponentTransferAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in"] + ignoreAttrs + return $ (\[class_,style,in1] -> (ca,pa,fpa,class_,style,in1) ) l +feCompositeAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","in2","operator","k1","k2","k3","k4"] + ignoreAttrs + return $ (\[class_,style,in1,in2,operator,k1,k2,k3,k4] -> (ca,pa,fpa,class_,style,in1,in2,operator,k1,k2,k3,k4) ) l + +feConvolveMatrixAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","order","kernelMatrix","divisor","bias","targetX","targetY","edgeMode","kernelUnitLength","preserveAlpha"] + ignoreAttrs + return $ (\[class_,style,order,km,d,bias,tx,ty,em,ku,pa] -> (ca,pa,fpa,class_,style,order,km,d,bias,tx,ty,em,ku,pa) ) l + +feDiffuseLightingAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","surfaceScale","diffuseConstant","kernelUnitLength"] + ignoreAttrs + return $ (\[class_,style,in1,surfaceScale,diffuseConstant,kuLength] -> (ca,pa,fpa,class_,style,in1,surfaceScale,diffuseConstant,kuLength) ) l + +feDisplacementMapAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","in2","scale","xChannelSelector","yChannelSelector"] + ignoreAttrs + return $ (\[class_,style,in1,in2,sc,xChan,yChan] -> (ca,pa,fpa,class_,style,in1,in2,sc,xChan,yChan) ) l + +feFloodAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style"] + ignoreAttrs + return $ (\[class_,style] -> (ca,pa,fpa,class_,style) ) l + +feGaussianBlurAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","stdDeviation"] + ignoreAttrs + return $ (\[class_,style,in1,stdDeviation] -> (ca,pa,fpa,class_,style,in1,stdDeviation) ) l + +feImageAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + xlink <- xlinkAttributes + l <- mapM attr + ["class","style","externalResourcesRequired","preserveAspectRatio"] + ignoreAttrs + return $ (\[class_,style,ext,pa] -> (ca,pa,fpa,xlink,class_,style,ext,pa) ) l + +feMergeAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style"] + ignoreAttrs + return $ (\[class_,style] -> (ca,pa,fpa,class_,style) ) l + +feMorphologyAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","operator","radius"] + ignoreAttrs + return $ (\[class_,style,in1,operator,radius] -> (ca,pa,fpa,class_,style,in1,operator,radius) ) l + +feOffsetAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","dx","dy"] + ignoreAttrs + return $ (\[class_,style,in1,dx,dy] -> (ca,pa,fpa,class_,style,in1,dx,dy) ) l + +feSpecularLightingAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","surfaceScale","specularConstant","specularExponent","kernelUnitLength"] + ignoreAttrs + return $ (\[class_,style,in1,surfaceScale,sc,se,ku] -> (ca,pa,fpa,class_,style,in1,surfaceScale,sc,se,ku) ) l + +feTileAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in"] + ignoreAttrs + return $ (\[class_,style,in1] -> (ca,pa,fpa,class_,style,in1) ) l + +feTurbulenceAttrs = + do ca <- coreAttributes + pa <- presentationAttributes + fpa <- filterPrimitiveAttributes + l <- mapM attr + ["class","style","in","in2","mode"] + ignoreAttrs + return $ (\[class_,style,in1,in2,mode] -> (ca,pa,fpa,class_,style,in1,in2,mode) ) l + diff --git a/src/Diagrams/SVG/Attributes.hs b/src/Diagrams/SVG/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/SVG/Attributes.hs @@ -0,0 +1,1013 @@ +{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, TypeFamilies, FlexibleContexts #-} + +-------------------------------------------------------------------- +-- | +-- Module : Diagrams.SVG.Attributes +-- Copyright : (c) 2015 Tillmann Vogt +-- License : BSD3 +-- +-- Maintainer: diagrams-discuss@googlegroups.com +-- Stability : stable +-- Portability: portable + +module Diagrams.SVG.Attributes + ( + initialStyles + -- * Classes of attributes + , CoreAttributes(..) + , ConditionalProcessingAttributes(..) + , DocumentEventAttributes(..) + , GraphicalEventAttributes(..) + , XlinkAttributes(..) + , FilterPrimitiveAttributes(..) + , NameSpaces(..) + -- * General Parsing Functions + , separatedBy + , parseOne + , parseOne' + , compose + , parseDouble + , parseToDouble + , parsePoints + , parseTempl + , parseIRI + -- * Transformations + , applyTr + , parseTr + -- * Parsing the style attribute + , applyStyleSVG + , parseStyles + , parseLengths + , parseViewBox + , parsePA + , cssStylesFromMap + , fragment + , p + , parseSpread + -- * Parsing Colors + -- * Parsing preserve aspect ratio + , parsePreserveAR + , PreserveAR(..) + , AlignSVG(..) + , Place(..) + , MeetOrSlice(..) + , SVGStyle(..) + , PresentationAttributes(..) + ) +where + +import Data.Attoparsec.Combinator +import Data.Attoparsec.Text +import qualified Data.Attoparsec.Text as AT +import Data.Char (isAlpha, isHexDigit, digitToInt) +import Data.Colour +import Data.Colour.Names (readColourName) +import Data.Colour.SRGB +import Data.Colour.RGBSpace.HSL (hsl) +import qualified Data.HashMap.Strict as H +import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes) +import qualified Data.Text as T +import Data.Text(Text(..), pack, unpack, empty, cons, snoc, append) +import Data.Typeable +import Data.Word (Word8) +import Diagrams.Prelude hiding (fillOpacity, strokeOpacity) +import Diagrams.SVG.Path +import Diagrams.SVG.Tree +import Text.CSS.Parse +import Diagrams.Core.Transform +import Data.Digits + +--------------------------------------------------- + +data CoreAttributes = + CA { id1 :: Maybe Text + , xmlbase :: Maybe Text + , xmllang :: Maybe Text + , xmlspace :: Maybe Text + } + +data ConditionalProcessingAttributes = + CPA { requiredFeatures :: Maybe Text + , requiredExtensions :: Maybe Text + , systemLanguage :: Maybe Text + } + +data DocumentEventAttributes = + DEA { onunload :: Maybe Text + , onabort :: Maybe Text + , onerror :: Maybe Text + , onresize :: Maybe Text + , onscroll :: Maybe Text + , onzoom :: Maybe Text + } + +data GraphicalEventAttributes = + GEA { onfocusin :: Maybe Text + , onfocusout :: Maybe Text + , onactivate :: Maybe Text + , onclick :: Maybe Text + , onmousedown :: Maybe Text + , onmouseup :: Maybe Text + , onmouseover :: Maybe Text + , onmousemove :: Maybe Text + , onmouseout :: Maybe Text + , onload :: Maybe Text + } + +data XlinkAttributes = + XLA { xlinkHref :: Maybe Text + , xlinkShow :: Maybe Text + , xlinkActuate :: Maybe Text + , xlinkType :: Maybe Text + , xlinkRole :: Maybe Text + , xlinkArcrole :: Maybe Text + , xlinkTitle :: Maybe Text + } + +data FilterPrimitiveAttributes = + FPA { x :: Maybe Text + , y :: Maybe Text + , width :: Maybe Text + , height :: Maybe Text + , result :: Maybe Text + } + +data NameSpaces = + NSP { xlink :: Maybe Text + , dc :: Maybe Text + , cc :: Maybe Text + , rdf :: Maybe Text + , svg :: Maybe Text + , sodipodi :: Maybe Text + , inkscape :: Maybe Text + } deriving Show + +-------------------------------------------------------------------------------- +-- General parsing functions +-------------------------------------------------------------------------------- + +-- | Parsing content separated by something, e.g. ";" like in: "a;b;c;d;" or "a;b;c;d" +separatedBy parse sep = do ls <- many1 (choice [parseOne parse sep, parseOne' parse]) + return ls + +parseOne parse sep = do AT.skipSpace + s <- parse + AT.string sep + return s + +parseOne' parse = do AT.skipSpace + s <- parse + return s + +-- | See +compose :: [a -> a] -> a -> a +compose fs v = Prelude.foldl (flip (.)) id fs $ v + +parseDouble :: RealFloat n => Text -> n +parseDouble l = either (const 0) (fromRational . toRational) (AT.parseOnly myDouble l) + +parseToDouble :: RealFloat n => Maybe Text -> Maybe n +parseToDouble l | isJust l = either (const Nothing) (Just . fromRational . toRational) (AT.parseOnly myDouble (fromJust l)) + | otherwise = Nothing +pp = parseDouble . pack + +myDouble = AT.choice [dotDouble, double] + +dotDouble = + do AT.skipSpace + AT.char '.' + frac <- AT.decimal + let denominator = fromIntegral (10^(length $ digits 10 frac)) + return ((fromIntegral frac) / denominator) + +parsePoints :: RealFloat n => Text -> [(n, n)] +parsePoints t = either (const []) id (AT.parseOnly (many' parsePoint) t) + +parsePoint :: RealFloat n => Parser (n, n) +parsePoint = + do AT.skipSpace + a <- double + AT.char ',' + b <- double + return ( (fromRational . toRational) a, (fromRational . toRational) b) + +parseUntil c = AT.manyTill AT.anyChar (AT.char c) + +data Tup n = TS1 Text | TS2 Text Text | TS3 Text Text Text + | T1 n | T2 n n | T3 n n n + deriving Show + +parse1 = + do AT.skipSpace + AT.char '(' + a <- AT.takeTill (== ')') + AT.char ')' + return (TS1 a) + +parse2 = + do AT.skipSpace + AT.char '(' + a <- AT.takeTill (\c -> c == ',' || c == ' ') + AT.choice [AT.char ',', AT.char ' '] + AT.skipSpace + b <- AT.takeTill (== ')') + AT.char ')' + return (TS2 a b) + +parse3 = + do AT.skipSpace + AT.char '(' + a <- AT.takeTill (\c -> c == ',' || c == ' ') + AT.choice [AT.char ',', AT.char ' '] + b <- AT.takeTill (\c -> c == ',' || c == ' ') + AT.choice [AT.char ',', AT.char ' '] + c <- AT.takeTill (== ')') + AT.char ')' + return (TS3 a b c) + +----------------------------------------------------------------------------------------------------------------- +-- Transformations, see +-- +-- Example: transform="translate(-121.1511,-167.6958) matrix(4.675013,0,0,4.675013,-1353.75,-678.4329)" +----------------------------------------------------------------------------------------------------------------- + +data Transform n = Tr (Tup n) + | Matrix n n n n n n + | Rotate (Tup n) + | Scale (Tup n) + | SkewX (Tup n) + | SkewY (Tup n) deriving Show + +parseTr :: RealFloat n => Maybe Text -> [Transform n] +parseTr = reverse . + catMaybes . + (either (const []) id) . + ( AT.parseOnly (AT.many1 parseTransform)) . + (fromMaybe empty) + +parseTransform = AT.choice [matr, trans, scle, rot, skewX, skewY] + +applyTr trs = compose (map getTransformations trs) + +getTransformations (Tr (T1 x)) = translateX x +getTransformations (Tr (T2 x y)) = (translateX x) . (translateY y) + +-- | See +getTransformations (Matrix a b c d e f) + = (translateX x) . (translateY y) . (rotateBy angle) . (scaleX scX) . (scaleY scY) + where (angle, scX, scY, x, y) = matrixDecompose (Matrix a b c d e f) + + +-- matrix(0.70710678,-0.70710678,0.70710678,0.70710678,0,0) + +getTransformations (Rotate (T1 angle)) = rotateBy angle +getTransformations (Rotate (T3 angle x y)) = id -- rotationAbout (p2 (x,y)) (angle) +getTransformations (Scale (T1 x)) = scaleX x +getTransformations (Scale (T2 x y)) = (scaleX x) . (scaleY y) +getTransformations (SkewX (T1 x)) = id +getTransformations (SkewY (T1 y)) = id + +-- | See +matrixDecompose (Matrix m11 m12 m21 m22 m31 m32) = (rotation, scX, scY, transX, transY) + where + rotation = (atan2 m12 m22) / (2*pi) + scX | m11 >= 0 = sqrt (m11*m11 + m21*m21) + | otherwise = - sqrt (m11*m11 + m21*m21) + scY | m22 >= 0 = sqrt (m12*m12 + m22*m22) + | otherwise = - sqrt (m12*m12 + m22*m22) + (transX, transY) = (m31, m32) + +matr = + do AT.skipSpace + AT.string "matrix" + AT.skipSpace + AT.char '(' + a <- parseUntil ',' + b <- parseUntil ',' + c <- parseUntil ',' + d <- parseUntil ',' + e <- parseUntil ',' + f <- parseUntil ')' + return (Just $ Matrix (pp a) (pp b) (pp c) (pp d) (pp e) (pp f) ) + +evalTup (TS1 x) = T1 (parseDouble x) +evalTup (TS2 x y) = T2 (parseDouble x) (parseDouble y) +evalTup (TS3 x y z) = T3 (parseDouble x) (parseDouble y) (parseDouble z) + +trans = + do AT.skipSpace + AT.string "translate" + tup <- AT.choice [parse2, parse1] + return (Just $ Tr (evalTup tup)) + +scle = + do AT.skipSpace + AT.string "scale" + tup <- AT.choice [parse2, parse1] + return (Just $ Scale (evalTup tup)) + +rot = + do AT.skipSpace + AT.string "rotate" + tup <- AT.choice [parse1, parse3] + return (Just $ Rotate (evalTup tup)) + +skewX = + do AT.skipSpace + AT.string "skewX" + angle <- parse1 + return (Just $ SkewX (evalTup angle)) + +skewY = + do AT.skipSpace + AT.string "skewY" + angle <- parse1 + return (Just $ SkewY (evalTup angle)) + +------------------------------------------------------------------------------------------------ +-- Parse the styles of various presentation attributes. +-- Example: Maybe Text -> HashMaps b n -> [(SVGStyle n a)] +parseStyles text hmaps = either (const []) id $ + AT.parseOnly (separatedBy (parseStyleAttr hmaps) ";") (fromMaybe empty text) + +-- parseStyleAttr :: (Read a, RealFloat a, RealFloat n) => HashMaps b n -> Parser (SVGStyle n a) +parseStyleAttr (ns,css,grad) = + AT.choice [styleFillRule, styleStrokeWidth, styleStrokeDashArray, styleFill css grad, styleStroke css grad, styleStopColor, + styleStopOpacity, styleFillOpacity, styleStrokeOpacity, styleOpacity, + styleFontFamily, styleFontStyle, styleFontVariant, styleFontWeight, styleFontStretch, styleFontSize, + styleStrokeLineCap, styleStrokeLineJoin, styleStrokeMiterLimit, styleClipPath ns, skipOne] + +skipOne = do str <- AT.manyTill AT.anyChar (AT.char ';') -- TODO end of input ? + return EmptyStyle + +-- | This function is called on every tag and returns a list of style-attributes to apply +-- (if there is a rule that matches) +-- TO DO: CSS2 + CSS3 selectors +-- cssStylesFromMap :: (Read a, RealFloat a, RealFloat n) => +-- HashMaps b n -> Text -> Maybe Text -> Maybe Text -> [(SVGStyle n a)] +cssStylesFromMap (ns,css,grad) tagName id_ class_ = parseStyles ( Just ( T.concat ( map f attributes ) ) ) (ns,css,grad) + where f (attr, val) = (attr `Data.Text.snoc` ':') `append` (val `Data.Text.snoc` ';') + styleFromClass cl = [H.lookup ('.' `Data.Text.cons` cl) css] ++ [H.lookup (tagName `append` ('.' `Data.Text.cons` cl)) css] + attributes = concat $ catMaybes + ( [H.lookup "*" css] ++ -- apply this style to every element + (if isJust id_ then [H.lookup ('#' `Data.Text.cons` (fromJust id_)) css] else []) ++ + (concat (map styleFromClass (if isJust class_ then T.words $ fromJust class_ else []))) + ) + +-- | a template that deals with the common parser errors +parseTempl :: Parser a -> Maybe Text -> Maybe a +parseTempl p = (either (const Nothing) Just) . + (AT.parseOnly p). + (fromMaybe empty) + +-- | Given a minimum and maximum value of a viewbox (x or y-direction) and a maybe a Text value +-- Parse this Text value as a length (with a unit) or a percentage relative to the viewbox (minx,maxx) +-- If parsers fails return def +p :: RealFloat n => (n,n) -> n -> Maybe Text -> n +p (minx,maxx) def x = unL $ fromMaybe (Len def) $ parseTempl styleLength x + where unL (Len x) = x + unL (Percent x) = x/100 * (maxx-minx) + +parseIRI = do AT.choice [ funcIRI, absoluteOrRelativeIRI ] + +funcIRI = + do AT.skipSpace + AT.string "url(" + absrel <- parseUntil '#' + frag <- parseUntil ')' + return (T.pack absrel, T.pack frag) + +absoluteOrRelativeIRI = + do AT.skipSpace + absrel <- parseUntil '#' + frag <- takeText + return (T.pack absrel, frag) + +fragment x = fmap snd (parseTempl parseIRI x) -- look only for the text after "#" + +-- | Inital styles, see: +initialStyles = lwL 1 . fc black . lineCap LineCapButt . lineJoin LineJoinMiter . lineMiterLimit 4 . lcA transparent + . fontSize medium + -- fillRule nonzero -- TODO + -- fillOpcacity 1 -- TODO + -- stroke-opacity 1 # + -- stroke-dasharray none + -- stroke-dashoffset 0 # + -- display inline + +applyStyleSVG stylesFromMap hmap = compose (map getStyles (stylesFromMap hmap)) + +getStyles (Fill c) = fcA c +getStyles (FillTex x) = fillTexture x +getStyles (FillRule Even_Odd) = fillRule EvenOdd +getStyles (FillRule Nonzero) = id +getStyles (FillRule Inherit) = id +getStyles (FillOpacity x) = Diagrams.Prelude.opacity x +getStyles (FontFamily str) = font str +getStyles (FontStyle s) = id +getStyles (FontVariant s) = id +getStyles (FontWeight s) = id +getStyles (FontStretch s) = id +getStyles (FontSize (Len len)) = fontSize (local len) +-- getStyles (FontSize (Percent len)) = fontSize (local len) +getStyles (Diagrams.SVG.Attributes.Opacity x) = Diagrams.Prelude.opacity x +getStyles (StrokeOpacity x) | x == 0 = lwL 0 + | otherwise = Diagrams.Prelude.opacity x -- we currently don't differentiate between fill opacity and stroke opacity +getStyles (Stroke x) = lcA x +getStyles (StrokeTex x) = lineTexture x +getStyles (StrokeWidth (Len x)) = lwL $ fromRational $ toRational x +getStyles (StrokeWidth (Percent x)) = lwG x +getStyles (StrokeLineCap x) = lineCap x +getStyles (StrokeLineJoin x) = lineJoin x +getStyles (StrokeMiterLimit x) = id +getStyles (StrokeDasharray array) = dashingL (map dash array) 0 + where dash (Len x) = x + dash (Percent x) = x -- TODO implement percent length +getStyles (ClipPath path) = clipBy path +getStyles _ = id + +-- | Example: style="fill:#ffb13b" style="fill:red" +styleFill css hmap = + do AT.skipSpace + AT.string "fill:" + AT.skipSpace + styleFillVal css hmap + +styleFillVal css gradients = AT.choice [ styleFillColourVal, styleFillTexURL css gradients ] + +styleFillColourVal = + do c <- AT.choice [colorRRGGBB, colorRGB, colorString, colorRGBPercent, colorHSLPercent, colorNone, colorRGBWord] + return (Fill c) + +styleFillTexURL css gradients = + do (absrel,frag) <- parseIRI + let t = H.lookup frag gradients + if isJust t then return (FillTex (getTexture (fromJust t))) + else return EmptyStyle + where getTexture (Gr refId ga vb stops f) = f css ga (fromMaybe (0,0,0,0) vb) stops + +-- | Example: style="fill-rule:evenodd" +styleFillRule = + do AT.skipSpace + AT.string "fill-rule:" + AT.skipSpace + styleFillRuleVal + +styleFillRuleVal = + do AT.choice [ (do{ AT.string "evenodd"; return $ FillRule Even_Odd }), + (do{ AT.string "nonzero"; return $ FillRule Nonzero }), + (do{ AT.string "inherit"; return $ FillRule Inherit }) + ] + +-- | Example: style="fill:#ffb13b" style="fill:red" +styleFillOpacity = + do AT.skipSpace + AT.string "fill-opacity:" + AT.skipSpace + styleFillOpacityVal + +styleFillOpacityVal = + do o <- myDouble + return (FillOpacity $ fromRational $ toRational o) + +-- | Example: style="fill:#ffb13b" style="fill:red" +styleOpacity = + do AT.skipSpace + AT.string "opacity:" + AT.skipSpace + styleOpacityVal + +styleOpacityVal = + do o <- myDouble + return (Diagrams.SVG.Attributes.Opacity $ fromRational $ toRational o) + + +-- | Example: style="stroke:black" +styleStroke css hmap = + do AT.skipSpace + AT.string "stroke:" + AT.skipSpace + styleStrokeVal css hmap + +styleStrokeVal css gradients = AT.choice [ styleStrokeColourVal, styleStrokeTexURL css gradients ] + +styleStrokeColourVal = + do c <- AT.choice [colorRRGGBB, colorRGB, colorString, colorRGBPercent, colorHSLPercent, colorNone, colorRGBWord] + return (Stroke c) + +styleStrokeTexURL css gradients = + do (absrel,frag) <- parseIRI + let t = H.lookup frag gradients + if isJust t then return (StrokeTex (getTexture (fromJust t))) + else return EmptyStyle + where getTexture (Gr refId ga vb stops f) = f css ga (fromMaybe (0,0,0,0) vb) stops + +-- | Example: style="stroke-width:0.503546" +styleStrokeWidth = + do AT.skipSpace + AT.string "stroke-width:" + styleStrokeWidthVal + +styleStrokeWidthVal = + do len <- styleLength + return (StrokeWidth len) + +------------------------------------------------------------------------------------- +-- font + +styleFontFamily = + do AT.skipSpace + AT.string "font-family:" + str <- AT.manyTill AT.anyChar theEnd + return (FontFamily str) + +theEnd = do AT.choice [AT.char ';', do { endOfInput; return ' '}] + + +data FStyle = NormalStyle | Italic | Oblique | FSInherit + +styleFontStyle = + do AT.skipSpace + AT.string "font-style:" + AT.choice [ do { string "normal"; return (FontStyle NormalStyle)} + , do { string "italic"; return (FontStyle Italic)} + , do { string "oblique"; return (FontStyle Oblique)} + , do { string "inherit"; return (FontStyle FSInherit)} + ] + + +data FVariant = NormalVariant | SmallCaps | VInherit + +styleFontVariant = + do AT.skipSpace + AT.string "font-variant:" + AT.choice [ do { string "normal"; return (FontVariant NormalVariant)} + , do { string "small-caps"; return (FontVariant SmallCaps)} + , do { string "inherit"; return (FontVariant VInherit)} + ] + + +data FWeight = NormalWeight | Bold | Bolder | Lighter + | N100 | N200 | N300 | N400 | N500 | N600 | N700 | N800 | N900 + | FWInherit + +styleFontWeight = + do AT.skipSpace + AT.string "font-weight:" + AT.choice [ do { string "normal"; return (FontWeight NormalWeight)} + , do { string "bold"; return (FontWeight Bold)} + , do { string "bolder"; return (FontWeight Bolder)} + , do { string "lighter"; return (FontWeight Lighter)} + , do { string "100"; return (FontWeight N100)} + , do { string "200"; return (FontWeight N200)} + , do { string "300"; return (FontWeight N300)} + , do { string "400"; return (FontWeight N400)} + , do { string "500"; return (FontWeight N500)} + , do { string "600"; return (FontWeight N600)} + , do { string "700"; return (FontWeight N700)} + , do { string "800"; return (FontWeight N800)} + , do { string "900"; return (FontWeight N900)} + , do { string "inherit"; return (FontWeight FWInherit)} + ] + + +data FStretch = NormalStretch | Wider | Narrower | UltraCondensed | ExtraCondensed | Condensed + | SemiCondensed | SemiExpanded | Expanded | ExtraExpanded | UltraExpanded | SInherit + +styleFontStretch = + do AT.skipSpace + AT.string "font-stretch:" + AT.choice [ do { string "normal"; return (FontStretch NormalStretch)} + , do { string "wider"; return (FontStretch Wider)} + , do { string "narrower"; return (FontStretch Narrower)} + , do { string "ultra-condensed"; return (FontStretch UltraCondensed)} + , do { string "extra-condensed"; return (FontStretch ExtraCondensed)} + , do { string "condensed"; return (FontStretch Condensed)} + , do { string "semi-condensed"; return (FontStretch SemiCondensed)} + , do { string "semi-expanded"; return (FontStretch SemiExpanded)} + , do { string "expanded"; return (FontStretch Expanded)} + , do { string "extra-expanded"; return (FontStretch ExtraExpanded)} + , do { string "ultra-expanded"; return (FontStretch UltraExpanded)} + , do { string "inherit"; return (FontStretch SInherit)} + ] + +styleFontSize = + do AT.skipSpace + AT.string "font-size:" + len <- styleLength + return (FontSize len) + +------------------------------------------------------------------------------------------------------------ + +-- | See +styleLength = + do AT.skipSpace + d <- myDouble + AT.skipSpace + AT.choice [ styleLengthWithUnit (fromRational $ toRational d), + lengthPercent (fromRational $ toRational d), return (Len (fromRational $ toRational d)) ] + +styleLengthWithUnit d = + do u <- styleUnit + return (Len (d * (unitFactor u))) + +lengthPercent d = + do AT.string "%" + return (Percent d) + +styleUnit = do AT.choice [styleEM,styleEX,stylePX,styleIN,styleCM,styleMM,stylePT,stylePC] + +styleEM = do { AT.choice [AT.string "em", AT.string "EM"]; return EM } +styleEX = do { AT.choice [AT.string "ex", AT.string "EX"]; return EX } +stylePX = do { AT.choice [AT.string "px", AT.string "PX"]; return PX } +styleIN = do { AT.choice [AT.string "in", AT.string "IN"]; return IN } +styleCM = do { AT.choice [AT.string "cm", AT.string "CM"]; return CM } +styleMM = do { AT.choice [AT.string "mm", AT.string "MM"]; return MM } +stylePT = do { AT.choice [AT.string "pt", AT.string "PT"]; return PT } +stylePC = do { AT.choice [AT.string "pc", AT.string "PC"]; return PC } + +unitFactor EM = 1 +unitFactor EX = 1 +unitFactor PX = 1 +unitFactor IN = 90 +unitFactor CM = 35.43307 +unitFactor MM = 3.543307 +unitFactor PT = 1.25 +unitFactor PC = 15 + +-- | Example: "stroke-linecap:butt" +styleStrokeLineCap = + do AT.skipSpace + AT.string "stroke-linecap:" + AT.skipSpace + styleStrokeLineCapVal + +styleStrokeLineCapVal = + do lc <- AT.choice [butt,round0,square0] + return (StrokeLineCap lc) + +butt = do { AT.string "butt"; return LineCapButt } +round0 = do { AT.string "round"; return LineCapRound } +square0 = do { AT.string "square"; return LineCapSquare } + +-- | Example: "stroke-linejoin:miter;" +styleStrokeLineJoin = + do AT.skipSpace + AT.string "stroke-linejoin:" + AT.skipSpace + styleStrokeLineJoinVal + +styleStrokeLineJoinVal = + do lj <- AT.choice [miter,round1,bevel] + return (StrokeLineJoin lj) + +miter = do { AT.string "miter"; return LineJoinMiter } +round1 = do { AT.string "round"; return LineJoinRound } +bevel = do { AT.string "bevel"; return LineJoinBevel } + +styleClipPath hmap = + do AT.skipSpace + AT.string "clip-path:" + AT.skipSpace + styleClipPathVal hmap + +styleClipPathVal hmap = + do (absrel,frag) <- parseIRI + let t = H.lookup frag hmap + if isJust t then return (ClipPath $ evalPath hmap Nothing (fromJust t)) + else return EmptyStyle + +-- | Evaluate the tree to a path. Is only needed for clipPaths +evalPath :: RealFloat n => H.HashMap Text (Tag b n) -> Maybe (ViewBox n) -> (Tag b n) -> Path V2 n +evalPath hmap (Just viewBox) (Leaf id1 path diagram) = path viewBox +evalPath hmap Nothing (Leaf id1 path diagram) = path (0,0,1,1) -- shouldn't happen, there should always be a viewbox +evalPath hmap _ (SubTree _ id1 _ (Just viewBox) ar f children) = mconcat (map (evalPath hmap (Just viewBox)) children) +evalPath hmap (Just viewBox) (SubTree _ id1 _ Nothing ar f children) = mconcat (map (evalPath hmap (Just viewBox)) children) +-- evalPath hmap (Reference selfId id1 wh f) = evalPath hmap (lookUp hmap (fragment id1)) -- TODO implement (not that common) +evalPath hmap _ _ = mempty + +-- | Lookup a diagram and return an empty diagram in case the SVG-file has a wrong reference +lookUp hmap i | isJust l = fromJust l + | otherwise = Leaf Nothing mempty mempty -- an empty diagram if we can't find the id + where l = H.lookup i hmap + +-- | Example: "stroke-miterlimit:miter;" +styleStrokeMiterLimit = + do AT.skipSpace + AT.string "stroke-miterlimit:" + AT.skipSpace + styleStrokeMiterLimitVal + +styleStrokeMiterLimitVal = + do l <- myDouble + return $ StrokeMiterLimit $ (fromRational . toRational) l + +styleStrokeDashArray = + do AT.skipSpace + AT.string "stroke-dasharray:" + styleStrokeDashArrayVal + +styleStrokeDashArrayVal = + do len <- parseLengths + return (StrokeDasharray len) + +parseLengths = separatedBy styleLength "," + +styleStrokeOpacity = + do AT.skipSpace + AT.string "stroke-opacity:" + AT.skipSpace + styleStrokeOpacityVal + +styleStrokeOpacityVal = + do l <- myDouble + return $ StrokeOpacity $ (fromRational . toRational) l + +styleStopColor = + do AT.skipSpace + AT.string "stop-color:" + AT.skipSpace + styleFillColourVal + +styleStopOpacity = + do AT.skipSpace + AT.string "stop-opacity:" + AT.skipSpace + styleFillOpacityVal + +-- TODO: Visibility, marker +----------------------------------------------------------------------- +-- Colors, see and +-- +----------------------------------------------------------------------- + +colorString = + do a <- Data.Attoparsec.Text.takeWhile isAlpha + c <- readColourName (unpack a) + return (opaque c) + +colorRGB = + do AT.char '#' + h0 <- satisfy isHexDigit + h1 <- satisfy isHexDigit + h2 <- satisfy isHexDigit + return $ opaque ( sRGB24 (fromIntegral ((digitToInt h0) * 16)) + (fromIntegral ((digitToInt h1) * 16)) + (fromIntegral ((digitToInt h2) * 16)) ) + +colorRRGGBB = + do AT.char '#' + h0 <- satisfy isHexDigit + h1 <- satisfy isHexDigit + h2 <- satisfy isHexDigit + h3 <- satisfy isHexDigit + h4 <- satisfy isHexDigit + h5 <- satisfy isHexDigit + return $ opaque ( sRGB24 (fromIntegral ((digitToInt h0) * 16 + (digitToInt h1)) ) + (fromIntegral ((digitToInt h2) * 16 + (digitToInt h3)) ) + (fromIntegral ((digitToInt h4) * 16 + (digitToInt h5)) ) ) + +colorRGBWord = + do AT.string "rgb(" + AT.skipSpace + r <- decimal + AT.skipSpace + AT.char ',' + AT.skipSpace + g <- decimal + AT.skipSpace + AT.char ',' + AT.skipSpace + b <- decimal + AT.skipSpace + AT.char ')' + return $ opaque (sRGB ((fromIntegral r)/255) ((fromIntegral g)/255) ((fromIntegral b)/255)) + +colorRGBPercent = + do AT.string "rgb(" + AT.skipSpace + r <- decimal + AT.char '%' + AT.skipSpace + AT.char ',' + AT.skipSpace + g <- decimal + AT.char '%' + AT.skipSpace + AT.char ',' + AT.skipSpace + b <- decimal + AT.char '%' + AT.skipSpace + AT.char ')' + return $ opaque (sRGB ((fromIntegral r)/100) ((fromIntegral g)/100) ((fromIntegral b)/100)) + +colorHSLPercent = + do AT.string "hsl(" + AT.skipSpace + h <- decimal + AT.char '%' + AT.skipSpace + AT.char ',' + AT.skipSpace + s <- decimal + AT.char '%' + AT.skipSpace + AT.char ',' + AT.skipSpace + l <- decimal + AT.char '%' + AT.skipSpace + AT.char ')' + let c = hsl (fromIntegral h) (fromIntegral s) (fromIntegral l) + return $ opaque (sRGB (channelRed c) (channelGreen c) (channelBlue c)) + +colorNone = + do AT.string "none" + return transparent + +------------------------------------------------------------------------------------- +-- | Example: spreadMethod="pad" +parseSpread :: Maybe Text -> SpreadMethod +parseSpread spr | isJust parsedSpread = fromJust parsedSpread + | otherwise = GradPad -- most of the time its "pad" + where parsedSpread = parseTempl gradSpread spr + +gradSpread = AT.choice [gradPad, gradReflect, gradRepeat ] + +gradPad = do AT.string "pad" + return GradPad + +gradReflect = do AT.string "reflect" + return GradReflect + +gradRepeat = do AT.string "repeat" + return GradRepeat + +------------------------------------------------------------------------------------- +-- | Example: viewBox="0 0 100 30" +-- Viewboxes establish a new viewport. Percentages (e.g. x="50%") only make sense with a viewport. +parseViewBox :: RealFloat n => Maybe Text -> Maybe Text -> Maybe Text -> Maybe (ViewBox n) +parseViewBox vb w h | isJust parsedVB = parsedVB -- This is how it should always be, + -- but sometimes an -tag has no viewbox attribute + | pw == 0 || ph == 0 = Nothing -- TODO: What does a browser do here? + | otherwise = Just (0,0,pw, ph) -- If there is no viewbox the image size is the viewbox + -- TODO: What does a browser do here? + -- The only other option I see is finding the min and max values of + -- shapes in user coordinate system, ignoring percentages + -- But one pass to just find out the viewbox? + where parsedVB = parseTempl viewBox vb + + -- Assuming percentages are not used in width/height of the top -tag + -- and there are no sub--tags that use percentage-width/height to refer to their calling viewbox + -- Using width and height is a hack anyway + pw | isJust w = parseDouble $ fromJust w + | otherwise = 0 + ph | isJust h = parseDouble $ fromJust h + | otherwise = 0 + +viewBox = + do AT.skipSpace + minx <- myDouble + AT.skipSpace + miny <- myDouble + AT.skipSpace + width <- myDouble + AT.skipSpace + height <- myDouble + AT.skipSpace + return ((fromRational . toRational) minx, + (fromRational . toRational) miny, + (fromRational . toRational) width, + (fromRational . toRational) height) + +------------------------------------------------------------------------------------- +-- Parse preserve aspect ratio +-- e.g. preserveAspectRatio="xMaxYMax meet" +------------------------------------------------------------------------------------- + +parsePreserveAR x = parseTempl preserveAR x + +preserveAR = + do AT.skipSpace + align <- AT.choice [alignXMinYMin,alignXMidYMin,alignXMaxYMin,alignXMinYMid,alignXMidYMid, + alignXMaxYMid,alignXMinYMax,alignXMidYMax,alignXMaxYMax] + AT.skipSpace + meetOrSlice <- AT.choice [meet, slice] + return (PAR align meetOrSlice) + +meet = + do AT.string "meet" + return Meet + +slice = + do AT.string "slice" + return Slice + +alignXMinYMin = + do AT.string "xMinYMin" + return (AlignXY 0 0) + +alignXMidYMin = + do AT.string "xMidYMin" + return (AlignXY 0.5 0) + +alignXMaxYMin = + do AT.string "xMaxYMin" + return (AlignXY 1 0) + +alignXMinYMid = + do AT.string "xMinYMid" + return (AlignXY 0 0.5) + +alignXMidYMid = + do AT.string "xMidYMid" + return (AlignXY 0.5 0.5) + +alignXMaxYMid = + do AT.string "xMaxYMid" + return (AlignXY 1 0.5) + +alignXMinYMax = + do AT.string "xMinYMax" + return (AlignXY 0 1) + +alignXMidYMax = + do AT.string "xMidYMax" + return (AlignXY 0.5 1) + +alignXMaxYMax = + do AT.string "xMaxYMax" + return (AlignXY 1 1) + diff --git a/src/Diagrams/SVG/Fonts/CharReference.hs b/src/Diagrams/SVG/Fonts/CharReference.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/SVG/Fonts/CharReference.hs @@ -0,0 +1,57 @@ +module Diagrams.SVG.Fonts.CharReference (charsFromFullName, characterStrings) where +import Control.Applicative ((<|>), many) +import Data.Attoparsec.Text +import qualified Data.Text as T +import Data.List (sortBy) + +charRef :: Parser Int +charRef + = do + _ <- try (string (T.pack "&#x")) + d <- hexadecimal + _ <- char ';' + return d + <|> do + _ <- try (string (T.pack "&#")) + d <- decimal + _ <- char ';' + return d + <|> do + c <- anyChar + return (fromEnum c) + "character reference" + +charRefs :: Parser [Int] +charRefs = do l <- many1 charRef + return l + +fromCharRefs :: T.Text -> [Int] +fromCharRefs str + = case (parseOnly charRefs str) of + Right x -> x + Left _ -> [] + +-- | Parsing of xml character references. +-- +-- I.e. \"\&\#x2e\;\&\#x2e\;\&\#x2e\;\" is converted into a list of three Chars. +-- +-- \"ffb\" is also parsed and converted into three Chars (not changing it). +charsFromFullName :: String -> String +charsFromFullName str = map toEnum ( fromCharRefs (T.pack str) ) + + +-- | A string represents a glyph, i.e. the ligature \"ffi\" is a string that represents the ligature glyph ffi +characterStrings :: String -> [String] -> [T.Text] +characterStrings str ligs | null ligs = map ((T.pack).(\x->[x])) str + | otherwise = case parseOnly myParser (T.pack str) + of Right x -> x + Left _ -> [] + where myParser = many (try ligatures <|> charToText) + ligatures = buildChain $ sortBy -- sort so that the longest ligatures come first, i.e. "ffi", "ff", .. + (\x y -> compare (length y) (length x)) $ ligs + buildChain [] = string (T.pack "") -- will never be called, just to get rid of the warning message + buildChain [x] = parseLigature x -- try to parse with the first parsers in the chain first + buildChain (x:xs) = try (parseLigature x) <|> buildChain xs + parseLigature x = string (T.pack x) + charToText = do c <- anyChar -- or accept a single char + return (T.singleton c) diff --git a/src/Diagrams/SVG/Fonts/ReadFont.hs b/src/Diagrams/SVG/Fonts/ReadFont.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/SVG/Fonts/ReadFont.hs @@ -0,0 +1,190 @@ +module Diagrams.SVG.Fonts.ReadFont + ( + FontData(..) + , FontFace(..) + , Kern(..) + , KernDir(..) + , FontContent(..) + + , parseBBox +-- , bbox_dy +-- , bbox_lx, bbox_ly + +-- , underlinePosition +-- , underlineThickness + + , kernMap + , horizontalAdvance +-- , kernAdvance + + , OutlineMap + , PreparedFont + ) where + +import Data.Char (isSpace) +import Data.List (intersect, sortBy) +import Data.List.Split (splitOn, splitWhen) +import qualified Data.HashMap.Strict as H +import Data.Maybe (catMaybes, fromJust, fromMaybe, + isJust, isNothing, maybeToList) +import qualified Data.Text as T +import Data.Text (Text(..), pack, unpack, empty, words) +import Data.Text.Read (double) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Diagrams.Path +import Diagrams.Prelude hiding (font) + +import Diagrams.SVG.Fonts.CharReference (charsFromFullName) +import Diagrams.SVG.Path +import Diagrams.SVG.Tree + +kernMap :: [Kern n] -> KernMaps n +kernMap kernlist = KernMaps [] H.empty H.empty H.empty H.empty V.empty -- (transformChars (map kernU1) + where + transformChars chars = H.fromList $ map ch $ multiSet $ map (\(x,y) -> (x,[y])) $ sort fst $ + concat $ addIndex chars -- e.g. [["aa","b"],["c","d"]] to [("aa",0),("b",0),("c",1), ("d",1)] + ch (x,y) | null x = ("",y) + | otherwise = (x,y) + + addIndex qs = zipWith (\x y -> (map (\z -> (z,x)) y)) [0..] qs + sort f xs = sortBy (\x y -> compare (f x) (f y) ) xs + + multiSet [] = [] + multiSet (a:[]) = [a] -- example: [("n1",[0]),("n1",[1]),("n2",[1])] to [("n1",[0,1]),("n2",[1])] + multiSet (a:b:bs) | fst a == fst b = multiSet ( (fst a, (snd a) ++ (snd b)) : bs) + | otherwise = a : (multiSet (b:bs)) + + fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f)) + + +parseBBox :: (Read n, RealFloat n) => Maybe Text -> [n] +parseBBox bbox = maybe [] ((map convertToN) . T.words) bbox + where convertToN = fromRational . toRational . (either (const 0) fst) . double + +-- glyphs = map glyphsWithDefaults glyphElements + + -- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with "horiz-adv-x=" in +-- glyphsWithDefaults g = (charsFromFullName $ fromMaybe gname (findAttr (unqual "unicode") g), -- there is always a name or unicode +-- ( +-- gname, +-- fromMaybe fontHadv (fmap read (findAttr (unqual "horiz-adv-x") g)), +-- fromMaybe "" (findAttr (unqual "d") g) +-- ) +-- ) +-- where gname = fromMaybe "" (findAttr (unqual "glyph-name") g) + +-- | Horizontal advance of a character consisting of its width and spacing, extracted out of the font data +horizontalAdvance :: RealFloat n => Text -> FontData b n -> n +horizontalAdvance ch fontD + | isJust char = (\(a,b,c) -> b) (fromJust char) + | otherwise = fontDataHorizontalAdvance fontD + where char = (H.lookup ch (fontDataGlyphs fontD)) + +-- | See +-- +-- Some explanation how kerning is computed: +-- +-- In Linlibertine.svg, there are two groups of chars: e.g. +-- \ +-- This line means: If there is an f followed by parentright, reduce the horizontal advance by -37 (add 37). +-- Therefore to quickly check if two characters need kerning assign an index to the second group (g2 or u2) +-- and assign to every unicode in the first group (g1 or u1) this index, then sort these tuples after their +-- name (for binary search). Because the same unicode char can appear in several g1s, reduce this 'multiset', +-- ie all the (\"name1\",0) (\"name1\",1) to (\"name1\",[0,1]). +-- Now the g2s are converted in the same way as the g1s. +-- Whenever two consecutive chars are being printed try to find an +-- intersection of the list assigned to the first char and second char + +-- | Change the horizontal advance of two consective chars (kerning) +{- +kernAdvance :: RealFloat n => String -> String -> KernMaps n -> Bool -> n +kernAdvance ch0 ch1 kern u | u && not (null s0) = (kernK kern) V.! (head s0) + | not u && not (null s1) = (kernK kern) V.! (head s1) + | otherwise = 0 + where s0 = intersect (s kernU1S ch0) (s kernU2S ch1) + s1 = intersect (s kernG1S ch0) (s kernG2S ch1) + s sel ch = concat (maybeToList (Map.lookup ch (sel kern))) +-} +-- > import Graphics.SVGFonts.ReadFont +-- > textWH0 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "SPACES" lin INSIDE_WH KERN False 8 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL +-- > textWH1 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "are sometimes better." lin INSIDE_WH KERN False 8 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL +-- > textWH2 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "But too many chars are not good." lin INSIDE_WH KERN False 8 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL +-- > textWH = textWH0 # alignBL === strutY 0.3 === textWH1 === strutY 0.3 === textWH2 # alignBL +-- > textW0 = (rect 3 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" lin INSIDE_W KERN False 3 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL +-- > textW1 = (rect 10 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" lin INSIDE_W KERN False 10 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL +-- > textW = textW0 # alignBL ||| strutX 1 ||| textW1 # alignBL +-- > textH0 = (rect 10 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" lin INSIDE_H KERN False 10 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL +-- > textH1 = (rect 3 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" lin INSIDE_H KERN False 3 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL +-- > textH = textH0 # alignBL === strutY 0.5 === textH1 # alignBL + +-- > import Graphics.SVGFonts.ReadFont +-- > textHADV = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H HADV False 10 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd + +-- > import Graphics.SVGFonts.ReadFont +-- > textKern = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H KERN False 10 1 ) +-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd + +{- +-- | Difference between highest and lowest y-value of bounding box +bbox_dy :: RealFloat n => FontData n -> n +bbox_dy fontData = (bbox!!3) - (bbox!!1) + where bbox = fontDataBoundingBox fontData -- bbox = [lowest x, lowest y, highest x, highest y] + +-- | Lowest x-value of bounding box +bbox_lx :: RealFloat n => FontData n -> n +bbox_lx fontData = (fontDataBoundingBox fontData) !! 0 + +-- | Lowest y-value of bounding box +bbox_ly :: RealFloat n => FontData n -> n +bbox_ly fontData = (fontDataBoundingBox fontData) !! 1 + +-- | Position of the underline bar +underlinePosition :: RealFloat n => FontData n -> n +underlinePosition fontData = fontDataUnderlinePos fontData + +-- | Thickness of the underline bar +underlineThickness :: RealFloat n => FontData n -> n +underlineThickness fontData = fontDataUnderlineThickness fontData +-} +-- | A map of unicode characters to outline paths. +type OutlineMap n = H.HashMap Text (Path V2 n) + +-- | A map of unicode characters to parsing errors. +type ErrorMap = H.HashMap Text Text + +-- | A font including its outline map. +type PreparedFont b n = (FontData b n, OutlineMap n) + +-- | Compute a font's outline map, collecting errors in a second map. +outlineMap :: (Read n, Show n, RealFloat n) => + FontData b n -> (OutlineMap n, ErrorMap) +outlineMap fontData = + ( H.fromList [(ch, outl) | (ch, Right outl) <- allOutlines] + , H.fromList [(ch, err) | (ch, Left err) <- allOutlines] + ) + where + allUnicodes = H.keys (fontDataGlyphs fontData) + outlines ch = return $ mconcat $ commandsToPaths (commandsFromChar ch (fontDataGlyphs fontData)) + allOutlines = [(ch, outlines ch) | ch <- allUnicodes] + +-- | Prepare font for rendering, by determining its outline map. +prepareFont :: (Read n, Show n, RealFloat n) => + FontData b n -> (PreparedFont b n, ErrorMap) +prepareFont fontData = ((fontData, outlines), errs) + where + (outlines, errs) = outlineMap fontData + +commandsFromChar :: RealFloat n => Text -> SvgGlyphs n -> [PathCommand n] +commandsFromChar ch glyph = case H.lookup ch glyph of +-- Just e -> commands (Just $ pack $ (\(a,b,c) -> c) e) + Nothing -> [] + diff --git a/src/Diagrams/SVG/Path.hs b/src/Diagrams/SVG/Path.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/SVG/Path.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +------------------------------------------------------------------------------------- +-- Parsing the SVG path command, see +------------------------------------------------------------------------------------- + +module Diagrams.SVG.Path + ( + -- * Converting Path Commands + commandsToPaths + , splittedCommands + , outline + , nextSegment + , svgArc + -- * Parsing (Generating Path Commands) + , PathCommand(..) + , parsePathCommand + , commands + ) +where + +import Data.Attoparsec.Combinator +import Data.Attoparsec.Text +import qualified Data.Attoparsec.Text as AT +import Data.Char (isAlpha, isHexDigit, digitToInt) +import Data.Colour.Names (readColourName) +import Data.Colour.SRGB +import qualified Data.List.Split as S +import Data.List (foldl') +import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes) +import qualified Data.Text as T +import Data.Text(Text(..), pack, unpack, empty) +import Diagrams.Attributes +import Diagrams.Path +import Diagrams.Segment +import Diagrams.TwoD.Types +import Diagrams.Prelude + +data AbsRel = Abs | Rel deriving Show +data PathCommand n = + M AbsRel !(n,n) | -- ^AbsRel (x,y): Establish a new current point (with absolute coords) + Z | -- ^Close current subpath by drawing a straight line from current point to current subpath's initial point + L AbsRel !(n,n) | -- ^AbsRel (X,Y): A line from the current point to Tup which becomes the new current point + H AbsRel !n | -- ^AbsRel x: A horizontal line from the current point (cpx, cpy) to (x, cpy) + V AbsRel !n | -- ^AbsRel y: A vertical line from the current point (cpx, cpy) to (cpx, y) + C AbsRel !(n,n,n,n,n,n) | -- ^AbsRel (X1,Y1,X2,Y2,X,Y): Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the + -- ^control point at the beginning of the curve and (x2,y2) as the control point at the end of the curve. + S AbsRel !(n,n,n,n) | -- ^AbsRel (X2,Y2,X,Y): Draws a cubic Bézier curve from the current point to (x,y). The first control point is +-- assumed to be the reflection of the second control point on the previous command relative to the current point. +-- (If there is no previous command or if the previous command was not an C, c, S or s, assume the first control +-- point is coincident with the current point.) (x2,y2) is the second control point (i.e., the control point at +-- the end of the curve). + Q AbsRel !(n,n,n,n) | -- ^AbsRel (X1,Y1,X,Y): A quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point. +-- Nearly the same as cubic, but with one point less + T AbsRel !(n,n) | -- ^AbsRel (X,Y): T_Abs = Shorthand/smooth quadratic Bezier curveto + A AbsRel !(n,n,n,n,n,n,n) -- ^AbsRel (rx,ry,xAxisRot,fl0,fl1,x,y): Elliptic arc + deriving Show + + +-- | The parser to parse the lines and curves that make an outline +parsePathCommand = do { AT.skipSpace; + AT.choice [parse_m, parse_M, parse_l, parse_L, parse_h, parse_H, + parse_v, parse_V, parse_c, parse_C, parse_S, parse_s, + parse_q, parse_Q, parse_t, parse_T, parse_a, parse_A, parse_z] + } + +-- Although it makes no sense, some programs produce several M in sucession +parse_m = do { AT.string "m"; t <- many' tuple2; return (Just $ (M Rel $ head t): (map (L Rel) (tail t)) ) } -- that's why we need many' +parse_M = do { AT.string "M"; t <- many' tuple2; return (Just $ map (M Abs) t) } +parse_z = do { AT.choice [AT.string "z", AT.string "Z"]; return (Just [Z]) } +parse_l = do { AT.string "l"; t <- many' tuple2; return (Just $ map (L Rel) t) } +parse_L = do { AT.string "L"; t <- many' tuple2; return (Just $ map (L Abs) t) } +parse_h = do { AT.string "h"; t <- many' spaceDouble; return (Just $ map (H Rel) t) } +parse_H = do { AT.string "H"; t <- many' spaceDouble; return (Just $ map (H Abs) t) } +parse_v = do { AT.string "v"; t <- many' spaceDouble; return (Just $ map (V Rel) t) } +parse_V = do { AT.string "V"; t <- many' spaceDouble; return (Just $ map (V Abs) t) } +parse_c = do { AT.string "c"; t <- many' tuple6; return (Just $ map (C Rel) t) } +parse_C = do { AT.string "C"; t <- many' tuple6; return (Just $ map (C Abs) t) } +parse_s = do { AT.string "s"; t <- many' tuple4; return (Just $ map (S Rel) t) } +parse_S = do { AT.string "S"; t <- many' tuple4; return (Just $ map (S Abs) t) } +parse_q = do { AT.string "q"; t <- many' tuple4; return (Just $ map (Q Rel) t) } +parse_Q = do { AT.string "Q"; t <- many' tuple4; return (Just $ map (Q Abs) t) } +parse_t = do { AT.string "t"; t <- many' tuple2; return (Just $ map (T Rel) t) } +parse_T = do { AT.string "T"; t <- many' tuple2; return (Just $ map (T Abs) t) } +parse_a = do { AT.string "a"; t <- many' tuple7; return (Just $ map (A Rel) t) } +parse_A = do { AT.string "A"; t <- many' tuple7; return (Just $ map (A Abs) t) } + +-- | In SVG values can be separated with a "," but don't have to be +withOptional parser a = do { AT.skipSpace; + AT.choice [ do { AT.char a; b <- parser; return b}, + do { b <- parser; return b} ] } + +doubleWithOptional a = do { d <- double `withOptional` a ; return (fromRational $ toRational d) } + +spaceDouble = do { AT.skipSpace; d <- double; return (fromRational $ toRational d) } + +tuple2 = do { a <- spaceDouble; b <- doubleWithOptional ','; return (a, b) } + +tuple4 = do { a <- spaceDouble; + b <- doubleWithOptional ','; + c <- doubleWithOptional ','; + d <- doubleWithOptional ','; + return (a, b, c, d) } + +tuple6 = do { a <- spaceDouble; + b <- doubleWithOptional ','; + c <- doubleWithOptional ','; + d <- doubleWithOptional ','; + e <- doubleWithOptional ','; + f <- doubleWithOptional ','; return (a, b, c, d, e, f) } + +tuple7 = do { a <- spaceDouble; + b <- doubleWithOptional ','; + c <- doubleWithOptional ','; + d <- decimal `withOptional` ','; + e <- decimal `withOptional` ','; + f <- doubleWithOptional ','; + g <- doubleWithOptional ','; + return $ -- Debug.Trace.trace (show (a, b, c, fromIntegral d, fromIntegral e, f, g)) + (a, b, c, fromIntegral d, fromIntegral e, f, g) } + + +-- | Convert a path string into path commands +commands :: (RealFloat n, Show n) => Maybe Text -> [PathCommand n] +commands = concat . + catMaybes . + (either (const []) id) . + (AT.parseOnly (many' parsePathCommand)) . + (fromMaybe T.empty) + + +-- | Convert path commands into trails +commandsToPaths :: (RealFloat n, Show n) => [PathCommand n] -> [Path V2 n] +commandsToPaths pathCommands = map fst $ foldl' outline [] (splittedCommands pathCommands) + + +-- | split list when there is a Z(closePath) and also when there is a (M)oveto command (keep the M) +-- and merge repeated lists of single Ms into one M command +splittedCommands pathCommands = concat $ map (S.split (S.keepDelimsR (S.whenElt isZ))) $ -- a path ends with a Z + mergeMs $ -- now it is one M + S.split (S.keepDelimsL (S.whenElt isM)) -- a path starts with Ms + pathCommands + where + isM (M ar p) = True + isM _ = False + isZ Z = True + isZ _ = False + -- single Ms are a problem, because we would move something empty that we don't remember. + mergeMs :: RealFloat n => [[PathCommand n]] -> [[PathCommand n]] + mergeMs ( [M Rel (x,y)] : ( ((M Rel (x0,y0)):cs):ds ) ) = mergeMs (((M Rel (x+x0,y+y0)):cs):ds) + mergeMs ( [M Rel (x,y)] : ( ((M Abs (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x0, y0)):cs):ds) + mergeMs ( [M Abs (x,y)] : ( ((M Rel (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x+x0,y+y0)):cs):ds) + mergeMs ( [M Abs (x,y)] : ( ((M Abs (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x0, y0)):cs):ds) + mergeMs (c:cs) = c : (mergeMs cs) + mergeMs [] = [] + +data ClosedTrail a = O a | Closed a +isClosed (Closed _) = True +isClosed _ = False + +getTrail (Closed a) = a +getTrail (O a) = a + +-- | Take the endpoint of the latest path, append another path that has been generated from the path commands +-- and return this whole path +outline :: (RealFloat n, Show n) => [(Path V2 n, (n, n))] -> [PathCommand n] -> [(Path V2 n, (n, n))] +outline paths cs = paths ++ [(newPath,newPoint)] + where + newPath = translate (r2 (trx,try)) $ + pathFromTrail $ + if isClosed trail + then wrapLoop $ closeLine (mconcat (getTrail trail)) + else wrapLoop $ closeLine (mconcat (getTrail trail)) -- unfortunately this has to be closed also, + -- because some svgs fill paths that are open + + newPoint | isClosed trail = (trx, try) -- the endpoint is the old startpoint + | otherwise = startPoint + + (ctrlPoint, startPoint, trail) = foldl' nextSegment ((x,y), (x,y), O []) cs + + (trx,try) | null cs = (0,0) + | otherwise = sel2 $ nextSegment ((x,y), (x,y), O []) (head cs) -- cs usually always starts with a M-command, + -- because we splitted the commands like that + (x,y) | null paths = (0,0) + | otherwise = snd (last paths) + sel2 (a,b,c) = a + + +-- | The last control point and end point of the last path are needed to calculate the next line to append +-- endpoint -> (controlPoint, startPoint, line) -> +nextSegment :: (RealFloat n, Show n) => ((n,n), (n,n), ClosedTrail [Trail' Line V2 n]) -> PathCommand n -> ( (n,n), (n,n), ClosedTrail [Trail' Line V2 n]) +nextSegment (ctrlPoint, startPoint, O trail) Z = (ctrlPoint, startPoint, Closed trail) +nextSegment (_, _, _ ) (M Abs point) = (point, point, O []) +nextSegment (_, (x0,y0), _ ) (M Rel (x,y)) = ((x+x0, y+y0), (x+x0, y+y0), O []) +nextSegment (_, (x0,y0), O trail) (L Abs (x,y)) = ((x, y ), (x, y ), O $ trail ++ [straight' (x-x0, y-y0)]) +nextSegment (_, (x0,y0), O trail) (L Rel (x,y)) = ((x+x0, y+y0), (x+x0, y+y0), O $ trail ++ [straight' (x, y )]) +nextSegment (_, (x0,y0), O trail) (H Abs x) = ((x, y0), (x, y0), O $ trail ++ [straight' (x-x0, 0)]) +nextSegment (_, (x0,y0), O trail) (H Rel x) = ((x+x0, y0), (x+x0, y0), O $ trail ++ [straight' (x, 0)]) +nextSegment (_, (x0,y0), O trail) (V Abs y) = (( x0, y ), ( x0, y ), O $ trail ++ [straight' (0 , y-y0)]) +nextSegment (_, (x0,y0), O trail) (V Rel y) = (( x0, y+y0), ( x0, y+y0), O $ trail ++ [straight' (0, y )]) + +nextSegment (_, (x0,y0), O trail) (C Abs (x1,y1,x2,y2,x,y)) = ((x2,y2), (x,y), O $ trail ++ [bez3 (x1-x0, y1-y0) (x2-x0, y2-y0) (x-x0,y-y0)]) +nextSegment (_, (x0,y0), O trail) (C Rel (x1,y1,x2,y2,x,y)) = ((x2+x0, y2+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x1, y1) (x2, y2) (x,y)]) + +nextSegment ((cx,cy),(x0,y0), O trail) (S Abs (x2,y2,x,y)) = ((x2, y2), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x2-x0, y2-y0) (x-x0, y-y0)]) +nextSegment ((cx,cy),(x0,y0), O trail) (S Rel (x2,y2,x,y)) = ((x2+x0, y2+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x0-cx, y0-cy) (x2, y2) (x, y)]) + +nextSegment (_, (x0,y0), O trail) (Q Abs (x1,y1,x,y)) = ((x1, y1), (x, y), O $ trail ++ [bez3 (x1-x0, y1-y0) (x-x0, y-y0) (x-x0, y-y0)]) +nextSegment (_, (x0,y0), O trail) (Q Rel (x1,y1,x,y)) = ((x1+x0, y1+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x1, y1) (x, y) (x, y)]) + +nextSegment ((cx,cy), (x0,y0), O trail) (T Abs (x,y)) = ((2*x0-cx, 2*y0-cy ), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x-x0, y-y0) (x-x0, y-y0)]) +nextSegment ((cx,cy), (x0,y0), O trail) (T Rel (x,y)) = ((2*x0-cx, 2*y0-cy), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x, y) (x, y)]) + +nextSegment (_, (x0,y0), O trail) (A Abs (rx,ry,xAxisRot,fl0,fl1,x,y) ) = (nul, nul, O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)]) +nextSegment (_, (x0,y0), O trail) (A Rel (rx,ry,xAxisRot,fl0,fl1,x,y) ) = (nul, nul, O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)]) + +nul = (0,0) + +straight' = lineFromSegments . (:[]) . straight . r2 + +bez3 point1 point2 point3 = lineFromSegments [bezier3 (r2 point1) (r2 point2) (r2 point3)] + +-- | The arc command: see +-- To Do: scale if rx,ry,xAxisRot are such that there is no solution +svgArc :: (RealFloat n, Show n) => (n, n) -> n -> n -> n -> (n,n) -> Trail' Line V2 n +svgArc (rxx, ryy) xAxisRot largeArcFlag sweepFlag (x2, y2) + | x2 == 0 && y2 == 0 = emptyLine -- spec F6.2 + | rx == 0 || ry == 0 = straight' (x2,y2) -- spec F6.2 + | otherwise = -- Debug.Trace.trace (show (dtheta) ++ show dir1) $ + unLoc (arc' 1 dir1 (dtheta @@ rad) # scaleY ry # scaleX rx # rotate (phi @@ rad)) + where rx | rxx < 0 = -rxx -- spec F6.2 + | otherwise = rxx + ry | ryy < 0 = -ryy -- spec F6.2 + | otherwise = ryy + fa | largeArcFlag == 0 = 0 + | otherwise = 1 -- spec F6.2 + fs | sweepFlag == 0 = 0 + | otherwise = 1 -- spec F6.2 + phi = xAxisRot * pi / 180 + (x1,y1) = (0,0) + x1x2 = (x1 - x2)/2 + y1y2 = (y1 - y2)/2 + x1' = (cos phi) * x1x2 + (sin phi) * y1y2 + y1' = -(sin phi) * x1x2 + (cos phi) * y1y2 + s = (rx*rx*ry*ry - rx*rx*y1'*y1' - ry*ry*x1'*x1') / (rx*rx*y1'*y1' + ry*ry*x1'*x1' ) + root | s <= 0 = 0 -- Should only happen because of rounding errors, s usually being very close to 0 + | otherwise = sqrt s -- This bug happened: + cx' | fa /= fs = root * rx * y1' / ry + | otherwise = - root * rx * y1' / ry + cy' | fa /= fs = - root * ry * x1' / rx + | otherwise = root * ry * x1' / rx + cx = (cos phi) * cx' - (sin phi) * cy' + ((x1+x2)/2) + cy = (sin phi) * cx' + (cos phi) * cy' + ((y1+y2)/2) + dir1 = dirBetween (p2 ((x1'-cx')/rx, (y1'-cy')/ry)) origin + v1 = r2 (( x1'-cx')/rx, (y1'-cy')/ry) + v2 = r2 ((-x1'-cx')/rx, (-y1'-cy')/ry) + -- angleV1V2 is unfortunately necessary probably because of something like + angleV1V2 | (signorm v1 `dot` signorm v2) >= 1 = (acosA 1 ) ^. rad + | (signorm v1 `dot` signorm v2) <= -1 = (acosA (-1)) ^. rad + | otherwise = (signedAngleBetween v2 v1) ^. rad + dtheta | fs == 0 = if angleV1V2 > 0 then angleV1V2 - (2*pi) else angleV1V2 + | otherwise = if angleV1V2 < 0 then angleV1V2 + (2*pi) else angleV1V2 + diff --git a/src/Diagrams/SVG/ReadSVG.hs b/src/Diagrams/SVG/ReadSVG.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/SVG/ReadSVG.hs @@ -0,0 +1,1036 @@ +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GADTs, + MultiParamTypeClasses, NoMonomorphismRestriction, OverloadedStrings, TypeFamilies, UndecidableInstances #-} + +------------------------------------------------------------------- +-- | +-- Module : Diagrams.SVG.ReadSVG +-- Copyright : (c) 2015 Tillmann Vogt +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Maintainer : diagrams-discuss@googlegroups.com +-- Stability : stable +-- Portability: portable + +------------------------------------------------------------------- + +module Diagrams.SVG.ReadSVG + ( + -- * Main functions + readSVGFile + , preserveAspectRatio + , nodes + , insertRefs + , PreserveAR(..) + , AlignSVG(..) + , Place(..) + , MeetOrSlice(..) + , InputConstraints(..) + -- * Parsing of basic structure tags + , parseSVG + , parseG + , parseDefs + , parseSymbol + , parseUse + , parseSwitch + , parseDesc + , parseTitle +-- , parseMetaData + -- * Parsing of basic shape tags + , parseRect + , parseCircle + , parseEllipse + , parseLine + , parsePolyLine + , parsePolygon + , parsePath + -- * Parsing of Gradient tags + , parseLinearGradient + , parseRadialGradient + , parseSet + , parseStop + -- * Parsing of other tags + , parseClipPath + , parsePattern + , parseFilter + , parseImage + , parseText + -- * Parsing data uri in + , dataUriToImage + ) where + +import Codec.Picture +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Control.Monad.Trans.Class +import Data.Either.Combinators +import qualified Data.Attoparsec.Text as AT +import qualified Data.Attoparsec.ByteString as ABS +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as Base64 +import Data.Conduit +import qualified Data.Conduit.List as CL +import qualified Data.Colour +import qualified Data.Conduit.List as C +import qualified Data.HashMap.Strict as H +import Data.Maybe (fromJust, fromMaybe, isJust) +import qualified Data.Text as T +import Data.Text(Text(..)) +import Data.Text.Encoding +import Data.Typeable (Typeable) +import Data.XML.Types +import Diagrams.Attributes +import Diagrams.Prelude +import Diagrams.TwoD.Ellipse +import Diagrams.TwoD.Path (isInsideEvenOdd) +import Diagrams.TwoD.Size +import Diagrams.TwoD.Types +import qualified Diagrams.TwoD.Text as TT +import Diagrams.SVG.Arguments +import Diagrams.SVG.Attributes +import Diagrams.SVG.Fonts.ReadFont +import Diagrams.SVG.Path (commands, commandsToPaths, PathCommand(..)) +import Diagrams.SVG.Tree +import Filesystem.Path (FilePath(..), extension) +import Filesystem.Path.CurrentOS (encodeString) +import Prelude hiding (FilePath) +import Text.XML.Stream.Parse hiding (parseText) +import Text.CSS.Parse (parseBlocks) + +import Debug.Trace +-------------------------------------------------------------------------------------- +-- | Main library function +-- +-- @ +-- \{-\# LANGUAGE OverloadedStrings \#-\} +-- +-- module Main where +-- import Diagrams.SVG.ReadSVG +-- import Diagrams.Prelude +-- import Diagrams.Backend.SVG.CmdLine +-- import System.Environment +-- import Filesystem.Path.CurrentOS +-- import Diagrams.SVG.Attributes (PreserveAR(..), AlignSVG(..), Place(..), MeetOrSlice(..)) +-- +-- main = do +-- diagramFromSVG <- readSVGFile \"svgs/web.svg\" +-- mainWith $ diagramFromSVG +-- @ +-- +readSVGFile :: (V b ~ V2, N b ~ n, RealFloat n, Renderable (Path V2 n) b, Renderable (DImage n Embedded) b, -- TODO upper example + Typeable b, Typeable n, Show n, Read n, n ~ Place, Renderable (TT.Text n) b) + => Filesystem.Path.FilePath -> IO (Either String (Diagram b)) +readSVGFile fp = if (extension fp) /= (Just "svg") then return $ Left "Not a svg file" else -- TODO All exceptions into left values + runResourceT $ do tree <- parseFile def (encodeString fp) $$ force "error in parseSVG" parseSVG + return (Right (diagram tree)) + +diagram :: (RealFloat n, V b ~ V2, n ~ N b, Typeable n, Read n, n ~ Place) => Tag b n -> Diagram b +diagram tr = (insertRefs ((nmap,cssmap,expandedGradMap),(0,0,100,100)) tr) # scaleY (-1) # initialStyles + where + (ns,css,grad,fonts) = nodes Nothing ([],[],[], []) tr + nmap = H.fromList ns -- needed because of the use-tag and clipPath + cssmap = H.fromList css -- CSS inside the tag + gradmap = H.fromList grad + expandedGradMap = expandGradMap gradmap + + +-- | Read font data from font file, and compute its outline map. +-- +{- +loadFont :: (Read n, RealFloat n) => FilePath -> IO (Either String (PreparedFont n)) +loadFont filename = if (extension fp) /= (Just "svg") then return $ Left "Not a svg file" else -- TODO All exceptions into left values + runResourceT $ runEitherT $ do + tree <- lift (parseFile def fp $$ force "error in parseSVG" parseSVG) + let fontData = font tree + case fontData of Left s -> return (Left s) + Right s -> do let (font, errs) = prepareFont fontData + sequence_ [ putStrLn ("error parsing character '" ++ ch ++ "': " ++ err) + | (ch, err) <- Map.toList errs + ] + return font + +font tr = fonts + where (ns,css,grad,fonts) = nodes Nothing ([],[],[], []) tr +-} +------------------------------------------------------------------------------------- +-- Basic SVG structure + +tagName name = tag' (Text.XML.Stream.Parse.matching (== name)) + +class (V b ~ V2, N b ~ n, RealFloat n, Renderable (Path V2 n) b, Typeable n, Typeable b, Show n, + Renderable (DImage n Embedded) b) => InputConstraints b n + +instance (V b ~ V2, N b ~ n, RealFloat n, Renderable (Path V2 n) b, Typeable n, Typeable b, Show n, + Renderable (DImage n Embedded) b) => InputConstraints b n + +-- | Parse \, see +parseSVG :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Sink Event m (Maybe (Tag b n)) +parseSVG = tagName "{http://www.w3.org/2000/svg}svg" svgAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,x,y,w,h,vb,ar,zp,ver,baseprof,cScripT,cStyleT,xmlns,xml) -> + do gs <- many gContent + let st hmaps = (parseStyles style hmaps) ++ -- parse the style attribute (style="stop-color:#000000;stop-opacity:0.8") + (parsePA pa hmaps) ++ -- presentation attributes: stop-color="#000000" stop-opacity="0.8" + (cssStylesFromMap hmaps "svg" (id1 ca) class_) + let pw = if (isJust w) then parseDouble $ fromJust w else 0 + let ph = if (isJust h) then parseDouble $ fromJust h else 0 + return $ -- Debug.Trace.trace ("@" ++ show vb ++ show (parseViewBox vb w h)) ( + SubTree True (id1 ca) + (pw,ph) + (parseViewBox vb w h) + (parsePreserveAR ar) + (applyStyleSVG st) + (reverse gs) + +svgContent :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Consumer Event m (Maybe (Tag b n)) +svgContent = choose -- the likely most common are checked first + [parseG, parsePath, parseCircle, parseRect, parseEllipse, parseLine, parsePolyLine, parsePolygon, + parseDefs, parseSymbol, parseUse, -- structural elements + parseClipPath, parsePattern, parseImage, parseText, -- parseSwitch, parseSodipodi, + skipArbitraryTag] -- should always be last! + -- parseDesc, parseMetaData, parseTitle] -- descriptive Elements + +--------------------------------------------------------------------------- +-- | Parse \, see +parseG :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Consumer Event m (Maybe (Tag b n)) +parseG = tagName "{http://www.w3.org/2000/svg}g" gAttrs + $ \(cpa,ca,gea,pa,class_,style,ext,tr) -> + do insideGs <- many gContent + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "g" (id1 ca) class_) + return $ SubTree True (id1 ca) + (0, 0) + Nothing + Nothing + (\maps -> (applyStyleSVG st maps) . (applyTr (parseTr tr)) ) + (reverse insideGs) + +gContent :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (Tag b n)) +gContent = choose -- the likely most common are checked first + [parsePath, parseG, parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePolygon, + parseUse, parseSymbol, parseStyle, parseDefs, -- structural elements + parseClipPath, parseLinearGradient, parseRadialGradient, parseImage, parseText, -- parseFont, + skipArbitraryTag] -- -- should always be last! +-- parseFilter, parsePattern, parseSwitch, parsePerspective, +-- parseDesc, parseMetaData, parseTitle, parsePathEffect] -- descriptive Elements + +--------------------------------------------------------------------------- +-- | Parse \, see +parseDefs :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Consumer Event m (Maybe (Tag b n)) +parseDefs = tagName "{http://www.w3.org/2000/svg}defs" gAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,tr) -> + do insideDefs <- many gContent + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "defs" (id1 ca) class_) + return $ SubTree False (id1 ca) + (0, 0) + Nothing + Nothing + ( (applyTr (parseTr tr)) . (applyStyleSVG st) ) + (reverse insideDefs) + +--------------------------------------------------------------------------- +-- | Parse \, see +-- e.g. +-- +parseStyle :: (MonadThrow m, RealFloat n) => Consumer Event m (Maybe (Tag b n)) +parseStyle = tagName "{http://www.w3.org/2000/svg}style" sAttrs $ + \(ca,type_,media,title) -> + do insideStyle <- content + let blocks = parseBlocks insideStyle -- parseBlocks :: Text -> Either String [CssBlock] + let cssBlocks = case blocks of + Left err -> [] + Right st -> st + return $ StyleTag cssBlocks -- type CssBlock = (Text, [(Text, Text)]) = (selector, [(attribute, value)]) + +----------------------------------------------------------------------------------- +-- | Parse \, see +parseSymbol :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Consumer Event m (Maybe (Tag b n)) +parseSymbol = tagName "{http://www.w3.org/2000/svg}symbol" symbolAttrs $ + \(ca,gea,pa,class_,style,ext,ar,viewbox) -> + do insideSym <- many gContent + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "symbol" (id1 ca) class_) + return $ SubTree False (id1 ca) + (0, 0) + (parseViewBox viewbox Nothing Nothing) + (parsePreserveAR ar) + (applyStyleSVG st) + (reverse insideSym) + +----------------------------------------------------------------------------------- +-- | Parse \, see +parseUse :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Typeable n) => Consumer Event m (Maybe (Tag b n)) +parseUse = tagName "{http://www.w3.org/2000/svg}use" useAttrs + $ \(ca,cpa,gea,pa,xlink,class_,style,ext,tr,x,y,w,h) -> + do -- insideUse <- many useContent + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "use" (id1 ca) class_) + let path (minx,miny,vbW,vbH) = rect (p (minx,vbW) 0 w) (p (miny,vbH) 0 h) + return $ Reference (id1 ca) + (Diagrams.SVG.Attributes.fragment $ xlinkHref xlink) + path + (f tr x y st) -- f gets supplied with the missing maps an viewbox when evaluating the Tag-tree + where -- f :: Maybe Text -> Maybe Text -> Maybe Text -> (HashMaps b n -> [SVGStyle n a]) + -- -> (HashMaps b n, (n,n,n,n)) -> Diagram b -> Diagram b + f tr x y st (maps,(minx,miny,vbW,vbH)) = (translate (r2 (p (vbW, minx) 0 x, + p (vbH, miny) 0 y))) . + (applyTr (parseTr tr)) . (applyStyleSVG st maps) + +useContent :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n)) +useContent = choose [parseDesc,parseTitle] -- descriptive elements + +-------------------------------------------------------------------------------------- +-- | Parse \, see +parseSwitch :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n)) +parseSwitch = tagName "{http://www.w3.org/2000/svg}switch" switchAttrs + $ \(cpa,ca,gea,pa,class_,style,ext,tr) -> + do -- insideSwitch <- many switchContent + return $ Leaf (id1 ca) mempty mempty + +-- switchContent :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n)) +switchContent = choose [parsePath, parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePolygon] + +----------------------------------------------------------------------------------- +-- | Parse \, see +parseRect :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n)) +parseRect = tagName "{http://www.w3.org/2000/svg}rect" rectAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,ar,tr,x,y,w,h,rx,ry) -> do + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "rect" (id1 ca) class_) + let rRect pw ph prx pry | prx == 0 && pry == 0 = rect pw ph + | otherwise = roundedRect pw ph (if prx == 0 then pry else prx) + let path (minx,miny,vbW,vbH) = (rRect (p (minx,vbW) 0 w) (p (miny,vbH) 0 h) + (p (minx,vbW) 0 rx) (p (miny,vbH) 0 ry)) + # alignBL + # applyTr (parseTr tr) + # translate (r2 (p (minx,vbW) 0 x, p (miny,vbH) 0 y)) + let f (maps,viewbox) = path viewbox # stroke # applyStyleSVG st maps + return $ Leaf (id1 ca) path f + +--------------------------------------------------------------------------------------------------- +-- | Parse \, see +parseCircle :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n)) +parseCircle = tagName "{http://www.w3.org/2000/svg}circle" circleAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,tr,r,cx,cy) -> do + let -- st :: (RealFloat n, RealFloat a, Read a) => (HashMaps b n, ViewBox n) -> [SVGStyle n a] + st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "circle" (id1 ca) class_) + let path (minx,miny,w,h) = circle (p (minx,w) 0 r) -- TODO: radius of a circle in percentages (relative to x?) + # applyTr (parseTr tr) + # translate (r2 (p (minx,w) 0 cx, p (miny,h) 0 cy)) + let f (maps,viewbox) = path viewbox # stroke # applyStyleSVG st maps + return $ Leaf (id1 ca) path f + +--------------------------------------------------------------------------------------------------- +-- | Parse \, see +parseEllipse :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n)) +parseEllipse = tagName "{http://www.w3.org/2000/svg}ellipse" ellipseAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,tr,rx,ry,cx,cy) -> do + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "ellipse" (id1 ca) class_) + let path (minx,miny,w,h) = ((ellipseXY (p (minx,w) 0 rx) (p (miny,h) 0 ry) )) + # applyTr (parseTr tr) + # translate (r2 (p (minx,w) 0 cx, p (miny,h) 0 cy)) + let f (maps,viewbox) = path viewbox # stroke # applyStyleSVG st maps + return $ Leaf (id1 ca) path f + +--------------------------------------------------------------------------------------------------- +-- | Parse \, see +parseLine :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n)) +parseLine = tagName "{http://www.w3.org/2000/svg}line" lineAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,tr,x1,y1,x2,y2) -> do + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "line" (id1 ca) class_) + let path (minx,miny,w,h) = (fromSegments [ straight (r2 ((p (minx,w) 0 x2) - (p (minx,w) 0 x1), + (p (miny,h) 0 y2) - (p (miny,h) 0 y1))) ]) + # applyTr (parseTr tr) + # translate (r2 (p (minx,w) 0 x1, p (miny,h) 0 y1)) + let f (maps,viewbox) = path viewbox # stroke + # applyStyleSVG st maps + return $ Leaf (id1 ca) path f + +--------------------------------------------------------------------------------------------------- +-- | Parse \, see +parsePolyLine :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n)) +parsePolyLine = tagName "{http://www.w3.org/2000/svg}polyline" polygonAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,tr,points) -> do + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "polyline" (id1 ca) class_) + let ps = parsePoints (fromJust points) + let path viewbox = fromVertices (map p2 ps) # translate (r2 (head ps)) + # applyTr (parseTr tr) + + let f (maps,viewbox) = fromVertices (map p2 ps) # strokeLine + # translate (r2 (head ps)) + # applyTr (parseTr tr) + # applyStyleSVG st maps + return $ Leaf (id1 ca) path f + +-------------------------------------------------------------------------------------------------- +-- | Parse \, see +parsePolygon :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n)) +parsePolygon = tagName "{http://www.w3.org/2000/svg}polygon" polygonAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,tr,points) -> do + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "polygon" (id1 ca) class_) + let ps = parsePoints (fromJust points) + let path viewbox = fromVertices (map p2 ps) # translate (r2 (head ps)) + # applyTr (parseTr tr) + let f (maps,viewbox) = fromVertices (map p2 ps) # closeLine + # strokeLoop + # translate (r2 (head ps)) + # applyTr (parseTr tr) + # applyStyleSVG st maps + return $ Leaf (id1 ca) path f + +-------------------------------------------------------------------------------------------------- +-- | Parse \, see +parsePath :: (MonadThrow m, InputConstraints b n, Show n) => Consumer Event m (Maybe (Tag b n)) +parsePath = tagName "{http://www.w3.org/2000/svg}path" pathAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,tr,d,pathLength) -> do + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "path" (id1 ca) class_) + let path viewbox = (mconcat $ commandsToPaths $ commands d) # applyTr (parseTr tr) + let f (maps,viewbox) = path viewbox # strokePath + # applyStyleSVG st maps + return $ Leaf (id1 ca) path f + +------------------------------------------------------------------------------------------------- +-- | Parse \, see +parseClipPath :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (Tag b n)) +parseClipPath = tagName "{http://www.w3.org/2000/svg}clipPath" clipPathAttrs $ + \(cpa,ca,pa,class_,style,ext,ar,viewbox) -> do + insideClipPath <- many clipPathContent + let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "clipPath" (id1 ca) class_) + return $ SubTree False (id1 ca) + (0, 0) + (parseViewBox viewbox Nothing Nothing) + (parsePreserveAR ar) + (applyStyleSVG st) + (reverse insideClipPath) + +clipPathContent :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (Tag b n)) +clipPathContent = choose [parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePath, + parsePolygon, parseText, parseUse] + +-------------------------------------------------------------------------------------- +-- | Parse \, see +-- +parseImage :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Renderable (DImage (N b) Embedded) b, + Typeable b, Typeable n) => Consumer Event m (Maybe (Tag b n)) +parseImage = tagName "{http://www.w3.org/2000/svg}image" imageAttrs $ + \(ca,cpa,gea,xlink,pa,class_,style,ext,ar,tr,x,y,w,h) -> + do return $ Leaf (id1 ca) mempty (\(_,(minx,miny,vbW,vbH)) -> (dataUriToImage (xlinkHref xlink) (p (minx,vbW) 0 w) (p (miny,vbH) 0 h)) + # alignBL + # applyTr (parseTr tr) + # translate (r2 (p (minx,vbW) 0 x, p (miny,vbH) 0 y))) +-- TODO aspect ratio + +data ImageType = JPG | PNG | SVG + +--------------------------------------------------------------------------------------------------- +-- | Convert base64 encoded data in to a Diagram b with JuicyPixels +-- input: "data:image/png;base64,..." +dataUriToImage :: (Metric (V b), Ord n, RealFloat n, N b ~ n, V2 ~ V b, Renderable (DImage n Embedded) b, + Typeable b, Typeable n) => Maybe Text -> n -> n -> Diagram b +dataUriToImage _ 0 h = mempty +dataUriToImage _ w 0 = mempty +dataUriToImage Nothing w h = mempty +dataUriToImage (Just text) w h = either (const mempty) id $ ABS.parseOnly dataUri (encodeUtf8 text) + where + jpg = do { ABS.string "jpg"; return JPG } -- ABS = Data.Attoparsec.ByteString + png = do { ABS.string "png"; return PNG } + svg = do { ABS.string "svg"; return SVG } + + dataUri = do + ABS.string "data:image/" + imageType <- ABS.choice [jpg, png, svg] + ABS.string ";base64," -- assuming currently that this is always used + base64data <- ABS.many1 ABS.anyWord8 + return $ case im imageType (B.pack base64data) of + Right img -> image (DImage (ImageRaster img) (round w) (round h) mempty) + Left x -> mempty + +im :: ImageType -> B.ByteString -> Either String DynamicImage +im imageType base64data = case Base64.decode base64data of + Left _ -> Left "diagrams-input: Error decoding data uri in -tag" + Right b64 -> case imageType of + JPG -> decodeJpeg b64 -- decodeJpeg :: ByteString -> Either String DynamicImage + PNG -> decodePng b64 + -- SVG -> preserveAspectRatio w h oldWidth oldHeight ar (readSVGBytes base64data) -- something like that + _ -> Left "diagrams-input: format not supported in -tag" + +------------------------------------------------------------------------------------------------- +-- | Parse \, see +parseText :: (MonadThrow m, InputConstraints b n, Read n, RealFloat n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (Tag b n)) +parseText = tagName "{http://www.w3.org/2000/svg}text" textAttrs $ + \(cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) -> + do let st hmaps = (parseStyles style hmaps) ++ + (parsePA pa hmaps) ++ + (cssStylesFromMap hmaps "text" (id1 ca) class_) + insideText <- many (tContent (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen)) + return $ SubTree True (id1 ca) + (0, 0) + Nothing + Nothing + (\maps -> applyStyleSVG st maps) + insideText + +tContent (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) + = choose + [ parseTSpan (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen), + textContent (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) ] + + +{- +-- text related data of pa (presentation attribute) + +alignmentBaseline baselineShift dominantBaseline fontFamily +fntSize fontSizeAdjust fontStretch fontStyle fontVariant fontWeight +glyphOrientationHorizontal glyphOrientationVertical kerning letterSpacing +textAnchor textDecoration textRendering wordSpacing writingMode +-} + +-- | Parse a string between the text tags: \Hello\ +textContent :: (MonadThrow m, InputConstraints b n, RealFloat n, Read n, Renderable (TT.Text n) b) => + (ConditionalProcessingAttributes, + CoreAttributes, + GraphicalEventAttributes, + PresentationAttributes, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text) -> ConduitM Event o m (Maybe (Tag b n)) +textContent (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) = + do t <- contentMaybe + let st :: (Read a, RealFloat a, RealFloat n) => (HashMaps b n, ViewBox n) -> [(SVGStyle n a)] + st (hmaps,_) = (parseStyles style hmaps) ++ + (parsePA pa hmaps) + + let f :: (V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable n, Renderable (TT.Text n) b) + => (HashMaps b n, ViewBox n) -> Diagram b + f (maps,(minx,miny,w,h)) = anchorText pa (maybe "" T.unpack t) + -- fontWeight + # scaleY (-1) + # translate (r2 (p (minx,w) 0 x, p (miny,h) 0 y)) + # (applyTr (parseTr tr)) + # applyStyleSVG st (maps,(minx,miny,w,h)) + # maybe id (fontSize . local . read . T.unpack) (fntSize pa) + # maybe id (font . T.unpack) (fontFamily pa) + + return (if isJust t then Just $ Leaf (id1 ca) mempty f + else Nothing) + + +{- -} + +------------------------------------------------------------------------------------------------- +-- | Parse \, see +parseTSpan :: (MonadThrow m, InputConstraints b n, RealFloat n, Read n, Renderable (TT.Text n) b) => + (ConditionalProcessingAttributes, + CoreAttributes, + GraphicalEventAttributes, + PresentationAttributes, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text, + Maybe Text) -> ConduitM Event o m (Maybe (Tag b n)) +parseTSpan (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) = tagName "{http://www.w3.org/2000/svg}tspan" tspanAttrs $ + \(cpa1,ca1,gea1,pa1,class1,style1,ext1,x1,y1,dx1,dy1,rot1,textlen1,lAdjust1,role) -> + do t <- contentMaybe + let st :: (Read a, RealFloat a, RealFloat n) => (HashMaps b n, ViewBox n) -> [(SVGStyle n a)] + st (hmaps,_) = (parseStyles style hmaps) ++ + (parseStyles style1 hmaps) ++ + (parsePA pa hmaps) ++ + (parsePA pa1 hmaps) ++ + (cssStylesFromMap hmaps "tspan" (id1 ca) class_) + + let f :: (V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable n, Renderable (TT.Text n) b) + => (HashMaps b n, ViewBox n) -> Diagram b + f (maps,(minx,miny,w,h)) = anchorText pa (maybe "" T.unpack t) + # maybe id (fontSize . local . read . T.unpack) (pref (fntSize pa1) (fntSize pa)) + # maybe id (font . T.unpack) (pref (fontFamily pa1) (fontFamily pa)) + -- fontWeight + # scaleY (-1) + # translate (r2 (p (minx,w) 0 (pref x1 x), p (miny,h) 0 (pref y1 y))) + # (applyTr (parseTr tr)) + # applyStyleSVG st (maps,(minx,miny,w,h)) + return $ Leaf (id1 ca) mempty f + + +anchorText :: (V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable n, Renderable (TT.Text n) b) + => PresentationAttributes -> String -> QDiagram b V2 n Any +anchorText pa txt = case anchor pa of + "start" -> baselineText txt + "middle" -> text txt + "end" -> alignedText 1 0 txt -- TODO is this correct? + "inherit" -> text txt -- TODO + where + anchor pa = maybe "start" T.unpack (textAnchor pa) -- see + + +pref :: Maybe a -> Maybe a -> Maybe a +pref (Just x) b = Just x +pref Nothing (Just y) = Just y +pref Nothing Nothing = Nothing + + +-------------------------------------------------------------------------------------- +-- Gradients +------------------------------------------------------------------------------------- + +-- | Parse \, see +-- example: +parseLinearGradient :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n)) +parseLinearGradient = tagName "{http://www.w3.org/2000/svg}linearGradient" linearGradAttrs $ + \(ca,pa,xlink,class_,style,ext,x1,y1,x2,y2,gradientUnits,gradientTransform,spreadMethod) -> -- TODO gradientUnits + do gs <- many gradientContent + let stops = map getTexture $ concat $ map extractStops gs + + -- because of href we have to replace Nothing-attributes by attributes of referenced gradients + -- see + let attributes = GA pa class_ style x1 y1 x2 y2 Nothing Nothing Nothing Nothing Nothing gradientUnits gradientTransform spreadMethod + + -- stops are lists of functions and everyone of these gets passed the same cssmap + -- and puts them into a Grad constructor + let f css attributes (minx,miny,w,h) stops = + over (_LG . lGradTrans) (applyTr (parseTr gradientTransform)) + (mkLinearGradient (concat (map ($ css) stops)) -- (minx,miny,w,h) is the viewbox + ((p (minx,w) 0 x1) ^& (p (miny,h) 0 y1)) + ((p (minx,w) 0 x2) ^& (p (miny,h) 0 y2)) + (parseSpread spreadMethod)) + return $ Grad (id1 ca) (Gr (Diagrams.SVG.Attributes.fragment $ xlinkHref xlink) attributes Nothing stops f) + +gradientContent = choose [parseStop, parseMidPointStop] -- parseSet, + -- parseDesc, parseMetaData, parseTitle] -- descriptive Elements (rarely used here, so tested at the end) + +-- | Parse \, see +parseRadialGradient :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n)) +parseRadialGradient = tagName "{http://www.w3.org/2000/svg}radialGradient" radialGradAttrs $ -- TODO gradientUnits + \(ca,pa,xlink,class_,style,ext,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod) -> + do gs <- many gradientContent + let stops = map getTexture $ concat $ map extractStops gs + + -- because of href we have to replace Nothing-attributes by attributes of referenced gradients + -- see + let attributes = GA pa class_ style Nothing Nothing Nothing Nothing cx cy r fx fy gradientUnits gradientTransform spreadMethod + + let f css attributes (minx,miny,w,h) stops = + over (_RG . rGradTrans) (applyTr (parseTr gradientTransform)) + (mkRadialGradient (concat (map ($ css) stops)) + ((p (minx,w) (p (minx,w) 0 cx) fx) ^& -- focal point fx is set to cx if fx does not exist + (p (miny,h) (p (miny,h) 0 cy) fy)) + 0 + ((p (minx,w) 0 cx) ^& + (p (miny,h) 0 cy)) + (p (minx,w) (0.5*(w-minx)) r) --TODO radius percentage relative to x or y? + (parseSpread spreadMethod)) + return $ Grad (id1 ca) (Gr (Diagrams.SVG.Attributes.fragment $ xlinkHref xlink) attributes Nothing stops f) + +extractStops (SubTree b id1 wh viewBox ar f children) = concat (map extractStops children) +extractStops (Stop stops) = [Stop stops] +extractStops _ = [] + +getTexture :: (RealFloat n) => Tag b n -> (CSSMap -> [GradientStop n]) +getTexture (Stop stops) = stops . (\css -> (H.empty, css, H.empty)) + +-- | Parse \, see +parseSet = tagName "{http://www.w3.org/2000/svg}set" setAttrs $ + \(ca,pa,xlink) -> + do return $ Leaf (id1 ca) mempty mempty -- "set" ignored so far + +-- | Parse \, see +-- e.g. +parseStop = tagName "{http://www.w3.org/2000/svg}stop" stopAttrs $ + \(ca,pa,xlink,class_,style,offset) -> + do let st hmaps = (parseStyles style empty3) ++ + (parsePA pa empty3) ++ + (cssStylesFromMap hmaps "stop" (id1 ca) class_) + return $ Stop (\hmaps -> mkStops [getStopTriple (p (0,1) 0 offset) (st hmaps)]) + +parseMidPointStop = tagName "{http://www.w3.org/2000/svg}midPointStop" stopAttrs $ + \(ca,pa,xlink,class_,style,offset) -> + do let st hmaps = (parseStyles style empty3) ++ + (parsePA pa empty3) ++ + (cssStylesFromMap hmaps "midPointStop" (id1 ca) class_) + return $ Stop (\hmaps -> mkStops [getStopTriple (p (0,1) 0 offset) (st hmaps)]) + +empty3 = (H.empty,H.empty,H.empty) + +getStopTriple offset styles = (col colors, offset, opacity opacities) + where col ((Fill c):_) = fromAlphaColour c + col _ = white + opacity ((FillOpacity x):_) = x + opacity _ = 1 + colors = Prelude.filter isFill styles + opacities = Prelude.filter isOpacity styles + +isFill (Fill _) = True +isFill _ = False + +isOpacity (FillOpacity _) = True +isOpacity _ = False + +---------------------------------------------------------------------------------------------------- +-- Fonts +---------------------------------------------------------------------------------------------------- + +parseFont :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Renderable (DImage (N b) Embedded) b, Renderable (Path V2 n) b, + Typeable b, Typeable n, Show n, Read n, Renderable (TT.Text n) b) => Consumer Event m (Maybe (Tag b n)) +parseFont = tagName "{http://www.w3.org/2000/svg}font" fontAttrs $ + \(ca,pa,class_,style,ext,hOriginX,hOriginY,hAdvX,vOriginX,vOriginY,vAdvY) -> + do gs <- many fontContent + return $ FontTag $ FontData (id1 ca) hOriginX hOriginY (getN hAdvX) vOriginX vOriginY vAdvY + (fontf gs) (missingGlyph gs) (glyphs gs) (kernMap (kerns gs)) + where fontf gs = (\(FF f) -> f) $ head $ Prelude.filter isFontFace gs + missingGlyph gs = (\(GG g) -> g) $ head $ Prelude.filter isMissingGlyph gs + glyphs gs = H.fromList $ map toSvgGlyph (Prelude.filter isGlyph gs) + kerns gs = map (\(KK k) -> k) (Prelude.filter isKern gs) + + isGlyph (GG (Glyph glyphId g d _ _ _ _ unicode glyphName o a l)) = not (maybe False T.null unicode) || + not (maybe False T.null glyphName) + isGlyph _ = False + isMissingGlyph (GG (Glyph glyphId g d _ _ _ _ unicode glyphName o a l)) = (maybe False T.null unicode) && + (maybe False T.null glyphName) + isMissingGlyph _ = False + isKern (KK k) = True + isKern _ = False + isFontFace (FF f) = True + isFontFace _ = False + toSvgGlyph (GG (Glyph glyphId g d horizAdvX _ _ _ (Just unicode) glyphName o a l)) = (unicode,(glyphName,horizAdvX,d)) + +fontContent :: (MonadThrow m, InputConstraints b n, Read n, Show n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (FontContent b n)) +fontContent = choose -- the likely most common are checked first + [parseGlyph, parseHKern, parseFontFace, parseMissingGlyph, parseVKern] + + +parseFontFace :: (MonadThrow m, V b ~ V2, N b ~ n, Read n, RealFloat n, Renderable (DImage (N b) Embedded) b, + Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n)) +parseFontFace = tagName "{http://www.w3.org/2000/svg}font-face" fontFaceAttrs $ + \(ca,fontFamily,fontStyle,fontVariant,fontWeight,fontStretch,fontSize,unicodeRange,unitsPerEm,panose1, + stemv,stemh,slope,capHeight,xHeight,accentHeight,ascent,descent,widths,bbox,ideographic,alphabetic,mathematical, + hanging,vIdeographic,vAlphabetic,vMathematical,vHanging,underlinePosition,underlineThickness,strikethroughPosition, + strikethroughThickness,overlinePosition,overlineThickness) -> + do return $ FF $ FontFace fontFamily fontStyle fontVariant fontWeight fontStretch fontSize unicodeRange unitsPerEm panose1 + stemv stemh slope capHeight xHeight accentHeight ascent descent widths (parseBBox bbox) ideographic + alphabetic mathematical hanging vIdeographic vAlphabetic vMathematical vHanging underlinePosition + underlineThickness strikethroughPosition strikethroughThickness overlinePosition overlineThickness + + +parseMissingGlyph :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Renderable (DImage (N b) Embedded) b, + Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n)) +parseMissingGlyph = tagName "{http://www.w3.org/2000/svg}missing-glyph" missingGlyphAttrs $ + \(ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY) -> + do return $ GG $ Glyph (id1 ca) (Leaf (id1 ca) mempty mempty) Nothing + (getN horizAdvX) (getN vertOriginX) (getN vertOriginY) (getN vertAdvY) + Nothing Nothing Nothing Nothing Nothing + + +parseGlyph :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Renderable (DImage (N b) Embedded) b, + Renderable (Path V2 n) b, Show n, Typeable b, Typeable n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (FontContent b n)) +parseGlyph = tagName "{http://www.w3.org/2000/svg}glyph" glyphAttrs $ + \(ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY,unicode,glyphName,orientation,arabicForm,lang) -> + do gs <- many gContent + let st hmaps = parseStyles style hmaps + let sub = SubTree True (id1 ca) (0,0) Nothing Nothing (\maps -> (applyStyleSVG st maps)) (reverse gs) + return $ GG $ Glyph (id1 ca) sub d (getN horizAdvX) (getN vertOriginX) (getN vertOriginY) (getN vertAdvY) + unicode glyphName orientation arabicForm lang + +getN = maybe 0 (read . T.unpack) + +parseHKern :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n)) +parseHKern = tagName "{http://www.w3.org/2000/svg}hkern" kernAttrs $ + \(ca,u1,g1,u2,g2,k) -> + do return $ KK $ Kern HKern (charList u1) (charList g1) (charList u2) (charList g2) (getN k) + +parseVKern :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n)) +parseVKern = tagName "{http://www.w3.org/2000/svg}vkern" kernAttrs $ + \(ca,u1,g1,u2,g2,k) -> + do return $ KK $ Kern VKern (charList u1) (charList g1) (charList u2) (charList g2) (getN k) + +charList :: Maybe Text -> [Text] +charList str = maybe [] (T.splitOn ",") str + +---------------------------------------------------------------------------------------- +-- descriptive elements +------------------------------------------------------o ---------------------------------- +-- | Parse \, see +-- parseDesc :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n)) +parseDesc = tagName "{http://www.w3.org/2000/svg}desc" descAttrs + $ \(ca,class_,style) -> + do desc <- content + return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseTitle = tagName "{http://www.w3.org/2000/svg}title" descAttrs + $ \(ca,class_,style) -> + do title <- content + return $ Leaf (id1 ca) mempty mempty + +skipArbitraryTag :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) => Consumer Event m (Maybe (Tag b n)) +skipArbitraryTag = do t <- ignoreAnyTreeContent + if isJust t then return (Just $ Leaf (Just "") mempty mempty) + else return Nothing + +-- | Parse \, see +-- +-- @ +-- An example what metadata contains: +-- +-- \ +-- \ +-- \ +-- \image\/svg+xml\<\/dc:format\> +-- \ +-- \ +-- \ +-- \ +-- @ +-- +{- Maybe we implement it one day + +parseMetaData :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n)) +parseMetaData = tagName "{http://www.w3.org/2000/svg}metadata" ignoreAttrs + $ \_ -> + do -- meta <- many metaContent + return $ Leaf Nothing mempty mempty + +-- metaContent :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n)) +metaContent = choose [parseRDF] -- extend if needed + +-- parseRDF :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n)) +parseRDF = tagName "{http://www.w3.org/1999/02/22-rdf-syntax-ns#}RDF" ignoreAttrs + $ \_ -> + do -- c <- parseWork + return $ Leaf Nothing mempty mempty + +-- parseWork :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n)) +parseWork = tagName "{http://creativecommons.org/ns#}Work" ignoreAttrs + $ \_ -> + do -- c <- many workContent + return $ Leaf Nothing mempty mempty + +workContent = choose [parseFormat, parseType, parseRDFTitle, parseDate, parseCreator, + parsePublisher, parseSource, parseLanguage, parseSubject, parseDescription] + +parseCreator = tagName "{http://purl.org/dc/elements/1.1/}creator" ignoreAttrs + $ \_ -> do { c <- parseAgent ; return $ Leaf Nothing mempty mempty } + +parseAgent = tagName "{http://creativecommons.org/ns#}Agent" ignoreAttrs + $ \_ -> do { c <- parseAgentTitle ; return $ Leaf Nothing mempty mempty } + +parsePublisher = tagName "{http://purl.org/dc/elements/1.1/}publisher" ignoreAttrs + $ \_ -> do { c <- parseAgent ; return $ Leaf Nothing mempty mempty } + +parseSubject = tagName "{http://purl.org/dc/elements/1.1/}subject" ignoreAttrs + $ \_ -> do { c <- parseBag ; return $ Leaf Nothing mempty mempty } + +-- parseBag :: (MonadThrow m, Metric (V b), Ord (N b), Floating (N b)) => Consumer Event m (Maybe (Tag b n)) +parseBag = tagName "{http://www.w3.org/1999/02/22-rdf-syntax-ns#}Bag" ignoreAttrs + $ \_ -> do { c <- parseList ; return $ Leaf Nothing mempty mempty } + +parseFormat = tagName "{http://purl.org/dc/elements/1.1/}format" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } + +parseType = tagName "{http://purl.org/dc/elements/1.1/}type" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } + +parseRDFTitle = tagName "{http://purl.org/dc/elements/1.1/}title" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } + +parseDate = tagName "{http://purl.org/dc/elements/1.1/}date" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } + +parseAgentTitle = tagName "{http://purl.org/dc/elements/1.1/}title" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } + +parseSource = tagName "{http://purl.org/dc/elements/1.1/}source" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } + +parseLanguage = tagName "{http://purl.org/dc/elements/1.1/}language" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } + +parseList = tagName "{http://www.w3.org/1999/02/22-rdf-syntax-ns#}li" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } + +parseDescription = tagName "{http://purl.org/dc/elements/1.1/}description" ignoreAttrs + $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty } +-} +------------------------------------ +-- inkscape / sodipodi tags +------------------------------------ +parseSodipodi = tagName "{http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd}namedview" namedViewAttrs + $ \(pc,bc,bo,ot,gt,gut,po,ps,ww,wh,id1,sg,zoom,cx,cy,wx,wy,wm,cl) -> + do -- c <- parseGrid + return $ Leaf (Just "") mempty mempty + +-- +parseGrid = tagName "{http://www.inkscape.org/namespaces/inkscape}grid" ignoreAttrs + $ \_ -> + do c <- content + return $ Leaf Nothing mempty mempty + +{- +-} + +parsePerspective = tagName "{http://www.inkscape.org/namespaces/inkscape}perspective" perspectiveAttrs + $ \(typ,vp_x,vp_y,vp_z,persp3d_origin,id_) -> + return $ Leaf (Just "") mempty mempty + +parsePathEffect = tagName "{http://www.inkscape.org/namespaces/inkscape}path-effect" ignoreAttrs + $ \_ -> return $ Leaf Nothing mempty mempty +-------------------------------------------------------------------------------------- +-- sceletons + +-- | Parse \, see +parsePattern :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n)) +parsePattern = tagName "{http://www.w3.org/2000/svg}pattern" patternAttrs $ + \(cpa,ca,pa,class_,style,ext,view,ar,x,y,w,h,pUnits,pCUnits,pTrans) -> + do c <- content -- insidePattern <- many patternContent + return $ Leaf (Just "") mempty mempty + +patternContent :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n)) +patternContent = choose [parseImage] + +-- | Parse \, see +parseFilter = tagName "{http://www.w3.org/2000/svg}filter" filterAttrs $ + \(ca,pa,xlink,class_,style,ext,x,y,w,h,filterRes,filterUnits,primUnits) -> + do -- insideFilter <- many filterContent + return $ Leaf (id1 ca) mempty mempty + +filterContent = choose [ parseFeGaussianBlur, + parseFeBlend,parseFeColorMatrix,parseFeComponentTransfer,parseFeComposite,parseFeConvolveMatrix, -- filter primitive elments + parseFeDiffuseLighting,parseFeDisplacementMap,parseFeFlood,parseFeImage, + parseFeMerge,parseFeMorphology,parseFeOffset,parseFeSpecularLighting,parseFeTile,parseFeTurbulence, + parseDesc,parseTitle] + +-------------------------------------------------------------------------------------- +-- filter primitives (currently only sceletons) +-------------------------------------------------------------------------------------- + +-- | Parse \, see +parseFeBlend = tagName "{http://www.w3.org/2000/svg}feBlend" feBlendAttrs $ + \(ca,pa,fpa,class_,style,in1,in2,mode) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeColorMatrix = tagName "{http://www.w3.org/2000/svg}feColorMatrix" feColorMatrixAttrs $ + \(ca,pa,fpa,class_,style,in1,type1,values) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeComponentTransfer = tagName "{http://www.w3.org/2000/svg}feComponentTransfer" feComponentTransferAttrs $ + \(ca,pa,fpa,class_,style,in1) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeComposite = tagName "{http://www.w3.org/2000/svg}feComposite" feCompositeAttrs $ + \(ca,pa,fpa,class_,style,in1,in2,operator,k1,k2,k3,k4) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeConvolveMatrix = tagName "{http://www.w3.org/2000/svg}feConvolveMatrix" feConvolveMatrixAttrs $ + \(ca,pa,fpa,class_,style,order,km,d,bias,tx,ty,em,ku,par) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeDiffuseLighting = tagName "{http://www.w3.org/2000/svg}feDiffuseLighting" feDiffuseLightingAttrs $ + \(ca,pa,fpa,class_,style,in1,surfaceScale,diffuseConstant,kuLength) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeDisplacementMap = tagName "{http://www.w3.org/2000/svg}feDisplacementMap" feDisplacementMapAttrs $ + \(ca,pa,fpa,class_,style,in1,in2,sc,xChan,yChan) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeFlood = tagName "{http://www.w3.org/2000/svg}feFlood" feFloodAttrs $ + \(ca,pa,fpa,class_,style) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeGaussianBlur = tagName "{http://www.w3.org/2000/svg}feGaussianBlur" feGaussianBlurAttrs $ + \(ca,pa,fpa,class_,style,in1,stdDeviation) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeImage = tagName "{http://www.w3.org/2000/svg}feImage" feImageAttrs $ + \(ca,pa,fpa,xlibk,class_,style,ext,par) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeMerge = tagName "{http://www.w3.org/2000/svg}feMerge" feMergeAttrs $ + \(ca,pa,fpa,class_,style) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeMorphology = tagName "{http://www.w3.org/2000/svg}feMorphology" feMorphologyAttrs $ + \(ca,pa,fpa,class_,style,in1,operator,radius) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeOffset = tagName "{http://www.w3.org/2000/svg}feOffset" feOffsetAttrs $ + \(ca,pa,fpa,class_,style,in1,dx,dy) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeSpecularLighting = tagName "{http://www.w3.org/2000/svg}feSpecularLighting" feSpecularLightingAttrs $ + \(ca,pa,fpa,class_,style,in1,surfaceScale,sc,se,ku) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeTile = tagName "{http://www.w3.org/2000/svg}feTile" feTileAttrs $ + \(ca,pa,fpa,class_,style,in1) -> return $ Leaf (id1 ca) mempty mempty + +-- | Parse \, see +parseFeTurbulence = tagName "{http://www.w3.org/2000/svg}feTurbulence" feTurbulenceAttrs $ + \(ca,pa,fpa,class_,style,in1,in2,mode) -> return $ Leaf (id1 ca) mempty mempty + +------------------------------------------------------------------------------------ + +animationElements = [] diff --git a/src/Diagrams/SVG/Tree.hs b/src/Diagrams/SVG/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/SVG/Tree.hs @@ -0,0 +1,547 @@ +{-# LANGUAGE TypeFamilies, OverloadedStrings, FlexibleContexts #-} +-------------------------------------------------------------------- +-- | +-- Module : Diagrams.SVG.Tree +-- Copyright : (c) 2015 Tillmann Vogt +-- License : BSD3 +-- +-- Maintainer: diagrams-discuss@googlegroups.com +-- Stability : stable +-- Portability: portable + +module Diagrams.SVG.Tree + ( + -- * Tree data type + Tag(..) + , HashMaps(..) + -- * Extract data from the tree + , nodes + , Attrs(..) + , NodesMap + , CSSMap + , GradientsMap + , PreserveAR(..) + , AlignSVG(..) + , MeetOrSlice(..) + , Place + , ViewBox(..) + , Gr(..) + , GradientAttributes(..) + , PresentationAttributes(..) + , GradRefId + , expandGradMap + , insertRefs + , preserveAspectRatio + , FontContent(..) + , FontData(..) + , FontFace(..) + , Glyph(..) + , KernDir(..) + , KernMaps(..) + , SvgGlyphs(..) + , Kern(..) + ) +where +import Data.Maybe (isJust, fromJust , fromMaybe) +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import Data.Text(Text(..)) +import Data.Vector(Vector) +import Diagrams.Prelude hiding (Vector) +import Diagrams.TwoD.Size +-- import Diagrams.SVG.Fonts.ReadFont +import Debug.Trace + +-- Note: Maybe we could use the Tree from diagrams here but on the other hand this makes diagrams-input +-- more independent of changes of diagrams' internal structures + +------------------------------------------------------------------------------------- +-- | A tree structure is needed to handle refences to parts of the tree itself. +-- The \-section contains shapes that can be refered to, but the SVG standard allows to refer to +-- every tag in the SVG-file. +-- +data Tag b n = Leaf Id (ViewBox n -> Path V2 n) ((HashMaps b n, ViewBox n) -> Diagram b)-- ^ +-- A leaf consists of +-- +-- * An Id +-- +-- * A path so that this leaf can be used to clip some other part of a tree +-- +-- * A diagram (Another option would have been to apply a function to the upper path) + | Reference Id Id (ViewBox n -> Path V2 n) ((HashMaps b n, ViewBox n) -> Diagram b -> Diagram b)-- ^ +-- A reference (\-tag) consists of: +-- +-- * An Id +-- +-- * A reference to an Id +-- +-- * A viewbox so that percentages are relative to this viewbox +-- +-- * Transformations applied to the reference + | SubTree Bool Id (Double, Double) + (Maybe (ViewBox n)) + (Maybe PreserveAR) + (HashMaps b n -> Diagram b -> Diagram b) + [Tag b n]-- ^ +-- A subtree consists of: +-- +-- * A Bool: Are we in a section that will be rendered directly (not in a \-section) +-- +-- * An Id of subdiagram +-- +-- * A viewbox so that percentages are relative to this viewbox +-- +-- * Aspect Ratio +-- +-- * A transformation or application of a style to a subdiagram +-- +-- * A list of subtrees + | StyleTag [(Text, [(Text, Text)])] -- ^ A tag that contains CSS styles with selectors and attributes + | FontTag (FontData b n) + | Grad Id (Gr n) -- ^ A gradient + | Stop (HashMaps b n -> [GradientStop n]) -- ^ +-- We need to make this part of this data structure because Gradient tags can also contain description tags + +type Id = Maybe Text +type GradRefId = Maybe Text +type Attrs = [(Text, Text)] + +type Nodelist b n = [(Text, Tag b n)] +type CSSlist = [(Text, Attrs)] +data Gr n = Gr GradRefId + GradientAttributes + (Maybe (ViewBox n)) + [CSSMap -> [GradientStop n]] + (CSSMap -> GradientAttributes -> ViewBox n -> [CSSMap -> [GradientStop n]] -> Texture n) + +type Gradlist n = [(Text, Gr n)] +type Fontlist b n = [(Text, FontData b n)] + +type HashMaps b n = (NodesMap b n, CSSMap, GradientsMap n) +type NodesMap b n = H.HashMap Text (Tag b n) +type CSSMap = H.HashMap Text Attrs +type GradientsMap n = H.HashMap Text (Gr n) + +type ViewBox n = (n,n,n,n) -- (MinX,MinY,Width,Height) + +data PreserveAR = PAR AlignSVG MeetOrSlice -- ^ see +data AlignSVG = AlignXY Place Place -- ^ alignment in x and y direction +type Place = Double -- ^ A value between 0 and 1, where 0 is the minimal value and 1 the maximal value +data MeetOrSlice = Meet | Slice + +instance Show (Tag b n) where + show (Leaf id1 _ _) = "Leaf " ++ (show id1) ++ "\n" + show (Reference selfid id1 viewbox f) = "Reference " ++ (show id1) ++ "\n" + show (SubTree b id1 wh viewbox ar f tree) = "Sub " ++ (show id1) ++ concat (map show tree) ++ "\n" + show (StyleTag _) = "Style " ++ "\n" + show (Grad id1 gr) = "Grad id:" ++ (show id1) -- ++ (show gr) ++ "\n" + show (Stop _) = "Stop " ++ "\n" + +-- instance Show (Gr n) where show (Gr gradRefId gattr vb stops tex) = " ref:" ++ (show gradRefId) ++ "viewbox: " ++ (show vb) + +---------------------------------------------------------------------------------- +-- | Generate elements that can be referenced by their ID. +-- The tree nodes are splitted into 4 groups of lists of (ID,value)-pairs): +-- +-- * Nodes that contain elements that can be transformed to a diagram +-- +-- * CSS classes with corresponding (attribute,value)-pairs, from the -tag +-- +-- * Gradients +-- +-- * Fonts +nodes :: Maybe (ViewBox n) -> (Nodelist b n, CSSlist, Gradlist n, Fontlist b n) -> Tag b n -> + (Nodelist b n, CSSlist, Gradlist n, Fontlist b n) +nodes viewbox (ns,css,grads,fonts) (Leaf id1 path diagram) + | isJust id1 = (ns ++ [(fromJust id1, Leaf id1 path diagram)],css,grads,fonts) + | otherwise = (ns,css,grads,fonts) + +-- A Reference element for the -tag +nodes viewbox (ns,css,grads,fonts) (Reference selfId id1 vb f) = (ns,css,grads,fonts) + +nodes viewbox (ns,css,grads,fonts) (SubTree b id1 wh Nothing ar f children) + | isJust id1 = myconcat [ (ns ++ [(fromJust id1, SubTree b id1 wh viewbox ar f children)],css,grads,fonts) , + (myconcat (map (nodes viewbox (ns,css,grads,fonts)) children)) ] + | otherwise = myconcat (map (nodes viewbox (ns,css,grads,fonts)) children) + +nodes viewbox (ns,css,grads,fonts) (SubTree b id1 wh vb ar f children) + | isJust id1 = myconcat [ (ns ++ [(fromJust id1, SubTree b id1 wh vb ar f children)],css,grads,fonts) , + (myconcat (map (nodes vb (ns,css,grads,fonts)) children)) ] + | otherwise = myconcat (map (nodes vb (ns,css,grads,fonts)) children) + +nodes viewbox (ns,css,grads,fonts) (Grad id1 (Gr gradRefId gattr vb stops texture)) + | isJust id1 = (ns,css, grads ++ [(fromJust id1, Gr gradRefId gattr vb stops texture)], fonts) + | otherwise = (ns,css,grads,fonts) + +-- There is a global style tag in the defs section of some svg files +nodes viewbox (ns,css,grads,fonts) (StyleTag styles) = (ns,css ++ styles,grads,fonts) +-- stops are not extracted here but from the gradient parent node +nodes viewbox lists (Stop _) = lists + +nodes viewbox (ns,css,grads,fonts) (FontTag fontData) = (ns,css,grads,fonts ++ [(fromMaybe "" (fontId fontData), fontData)]) + +myconcat :: [(Nodelist b n, CSSlist, Gradlist n, Fontlist b n)] -> (Nodelist b n, CSSlist, Gradlist n, Fontlist b n) +myconcat list = (concat $ map sel1 list, concat $ map sel2 list, concat $ map sel3 list, concat $ map sel4 list) + where sel1 (a,b,c,d) = a + sel2 (a,b,c,d) = b + sel3 (a,b,c,d) = c + sel4 (a,b,c,d) = d + +------------------------------------------------------------------------------------------------------ +-- The following code is necessary to handle nested xlink:href in gradients, +-- like in this example (#linearGradient3606 in radialGradient): +-- +-- +-- +-- +-- +-- + +-- | Gradients contain references to include attributes/stops from other gradients. +-- expandGradMap expands the gradient with these attributes and stops + +expandGradMap :: GradientsMap n -> GradientsMap n -- GradientsMap n = H.HashMap Text (Gr n) +expandGradMap gradMap = H.mapWithKey (newGr gradMap) gradMap + +newGr grMap key (Gr gradRefId attrs vb stops f) = (Gr gradRefId newAttributes vb newStops f) + where newStops = stops ++ (gradientStops grMap gradRefId) + newAttributes = overwriteDefaultAttributes $ gradientAttributes grMap (Just key) + +-- | Gradients that reference other gradients form a list of attributes +-- The last element of this list are the default attributes (thats why there is "reverse attrs") +-- Then the second last attributes overwrite these defaults (and so on until the root) +-- The whole idea of this nesting is that Nothing values don't overwrite Just values +overwriteDefaultAttributes :: [GradientAttributes] -> GradientAttributes +overwriteDefaultAttributes [attrs] = attrs +overwriteDefaultAttributes attrs = foldl1 updateRec (reverse attrs) + +-- | Every reference is looked up in the gradient map and a record of attributes is added to a list +gradientAttributes :: GradientsMap n -> GradRefId -> [GradientAttributes] -- GradientsMap n = H.HashMap Text (Gr n) +gradientAttributes grMap Nothing = [] +gradientAttributes grMap (Just refId) | isJust gr = (attrs $ fromJust gr) : (gradientAttributes grMap (grRef $ fromJust gr)) + | otherwise = [] + where gr = H.lookup refId grMap + grRef (Gr ref _ _ _ _) = ref + +attrs (Gr _ att _ _ _) = att + +-- | Every reference is looked up in the gradient map and the stops are added to a list +gradientStops :: GradientsMap n -> GradRefId -> [CSSMap -> [GradientStop n]] +gradientStops grMap Nothing = [] +gradientStops grMap (Just refId) | isJust gr = (stops $ fromJust gr) ++ (gradientStops grMap (grRef $ fromJust gr)) + | otherwise = [] + where gr = H.lookup refId grMap + grRef (Gr ref _ _ _ _) = ref + stops (Gr _ _ _ st _) = st + +-- | Update the gradient record. The first argument is the leaf record, the second is the record that overwrites the leaf. +-- The upper example references gradients that have only stops (no overwriting of attributes). +-- See +updateRec :: GradientAttributes -> GradientAttributes -> GradientAttributes +updateRec (GA pa class_ style x1 y1 x2 y2 cx cy r fx fy gradientUnits gradientTransform spreadMethod) + (GA paN class1N styleN x1N y1N x2N y2N cxN cyN rN fxN fyN gradientUnitsN gradientTransformN spreadMethodN) + = toGA (paN, (updateList [class_,style,x1,y1,x2,y2,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod] -- TODO: update pa + [class1N,styleN,x1N,y1N,x2N,y2N,cxN,cyN,rN,fxN,fyN,gradientUnitsN,gradientTransformN,spreadMethodN])) + where + updateList :: [Maybe Text] -> [Maybe Text] -> [Maybe Text] + updateList (defaultt:xs) ((Just t1):ys) = (Just t1) : (updateList xs ys) + updateList ((Just t0):xs) (Nothing :ys) = (Just t0) : (updateList xs ys) + updateList (Nothing :xs) (Nothing :ys) = Nothing : (updateList xs ys) + updateList _ _ = [] + + toGA (pa, [class_,style,x1,y1,x2,y2,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod]) = + GA pa class_ style x1 y1 x2 y2 cx cy r fx fy gradientUnits gradientTransform spreadMethod + +------------------------------------------------------------------------------------------------------------ + +-- | Lookup a diagram and return an empty diagram in case the SVG-file has a wrong reference +lookUp hmap i | (isJust i) && (isJust l) = fromJust l + | otherwise = Leaf Nothing mempty mempty -- an empty diagram if we can't find the id + where l = H.lookup (fromJust i) hmap + +-- | Evaluate the tree into a diagram by inserting xlink:href references from nodes and gradients, +-- applying clipping and passing the viewbox to the leafs +insertRefs :: (V b ~ V2, N b ~ n, RealFloat n, Place ~ n) => (HashMaps b n, ViewBox n) -> Tag b n -> Diagram b + +insertRefs (maps,viewbox) (Leaf id1 path f) = (f (maps,viewbox)) # (if isJust id1 then named (T.unpack $ fromJust id1) else id) +insertRefs (maps,viewbox) (Grad _ _) = mempty +insertRefs (maps,viewbox) (Stop f) = mempty +insertRefs (maps,viewbox) (Reference selfId id1 path styles) + | (Diagrams.TwoD.Size.width r) <= 0 || (Diagrams.TwoD.Size.height r) <= 0 = mempty + | otherwise = referencedDiagram # styles (maps,viewbox) + # cutOutViewBox viewboxPAR +-- # stretchViewBox (fromJust w) (fromJust h) viewboxPAR + # (if isJust selfId then named (T.unpack $ fromJust selfId) else id) + where r = path viewbox + viewboxPAR = getViewboxPreserveAR subTree + referencedDiagram = insertRefs (maps,viewbox) (makeSubTreeVisible viewbox subTree) + subTree = lookUp (sel1 maps) id1 + getViewboxPreserveAR (SubTree _ id1 wh viewbox ar g children) = (viewbox, ar) + getViewboxPreserveAR _ = (Nothing, Nothing) + sel1 (a,b,c) = a + +insertRefs (maps,viewbox) (SubTree False _ _ _ _ _ _) = mempty +insertRefs (maps,viewbox) (SubTree True id1 (w,h) viewb ar styles children) = + subdiagram # styles maps + # cutOutViewBox (viewb, ar) + # (if (w > 0) && (h > 0) then stretchViewBox w h (viewb, ar) else id) + # (if isJust id1 then named (T.unpack $ fromJust id1) else id) + where subdiagram = mconcat (map (insertRefs (maps, fromMaybe viewbox viewb)) children) + +insertRefs (maps,viewbox) (StyleTag _) = mempty +------------------------------------------------------------------------------------------------------------------------------- + +makeSubTreeVisible viewbox (SubTree _ id1 wh vb ar g children) = + (SubTree True id1 wh (Just viewbox) ar g (map (makeSubTreeVisible viewbox) children)) +makeSubTreeVisible _ x = x + +stretchViewBox w h ((Just (minX,minY,width,height), Just par)) = preserveAspectRatio w h (width - minX) (height - minY) par +stretchViewBox w h ((Just (minX,minY,width,height), Nothing)) = -- Debug.Trace.trace "nothing" $ + preserveAspectRatio w h (width - minX) (height - minY) (PAR (AlignXY 0.5 0.5) Meet) +stretchViewBox w h _ = id + +cutOutViewBox (Just (minX,minY,width,height), _) = rectEnvelope (p2 (minX, minY)) (r2 ((width - minX), (height - minY))) + -- (clipBy (rect (width - minX) (height - minY))) +cutOutViewBox _ = id + +------------------------------------------------------------------------------------------------------------------------------- +-- | preserveAspectRatio is needed to fit an image into a frame that has a different aspect ratio than the image +-- (e.g. 16:10 against 4:3). +-- SVG embeds images the same way: +-- +-- > import Graphics.SVGFonts +-- > +-- > portrait preserveAR width height = stroke (readSVGFile preserveAR width height "portrait.svg") # showOrigin +-- > text' t = stroke (textSVG' $ TextOpts t lin INSIDE_H KERN False 1 1 ) # fc back # lc black # fillRule EvenOdd +-- > portraitMeet1 x y = (text' "PAR (AlignXY " ++ show x ++ " " show y ++ ") Meet") === +-- > (portrait (PAR (AlignXY x y) Meet) 200 100 <> rect 200 100) +-- > portraitMeet2 x y = (text' "PAR (AlignXY " ++ show x ++ " " show y ++ ") Meet") === +-- > (portrait (PAR (AlignXY x y) Meet) 100 200 <> rect 100 200) +-- > portraitSlice1 x y = (text' "PAR (AlignXY " ++ show x ++ " " show y ++ ") Slice") === +-- > (portrait (PAR (AlignXY x y) Slice) 100 200 <> rect 100 200) +-- > portraitSlice2 x y = (text' "PAR (AlignXY " ++ show x ++ " " show y ++ ") Slice") === +-- > (portrait (PAR (AlignXY x y) Slice) 200 100 <> rect 200 100) +-- > meetX = (text' "meet") === (portraitMeet1 0 0 ||| portraitMeet1 0.5 0 ||| portraitMeet1 1 0) +-- > meetY = (text' "meet") === (portraitMeet2 0 0 ||| portraitMeet2 0 0.5 ||| portraitMeet2 0 1) +-- > sliceX = (text' "slice") === (portraitSlice1 0 0 ||| portraitSlice1 0.5 0 ||| portraitSlice1 1 0) +-- > sliceY = (text' "slice") === (portraitSlice2 0 0 ||| portraitSlice2 0 0.5 ||| portraitSlice2 0 1) +-- > im = (text' "Image to fit") === (portrait (PAR (AlignXY 0 0) Meet) 123 456) +-- > viewport1 = (text' "Viewport1") === (rect 200 100) +-- > viewport2 = (text' "Viewport2") === (rect 100 200) +-- > imageAndViewports = im === viewport1 === viewport2 +-- > +-- > par = imageAndViewports ||| ( ( meetX ||| meetY) === ( sliceX ||| sliceY) ) +-- +-- <> +-- preserveAspectRatio :: Width -> Height -> Width -> Height -> PreserveAR -> Diagram b -> Diagram b +preserveAspectRatio newWidth newHeight oldWidth oldHeight preserveAR image + | aspectRatio < newAspectRatio = xPlace preserveAR image + | otherwise = yPlace preserveAR image + where aspectRatio = oldWidth / oldHeight + newAspectRatio = newWidth / newHeight + scaX = newHeight / oldHeight + scaY = newWidth / oldWidth + xPlace (PAR (AlignXY x y) Meet) i = i # scale scaX # alignBL # translateX ((newWidth - oldWidth*scaX)*x) + xPlace (PAR (AlignXY x y) Slice) i = i # scale scaY # alignBL # translateX ((newWidth - oldWidth*scaX)*x) +-- # view (p2 (0, 0)) (r2 (newWidth, newHeight)) + + yPlace (PAR (AlignXY x y) Meet) i = i # scale scaY # alignBL # translateY ((newHeight - oldHeight*scaY)*y) + yPlace (PAR (AlignXY x y) Slice) i = i # scale scaX # alignBL # translateY ((newHeight - oldHeight*scaY)*y) +-- # view (p2 (0, 0)) (r2 (newWidth, newHeight)) + + +-- a combination of linear- and radial-attributes so that referenced gradients can replace Nothing-attributes +data GradientAttributes = + GA { presentationAttributes :: PresentationAttributes + , class_ :: Maybe Text + , style :: Maybe Text + , x1 :: Maybe Text + , y1 :: Maybe Text + , x2 :: Maybe Text + , y2 :: Maybe Text + , cx :: Maybe Text + , cy :: Maybe Text + , r :: Maybe Text + , fx :: Maybe Text + , fy :: Maybe Text + , gradientUnits :: Maybe Text + , gradientTransform :: Maybe Text + , spreadMethod :: Maybe Text + } + +-- GA pa class_ style x1 y1 x2 y2 cx cy r fx fy gradientUnits gradientTransform spreadMethod + +data PresentationAttributes = + PA { alignmentBaseline :: Maybe Text + , baselineShift :: Maybe Text + , clip :: Maybe Text + , clipPath :: Maybe Text + , clipRule :: Maybe Text + , color :: Maybe Text + , colorInterpolation :: Maybe Text + , colorInterpolationFilters :: Maybe Text + , colorProfile :: Maybe Text + , colorRendering :: Maybe Text + , cursor :: Maybe Text + , direction :: Maybe Text + , display :: Maybe Text + , dominantBaseline :: Maybe Text + , enableBackground :: Maybe Text + , fill :: Maybe Text + , fillOpacity :: Maybe Text + , fillRuleSVG :: Maybe Text + , filter :: Maybe Text + , floodColor :: Maybe Text + , floodOpacity :: Maybe Text + , fontFamily :: Maybe Text + , fntSize :: Maybe Text + , fontSizeAdjust :: Maybe Text + , fontStretch :: Maybe Text + , fontStyle :: Maybe Text + , fontVariant :: Maybe Text + , fontWeight :: Maybe Text + , glyphOrientationHorizontal :: Maybe Text + , glyphOrientationVertical :: Maybe Text + , imageRendering :: Maybe Text + , kerning :: Maybe Text + , letterSpacing :: Maybe Text + , lightingColor :: Maybe Text + , markerEnd :: Maybe Text + , markerMid :: Maybe Text + , markerStart :: Maybe Text + , mask :: Maybe Text + , opacity :: Maybe Text + , overflow :: Maybe Text + , pointerEvents :: Maybe Text + , shapeRendering :: Maybe Text + , stopColor :: Maybe Text + , stopOpacity :: Maybe Text + , strokeSVG :: Maybe Text + , strokeDasharray :: Maybe Text + , strokeDashoffset :: Maybe Text + , strokeLinecap :: Maybe Text + , strokeLinejoin :: Maybe Text + , strokeMiterlimit :: Maybe Text + , strokeOpacity :: Maybe Text + , strokeWidth :: Maybe Text + , textAnchor :: Maybe Text + , textDecoration :: Maybe Text + , textRendering :: Maybe Text + , unicodeBidi :: Maybe Text + , visibility :: Maybe Text + , wordSpacing :: Maybe Text + , writingMode :: Maybe Text + } deriving Show + +type SvgGlyphs n = H.HashMap Text (Maybe Text, n, Maybe Text) +-- ^ \[ (unicode, (glyph_name, horiz_advance, ds)) \] + +data Kern n = Kern + { kernDir :: KernDir + , kernU1 :: [Text] + , kernU2 :: [Text] + , kernG1 :: [Text] + , kernG2 :: [Text] + , kernK :: n + } + +-- | Data from the subtags +data FontContent b n = FF (FontFace n) | GG (Glyph b n) | KK (Kern n) + +-- | All data in the \-tag +data FontData b n = FontData + { + fontId :: Maybe Text + , fontDataHorizontalOriginX :: Maybe Text + , fontDataHorizontalOriginY :: Maybe Text + , fontDataHorizontalAdvance :: n + , fontDataVerticalOriginX :: Maybe Text + , fontDataVerticalOriginY :: Maybe Text + , fontDataVerticalAdvance :: Maybe Text + -- ^ data gathered from subtags + , fontFace :: FontFace n + , fontMissingGlyph :: Glyph b n + , fontDataGlyphs :: SvgGlyphs n +-- , fontDataRawKernings :: [(Text, [Text], [Text], [Text], [Text])] + , fontDataKerning :: KernMaps n +-- , fontDataFileName :: Text +} + +data FontFace n = FontFace + { fontDataFamily :: Maybe Text + , fontDataStyle :: Maybe Text + , fontDataVariant :: Maybe Text + , fontDataWeight :: Maybe Text + , fontDataStretch :: Maybe Text + , fontDataSize :: Maybe Text + , fontDataUnicodeRange :: Maybe Text + , fontDataUnitsPerEm :: Maybe Text + , fontDataPanose :: Maybe Text + , fontDataVerticalStem :: Maybe Text + , fontDataHorizontalStem :: Maybe Text + , fontDataSlope :: Maybe Text + , fontDataCapHeight :: Maybe Text + , fontDataXHeight :: Maybe Text + , fontDataAccentHeight :: Maybe Text + , fontDataAscent :: Maybe Text + , fontDataDescent :: Maybe Text + , fontDataWidths :: Maybe Text + , fontDataBoundingBox :: [n] + , fontDataIdeographicBaseline :: Maybe Text + , fontDataAlphabeticBaseline :: Maybe Text + , fontDataMathematicalBaseline :: Maybe Text + , fontDataHangingBaseline :: Maybe Text + , fontDataVIdeographicBaseline :: Maybe Text + , fontDataVAlphabeticBaseline :: Maybe Text + , fontDataVMathematicalBaseline :: Maybe Text + , fontDataVHangingBaseline :: Maybe Text + , fontDataUnderlinePos :: Maybe Text + , fontDataUnderlineThickness :: Maybe Text + , fontDataStrikethroughPos :: Maybe Text + , fontDataStrikethroughThickness :: Maybe Text + , fontDataOverlinePos :: Maybe Text + , fontDataOverlineThickness :: Maybe Text + } + +data Glyph b n = Glyph + { glyphId :: Maybe Text + , glyph :: Tag b n + , d :: Maybe Text + , horizAdvX :: n + , vertOriginX :: n + , vertOriginY :: n + , vertAdvY :: n + , unicode :: Maybe Text + , glyphName :: Maybe Text + , orientation :: Maybe Text + , arabicForm :: Maybe Text + , lang :: Maybe Text + } + +data KernDir = HKern | VKern + +data KernMaps n = KernMaps + { kernDirs :: [KernDir] + , kernU1S :: H.HashMap Text [Int] + , kernU2S :: H.HashMap Text [Int] + , kernG1S :: H.HashMap Text [Int] + , kernG2S :: H.HashMap Text [Int] + , kernKs :: Vector n + } + diff --git a/src/Diagrams/TwoD/Input.hs b/src/Diagrams/TwoD/Input.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Input.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Input +-- Copyright : (c) 2015 Tillmann Vogt +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Importing external images into diagrams. +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Input + ( loadImageEmbedded + , loadImageExternal + ) where + +import Control.Monad (msum) +import Codec.Picture +import Codec.Picture.Types (dynamicMap) + +import Data.Semigroup +import Data.Typeable (Typeable) + +import Diagrams.Core +import Diagrams.TwoD.Image +import Diagrams.TwoD.Size +import Diagrams.TwoD.Types +import qualified Diagrams.TwoD.Text as TT +import Diagrams.SVG.ReadSVG (readSVGFile, InputConstraints) +import Diagrams.SVG.Tree (Place) +import Filesystem.Path.CurrentOS (decodeString) + +-- | Load 2d formats given by a filepath and embed them +loadImageEmbedded :: (InputConstraints b n, Renderable (TT.Text n) b, Read n, n ~ Place) + => String -> IO (Either String (QDiagram b V2 n Any)) +loadImageEmbedded path = do + dImg <- readImage path + svgImg <- readSVGFile (decodeString path) + return $ msum [ svgImg, + fmap (image.rasterImage) dImg ] -- skip "Left"s and use the first "Right" image + where + rasterImage img = DImage (ImageRaster img) (dynamicMap imageWidth img) (dynamicMap imageHeight img) mempty + +-- | Load 2d formats given by a filepath and make a reference +loadImageExternal :: (InputConstraints b n, Renderable (DImage n External) b) + => FilePath -> IO (Either String (QDiagram b V2 n Any)) +loadImageExternal path = do + dImg <- readImage path +-- svgImg <- readSVGFile path + return $ msum [ fmap (image.rasterPath) dImg ] +-- svgImg ] -- skip "Left"s and use the first "Right" image + where + rasterPath img = DImage (ImageRef path) (dynamicMap imageWidth img) (dynamicMap imageHeight img) mempty +