wumpus-core 0.30.0 → 0.31.0

raw patch · 28 files changed

+1006/−434 lines, 28 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +74/−7
• demo/AffineTestBase.hs +4/−4
• demo/DeltaPic.hs +50/−0
• demo/FontMetrics.hs +6/−5
• demo/KernPic.hs +53/−0
• demo/LabelPic.hs +6/−6
• demo/Latin1Pic.hs +34/−0
• demo/MultiPic.hs +2/−2
• demo/Rotated.hs +2/−2
• demo/Scaled.hs +2/−2
• demo/Translated.hs +2/−2
• demo/ZOrderPic.hs +3/−3
• doc-src/Guide.lhs +5/−5
• doc-src/WorldFrame.hs +4/−4
• doc/Guide.pdf binary
• src/Wumpus/Core/FontSize.hs +1/−1
• src/Wumpus/Core/GraphicsState.hs +24/−22
• src/Wumpus/Core/OutputPostScript.hs +96/−84
• src/Wumpus/Core/OutputSVG.hs +123/−42
• src/Wumpus/Core/Picture.hs +296/−169
• src/Wumpus/Core/PictureInternal.hs +95/−17
• src/Wumpus/Core/PostScriptDoc.hs +6/−0
• src/Wumpus/Core/SVGDoc.hs +20/−0
• src/Wumpus/Core/TextEncoder.hs +8/−6
• src/Wumpus/Core/TextInternal.hs +43/−16
• src/Wumpus/Core/VersionNumber.hs +2/−2
• src/Wumpus/Core/WumpusTypes.hs +4/−1
• wumpus-core.cabal +41/−32

@@ -1,4 +1,78 @@ +0.30.0 to 0.31.0:++  * Extended the label type to optionally handle horizontal+    or vertical \"kerning\". This can be efficiently implemented +    in SVG.++  * Major API change - the Primitive constructors defined in +    @Core.PictureLanguage@ are no longer overloaded (@cstroke@, +    @ostroke@, @fill@, @textlabel@, @ellipse@). The respective +    classes (@Stroke@, @TextLabel@, @Ellipse@) have been removed+    and the constructors now have monomorphic types. This is +    because Wumpus-Core now only has one colour type and stroke+    attributes are now a single type, so polymorphism became+    less useful (and the simplicity of monomorphic types became+    more favourable). @ellipse@ is no longer a constructor +    instead there variants @fillEllipse@ and @strokeEllipse@.++  * Added support for /bordered/ closed paths - i.e. paths that+    are both stroked and filled. These can be efficiently drawn +    in SVG with a single @path@ element.++  * Changed StrokeAttr representation to be a regular data type+    rather than a list of /deltas/ - i.e. differences to the +    graphics state.++  * Added SVG font attribute /delta optimizations/ to help reduce +    SVG code size - via the @fontDeltaContext@ function in +    @Core.Picture@. This functionality was partially inplemented +    in the last release using the @GSUpdate@ datatype - this +    datatype it is now called @FontCtx@.++  * Some internal work documenting text encoding.++0.23.0 to 0.30.0:++  * Substantial changes - the output machinery has been heavily +    modified, the intention was to reduce the use of matrix +    transformations in SVG output. Though this goal has not been +    achieved, some code-size improvements in the SVG output have +    been made. ++  * The code generation monads have been changed - Wumpus no +    longer uses a writer monad for code generation, but it will+    keep the Wumpus name.++  * Added support for hyperlinks in the SVG output.++  * Improved internal pretty printing and added the function +    @printPicture@ for debugging.++  * The @Core.Colour@ module has been simplified to support just +    one (new) type - RGBi, and the conversion type class +    @PSColour@ has been eliminated.++  * @Core.Picture@ - the type of the @frame@ function has been +    changed to take a list of Primitives rather than a single +    Primitive. The function @frameMulti@ which previously +    provided this functionality has been removed. SVG hyperlinks+    are now supported for Primitives. + +  * The default font size has been changed to 14 pt. ++  * The Path datatype has been renamed PrimPath, likewise Ellipse +    is now PrimEllispe and Label becomes PrimLabel.++  * @Core.Geometry@ now longer defines an affine frame datatype.++  * @Core.BoundingBox@ module changed significantly. The corner +    functions (@boundaryBottomLeft@, etc.) have been removed, +    along with the plane functions (@leftPlane@, etc.). Some +    functions have been given more verbose names - @corners@ is +    now @boundaryCorners@, @within@ is now @withinBoundary@ and +    @union@ is now @boundaryUnion@. + 0.22.0 TO 0.23.0:     * @Basic.GraphicsState@ - extracted the font face fields from @@ -41,7 +115,6 @@    * Exposed the PSUnit type class.  - 0.20.0 to 0.21.0:    * Removed the Primitive instances of the Affine transformation @@ -70,7 +143,6 @@   * Removed the Ord superclass constriant from the @Stroke@ and     @Fill@ classes and derived operations (e.g. @zostroke@). - 0.19.0 to 0.20.0:      * Removed the modules:@@ -93,7 +165,6 @@      * Guide updated regarding the new package @wumpus-basic@.   - 0.18.0 to 0.19.0:      * Added @Transform@ type class to apply a matrix transformation@@ -149,7 +220,6 @@     missing with the generated file @WorldFrame.eps@ incorrectly      included instead. - 0.16.0 to 0.17.0:      * Added Core.WumpusTypes to export opaque versions of@@ -176,7 +246,6 @@      * Removed dependency on \'old-time\'. - 0.15.0 to 0.16.0:    * Additions to Core.Geometry (direction, pvec, vangle, @@ -216,12 +285,10 @@      * Removed DList dependency. - 0.13.0 to 0.13.1:    * Wumpus.Core.SVG changed path_s to path_c - \'S\' was the      wrongSVG command to match PostScript\'s @curveto@.-  0.12.0 to 0.13.0: 

@@ -110,16 +110,16 @@ --------------------------------------------------------------------------------
 
 rgbLabel :: RGBi -> DPrimitive
-rgbLabel rgb = textlabel rgb "Wumpus!" zeroPt
+rgbLabel rgb = textlabel rgb wumpus_default_font "Wumpus!" zeroPt
 
 rgbCircle :: RGBi -> DPrimitive
-rgbCircle rgb = ellipse rgb 60 60 zeroPt
+rgbCircle rgb = fillEllipse rgb 60 60 zeroPt
 
 rgbEllipse :: RGBi -> DPrimitive
-rgbEllipse rgb = ellipse rgb 60 30 zeroPt
+rgbEllipse rgb = fillEllipse rgb 60 30 zeroPt
 
 rgbPath :: RGBi -> DPrimitive
-rgbPath rgb = ostroke rgb $ dog_kennel
+rgbPath rgb = ostroke rgb default_stroke_attr $ dog_kennel
 --------------------------------------------------------------------------------
 -- Demo - draw a dog kennel...
 

@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++module DeltaPic where++import Wumpus.Core++import System.Directory+++peru :: RGBi+peru = RGBi 205  133  63++black :: RGBi+black = RGBi 0 0 0 +++++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/delta_pic01.eps" pic1+    writeSVG_latin1 "./out/delta_pic01.svg" pic1+++pic1 :: DPicture+pic1 = fontDeltaContext delta_ctx $ frame +          [ helveticaLabel 18 "Optimized - size and face"  (P2 0 60)+          , helveticaLabel 14 "Optimized - face only"      (P2 0 40)+          , courierLabel      "No optimization"            (P2 0 20)+          ]+  where+   delta_ctx  = FontAttr 18 common_ff+ ++common_ff :: FontFace+common_ff = FontFace "Helvetica" "Helvetica" SVG_REGULAR+++-- Note - each label is fully attributed with the font style.+-- There really is not attribute inheritance.+--+helveticaLabel :: Int -> String -> DPoint2 -> DPrimitive+helveticaLabel sz ss pt = textlabel peru attrs ss pt+  where+    attrs = FontAttr sz common_ff++courierLabel :: String -> DPoint2 -> DPrimitive+courierLabel ss pt = textlabel black wumpus_default_font ss pt

@@ -57,18 +57,19 @@ bodyHeight  = vertLine peru $ fromPtSize courier48_numeral_height  agraveU     :: PrimF-agraveU     = textlabel (black, courier_attr) "&#Agrave"+agraveU     = textlabel black courier_attr "&#Agrave"  letter :: Char -> DPoint2 -> DPrimitive-letter ch pt = textlabel (black, courier_attr) [ch] pt+letter ch pt = textlabel black courier_attr [ch] pt   vertLine :: RGBi -> Double -> DPoint2 -> DPrimitive-vertLine rgb height pt = ostroke rgb $ vertexPath [pt, pt .+^ vvec height]+vertLine rgb height pt = +    ostroke rgb default_stroke_attr $ vertexPath [pt, pt .+^ vvec height]  haxis :: RGBi -> PtSize -> DPrimitive haxis rgb ypos = -    ostroke (rgb, dash_attr) $ vertexPath [ pt, pt .+^ hvec 440 ]+    ostroke rgb dash_attr $ vertexPath [ pt, pt .+^ hvec 440 ]   where-    dash_attr = DashPattern (Dash 0 [(2,2)])+    dash_attr = default_stroke_attr { dash_pattern = Dash 0 [(2,2)] }     pt        = P2 0 (fromPtSize ypos)

@@ -0,0 +1,53 @@+{-# OPTIONS -Wall #-}++module KernPic where++import Wumpus.Core+import Wumpus.Core.Colour++import System.Directory++++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/kern_pic01.eps" kern_pic+    writeSVG_latin1 "./out/kern_pic01.svg" kern_pic+++kern_pic :: DPicture+kern_pic = pic1 `picOver` pic2++pic1 :: DPicture+pic1 = frame [ helveticaLabelH mystere   (P2 0 40)+             , helveticaLabelH mystere   (P2 0 20)+             ]++pic2 :: DPicture+pic2 = illustrateBoundsPrim blue_violet $ +          helveticaLabelV mystere   (P2 100 140)+++mystere ::[DKerningChar]+mystere = [ kernchar 0  'm'+          , kernchar 15 'y'+          , kernchar 10 's'+          , kernchar 10 't'+          , kernEscInt 6 232+          , kernchar 10 'r'+          , kernchar 6 'e'+          ]++helveticaLabelH :: [KerningChar Double] -> DPoint2 -> DPrimitive+helveticaLabelH xs pt = hkernlabel black helvetica18 xs pt++helveticaLabelV :: [KerningChar Double] -> DPoint2 -> DPrimitive+helveticaLabelV xs pt = vkernlabel black helvetica18 xs pt+++helvetica18 :: FontAttr+helvetica18 = FontAttr 18 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)++blue_violet             :: RGBi+blue_violet             = RGBi 0x8a 0x2b 0xe2

@@ -12,7 +12,7 @@   drawBounds :: (Floating u, Real u, FromPtSize u) => Picture u -> Picture u-drawBounds p        = p `picOver` (frame [cstroke () ph])+drawBounds p        = p `picOver` (frame [zcstroke ph])   where     ph            = vertexPath $ [bl,br,tr,tl]     (bl,br,tr,tl) = boundaryCorners $ boundary p@@ -41,9 +41,9 @@  lbl1 :: Picture Double lbl1 = line1 `picBeside` line2 where-  line1 = frame [textlabel attrs "Hello" zeroPt]-  line2 = frame [textlabel attrs "World" zeroPt]-  attrs = (peru, FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)) +  line1 = frame [textlabel peru attrs "Hello" zeroPt]+  line2 = frame [textlabel peru attrs "World" zeroPt]+  attrs = FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)   demo01 :: IO ()@@ -90,9 +90,9 @@ bigT = bigLetter plum  'T'  bigLetter :: RGBi -> Char -> Picture Double-bigLetter col ch = uniformScale 5 $ frame [textlabel attrs [ch] zeroPt]+bigLetter rgb ch = uniformScale 5 $ frame [textlabel rgb attrs [ch] zeroPt]   where-    attrs = (col, FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)) +    attrs = FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)   -- | A should be above B, above T

@@ -0,0 +1,34 @@+{-# OPTIONS -Wall #-}++module Latin1Pic where++import Wumpus.Core+import Wumpus.Core.Colour++import System.Directory++++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/latin1_pic01.eps" pic1+    writeSVG_latin1 "./out/latin1_pic01.svg" pic1+++-- | Provided the respective lookups can be found, Wumpus +-- supports escapes as either numbers or names...+--+pic1 :: DPicture+pic1 = frame [ helveticaLabel "mystère"      (P2 0 40)+             , helveticaLabel "myst&#egrave;re"   (P2 0 20)+             ]+ ++++helveticaLabel :: String -> DPoint2 -> DPrimitive+helveticaLabel ss pt = textlabel black helvetica18 ss pt++helvetica18 :: FontAttr+helvetica18 = FontAttr 18 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)

@@ -19,8 +19,8 @@  pic1 :: DPicture pic1 = uniformScale 2 $ frame $ -    [ ellipse blue 10 10 zeroPt-    , ellipse red 10 10 (P2 40 40)+    [ fillEllipse blue 10 10 zeroPt+    , fillEllipse red 10 10 (P2 40 40)     , ztextlabel "Wumpus!" (P2 40 20)     , square red 5 (P2 50 10)       ]

@@ -58,10 +58,10 @@   ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u-ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr+ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr   label :: Num u => RGBi -> Point2 u -> Primitive u-label rgb bl = textlabel rgb "Wumpus" bl+label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl   grey :: RGBi

@@ -51,10 +51,10 @@     [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen]  ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u-ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr+ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr   label :: Num u => RGBi -> Point2 u -> Primitive u-label rgb bl = textlabel rgb "Wumpus" bl+label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl   grey :: RGBi

@@ -46,10 +46,10 @@     [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen]  ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u-ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr+ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr   label :: Num u => RGBi -> Point2 u -> Primitive u-label rgb bl = textlabel rgb "Wumpus" bl+label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl   grey :: RGBi

@@ -28,8 +28,8 @@   prim_list :: DPoint2 -> [DPrimitive]-prim_list = sequence [ ellipse red   20 20-                     , \p -> ellipse green 20 20 (p .+^ hvec 20)-                     , \p -> ellipse blue  20 20 (p .+^ hvec 40)+prim_list = sequence [ fillEllipse red   20 20+                     , \p -> fillEllipse green 20 20 (p .+^ hvec 20)+                     , \p -> fillEllipse blue  20 20 (p .+^ hvec 40)                      ] 

@@ -95,11 +95,11 @@ 
 \item[\texttt{Wumpus.Core.Picture.}]
 Operations to build \emph{pictures} - paths and labels within
-an affine frame. Type classes overloading convenience 
-constructors for building paths, labels, ellipses... The 
-constructors are convenient in that attributes - colour, line
-width, etc. - may be specified or not. The technique is due to 
-Iavor S. Diatchki's XML-Light.
+an affine frame. Generally the functions here are convenience 
+constructors for types from the hidden module 
+\texttt{Wumpus.Core.PictureInternal}. The types from this
+module are exported as opaque signatures by 
+\texttt{Wumpus.Core.WumpusTypes}.
 
 \item[\texttt{Wumpus.Core.PtSize.}]
 Text size calculations in \texttt{Core.FontSize} use points 

@@ -27,11 +27,11 @@   makeLabelPrim :: String -> DPoint2 -> DPrimitive-makeLabelPrim = textlabel attrs +makeLabelPrim = textlabel black attrs    where-    attrs     = (black, FontAttr 10 (FontFace "Helvetica" "Helvetica" SVG_REGULAR))+    attrs     = FontAttr 10 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)  makeLinePrim :: Double -> DPoint2 -> DPoint2 -> DPrimitive-makeLinePrim lw a b = ostroke attrs $ path a [lineTo b]+makeLinePrim lw a b = ostroke black attrs $ path a [lineTo b]   where-    attrs = (black, [LineWidth lw])+    attrs = default_stroke_attr {line_width=lw}

binary file changed (56990 → 56526 bytes)

@@ -209,7 +209,7 @@ -- For variable width fonts the calculated bounding box will  -- usually be too long. ---textBounds :: (Fractional u, Ord u, FromPtSize u) +textBounds :: (Num u, Ord u, FromPtSize u)             => FontSize -> Point2 u -> CharCount -> BoundingBox u textBounds sz body_bl n = bbox bl tr where     h           = fromPtSize $ textHeight sz

@@ -56,8 +56,9 @@   , FontFace(..)   , SVGFontStyle(..) -  -- ** Default graphic state+  -- * Initial graphic state   , zeroGS+  , default_stroke_attr    ) where @@ -73,29 +74,23 @@       { gs_draw_colour  :: RGBi       , gs_font_size    :: Int       , gs_font_face    :: FontFace-      , gs_line_width   :: Double-      , gs_miter_limit  :: Double-      , gs_line_cap     :: LineCap-      , gs_line_join    :: LineJoin-      , gs_dash_pattern :: DashPattern +      , gs_stroke_attr  :: StrokeAttr        }   deriving (Eq,Show) ---- | Stroke attributes are an algebriac type rather than a --- record type. This is for convenience when attributing paths ---- paths can be attibuted with just the differences from the --- default settings, rather than all the settings whether or not--- they are important.+-- | Stroke attributes for drawing paths. ---data StrokeAttr = LineWidth   Double-                | MiterLimit  Double-                | LineCap     LineCap-                | LineJoin    LineJoin-                | DashPattern DashPattern +data StrokeAttr = StrokeAttr+      { line_width      :: Double+      , miter_limit     :: Double+      , line_cap        :: LineCap+      , line_join       :: LineJoin+      , dash_pattern    :: DashPattern+      }   deriving (Eq,Show)  + -- | Line cap - default in output is butt. -- data LineCap = CapButt | CapRound | CapSquare@@ -159,11 +154,18 @@ zeroGS = GraphicsState { gs_draw_colour  = black                        , gs_font_size    = (-1)                        , gs_font_face    = unmatchable_face-                       , gs_line_width   = 1-                       , gs_miter_limit  = 1-                       , gs_line_cap     = CapButt-                       , gs_line_join    = JoinMiter-                       , gs_dash_pattern = Solid+                       , gs_stroke_attr  = default_stroke_attr                        }   where     unmatchable_face = FontFace "DONT_MATCH" "" SVG_BOLD_OBLIQUE+++-- | Default stroke attributes.+--+default_stroke_attr :: StrokeAttr+default_stroke_attr = StrokeAttr { line_width      = 1+                                 , miter_limit     = 1+                                 , line_cap        = CapButt+                                 , line_join       = JoinMiter+                                 , dash_pattern    = Solid+                                 }

@@ -85,9 +85,9 @@     Just n  -> (Right n,s)     Nothing -> (Left $ ps_fallback r,s) -runLocalGS :: GSUpdate -> PsMonad a -> PsMonad a-runLocalGS upd mf = -    PsMonad $ \r s -> let (a,_) = getPsMonad mf r (getGSU upd s) in (a,s)+-- runLocalGS :: GSUpdate -> PsMonad a -> PsMonad a+-- runLocalGS upd mf = +--     PsMonad $ \r s -> let (a,_) = getPsMonad mf r (getGSU upd s) in (a,s)  getDrawColour       :: PsMonad RGBi getDrawColour       = PsMonad $ \_ s -> (gs_draw_colour s, s)@@ -107,38 +107,52 @@     getLineWidth        :: PsMonad Double-getLineWidth        = PsMonad $ \_ s -> (gs_line_width s, s)+getLineWidth        = PsMonad $ \_ s -> (line_width $ gs_stroke_attr s, s)  setLineWidth        :: Double -> PsMonad ()-setLineWidth a      = PsMonad $ \_ s -> ((), s { gs_line_width=a })-+setLineWidth a      = PsMonad $ \_ s -> +    ((), s { gs_stroke_attr = fn $ gs_stroke_attr s })+  where+    fn sa = sa { line_width = a }  getMiterLimit       :: PsMonad Double-getMiterLimit       = PsMonad $ \_ s -> (gs_miter_limit s,s)+getMiterLimit       = PsMonad $ \_ s -> (miter_limit $ gs_stroke_attr s,s)  setMiterLimit       :: Double -> PsMonad ()-setMiterLimit a     = PsMonad $ \_ s -> ((), s { gs_miter_limit=a })+setMiterLimit a     = PsMonad $ \_ s -> +    ((), s { gs_stroke_attr = fn $ gs_stroke_attr s })+  where+    fn sa = sa { miter_limit = a }   getLineCap          :: PsMonad LineCap-getLineCap          = PsMonad $ \_ s -> (gs_line_cap s,s)+getLineCap          = PsMonad $ \_ s -> (line_cap $ gs_stroke_attr s,s)  setLineCap          :: LineCap -> PsMonad ()-setLineCap a        = PsMonad $ \_ s -> ((), s { gs_line_cap=a })+setLineCap a        = PsMonad $ \_ s ->+    ((), s { gs_stroke_attr = fn $ gs_stroke_attr s })+  where+    fn sa = sa { line_cap = a }   getLineJoin         :: PsMonad LineJoin-getLineJoin         = PsMonad $ \_ s -> (gs_line_join s,s)+getLineJoin         = PsMonad $ \_ s -> (line_join $ gs_stroke_attr s,s)  setLineJoin         :: LineJoin -> PsMonad ()-setLineJoin a       = PsMonad $ \_ s -> ((), s { gs_line_join=a })+setLineJoin a       = PsMonad $ \_ s ->+    ((), s { gs_stroke_attr = fn $ gs_stroke_attr s })+  where+    fn sa = sa { line_join = a }   getDashPattern      :: PsMonad DashPattern-getDashPattern      = PsMonad $ \_ s -> (gs_dash_pattern s,s)+getDashPattern      = PsMonad $ \_ s -> (dash_pattern $ gs_stroke_attr s,s)  setDashPattern      :: DashPattern -> PsMonad ()-setDashPattern a    = PsMonad $ \_ s -> ((), s { gs_dash_pattern=a })+setDashPattern a    = PsMonad $ \_ s -> +    ((), s { gs_stroke_attr = fn $ gs_stroke_attr s })+  where+    fn sa = sa { dash_pattern = a }   --------------------------------------------------------------------------------@@ -237,13 +251,15 @@  -------------------------------------------------------------------------------- -+-- Note - PostScript ignotes any FontCtx changes via the @Group@+-- constructor.+-- picture :: (Real u, Floating u, PSUnit u) => Picture u -> PsMonad Doc picture (Leaf    (_,xs) ones)   = bracketTrafos xs $ revConcat primitive ones picture (Picture (_,xs) ones)   = bracketTrafos xs $ revConcat picture ones picture (Clip    (_,xs) cp pic) = bracketTrafos xs $                                     (vconcat <$> clipPath cp <*> picture pic)-picture (Group   (_,xs) fn pic) = bracketTrafos xs (runLocalGS fn (picture pic))+picture (Group   (_,xs) _ pic) = bracketTrafos xs (picture pic)   revConcat :: (a -> PsMonad Doc) -> OneList a -> PsMonad Doc@@ -310,10 +326,10 @@ primEllipse props (PrimEllipse center hw hh ctm) =     bracketPrimCTM center (scaleCTM 1 (hh/hw) ctm) (drawF props)   where-    drawF (EFill rgb)               pt = fillArcPath rgb hw pt-    drawF (EStroke attrs rgb)       pt = strokeArcPath rgb attrs hw pt-    drawF (EFillStroke fc attrs sc) pt = -        vconcat <$> fillArcPath fc hw pt <*>  strokeArcPath sc attrs hw pt+    drawF (EFill rgb)            pt = fillArcPath rgb hw pt+    drawF (EStroke sa rgb)       pt = strokeArcPath rgb sa hw pt+    drawF (EFillStroke fc sa sc) pt = +        vconcat <$> fillArcPath fc hw pt <*>  strokeArcPath sc sa hw pt                          @@ -329,15 +345,15 @@       <$> deltaDrawColour rgb  strokeArcPath :: PSUnit u -              => RGBi -> [StrokeAttr] -> u -> Point2 u -> PsMonad Doc-strokeArcPath rgb attrs radius pt =+              => RGBi -> StrokeAttr -> u -> Point2 u -> PsMonad Doc+strokeArcPath rgb sa radius pt =     (\rgbd attrd -> vcat [ rgbd                          , attrd                          , ps_newpath                          , ps_arc pt radius 0 360                          , ps_closepath                          , ps_stroke ])-      <$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs+      <$> deltaDrawColour rgb <*> deltaStrokeAttrs sa   -- Note - for the otherwise case, the x-and-y coordinates are @@ -345,24 +361,56 @@ -- primLabel :: (Real u, Floating u, PSUnit u)            => LabelProps -> PrimLabel u -> PsMonad Doc-primLabel (LabelProps rgb font) (PrimLabel basept txt ctm) = +primLabel (LabelProps rgb font) (PrimLabel basept body ctm) =      bracketPrimCTM basept ctm mf   where-    mf pt = (\rgbd fontd showd -> vcat [ rgbd, fontd, ps_moveto pt, showd ]) +    mf pt = (\rgbd fontd showd -> vcat [ rgbd, fontd, showd ])                <$> deltaDrawColour rgb <*> deltaFontAttrs font -                                      <*> encodedText txt+                                      <*> labelBody pt body +labelBody :: PSUnit u => Point2 u -> LabelBody u -> PsMonad Doc+labelBody pt (StdLayout txt) = (\d1 -> ps_moveto pt `vconcat` d1) +                                 <$> encodedText txt+labelBody pt (KernTextH xs)  = kernTextH pt xs+labelBody pt (KernTextV xs)  = kernTextV pt xs++ encodedText :: EncodedText -> PsMonad Doc  encodedText etext = vcat <$> (mapM textChunk $ getEncodedText etext)   textChunk :: TextChunk -> PsMonad Doc-textChunk (SText s)  = pure (ps_show $ escapeSpecial s)-textChunk (EscStr s) = pure (ps_glyphshow s)-textChunk (EscInt i) = (either failk ps_glyphshow) <$> askCharCode i +textChunk (TextSpan s)    = pure (ps_show $ escapeSpecial s)+textChunk (TextEscName s) = pure (ps_glyphshow s)+textChunk (TextEscInt i)  = (either failk ps_glyphshow) <$> askCharCode i    where     failk gly_name = missingCharCode i gly_name +kernTextH :: PSUnit u => Point2 u -> [KerningChar u] -> PsMonad Doc+kernTextH pt0 xs = snd <$> F.foldlM fn (pt0,empty) xs+  where+    fn (P2 x y,acc) (dx,ch) = (\doc1 -> let pt = P2 (x+dx) y in+                                        (pt, vcat [acc, ps_moveto pt, doc1]))+                                <$> encodedChar ch++-- Note - vertical labels grow downwards...+--+kernTextV :: PSUnit u => Point2 u -> [KerningChar u] -> PsMonad Doc+kernTextV pt0 xs = snd <$> F.foldlM fn (pt0,empty) xs+  where+    fn (P2 x y,acc) (dy,ch) = (\doc1 -> let pt = P2 x (y-dy) in+                                        (pt, vcat [acc, ps_moveto pt, doc1]))+                                <$> encodedChar ch+++encodedChar :: EncodedChar -> PsMonad Doc+encodedChar (CharLiteral c) = pure (ps_show $ escapeSpecialChar c)+encodedChar (CharEscName s) = pure (ps_glyphshow s)+encodedChar (CharEscInt i)  = (either failk ps_glyphshow) <$> askCharCode i +  where+    failk gly_name = missingCharCode i gly_name++ -------------------------------------------------------------------------------- -- Stroke, font and drawing colour attribute delta @@ -389,74 +437,38 @@                else setDrawColour rgb >> return (ps_setrgbcolor rgb)  --- Note - the current way of handling Stroke Deltas for --- PostScript uses an awful lot of operations. --- --- The GraphicsState data types need some more thought -----data StrokeDelta = StrokeDelta-      { sd_line_width   :: Double-      , sd_miter_limit  :: Double-      , sd_line_cap     :: LineCap-      , sd_line_join    :: LineJoin-      , sd_dash_pattern :: DashPattern-      }---- | Note - the values here must be in- sync with zeroGS.----zeroSD :: StrokeDelta-zeroSD = StrokeDelta { sd_line_width   = 1-                     , sd_miter_limit  = 1-                     , sd_line_cap     = CapButt-                     , sd_line_join    = JoinMiter-                     , sd_dash_pattern = Solid-                     }---makeStrokeDelta :: [StrokeAttr] -> StrokeDelta-makeStrokeDelta = foldr fn zeroSD-  where-    fn (LineWidth a)    sd = sd { sd_line_width = a }-    fn (MiterLimit a)   sd = sd { sd_miter_limit = a }-    fn (LineCap a)      sd = sd { sd_line_cap = a }-    fn (LineJoin a)     sd = sd { sd_line_join = a }-    fn (DashPattern a)  sd = sd { sd_dash_pattern = a} ---deltaStrokeAttrs :: [StrokeAttr] -> PsMonad Doc-deltaStrokeAttrs xs = step $ makeStrokeDelta xs+deltaStrokeAttrs :: StrokeAttr -> PsMonad Doc+deltaStrokeAttrs sa = +    (\d1 d2 d3 d4 d5 -> hcat $ catMaybes [d1,d2,d3,d4,d5])  +      <$> lw <*> ml <*> lc <*> lj <*> dp   where-    step sd = (\d1 d2 d3 d4 d5 -> hcat $ catMaybes [d1,d2,d3,d4,d5])  -                <$> lw sd <*> ml sd <*> lc sd <*> lj sd <*> dp sd--    lw sd = let d = sd_line_width sd in -            getLineWidth >>= \inh -> -            if d == inh +    lw = let d = line_width sa in +         getLineWidth >>= \inh -> +         if d == inh                then return Nothing                else setLineWidth d >> return (Just $ ps_setlinewidth d) -    ml sd = let d = sd_miter_limit sd in -            getMiterLimit >>= \inh -> -            if d==inh +    ml = let d = miter_limit sa in +         getMiterLimit >>= \inh -> +         if d==inh                then return Nothing                else setMiterLimit d >> return (Just $ ps_setmiterlimit d)                             -    lc sd = let d = sd_line_cap sd in-            getLineCap >>= \inh -> -            if d==inh +    lc = let d = line_cap sa in+         getLineCap >>= \inh -> +         if d==inh                then return Nothing               else setLineCap d >> return (Just $ ps_setlinecap d)                       -    lj sd = let d = sd_line_join sd in -            getLineJoin >>= \inh -> -            if d==inh +    lj = let d = line_join sa in +         getLineJoin >>= \inh -> +         if d==inh                then return Nothing               else setLineJoin d >> return (Just $ ps_setlinejoin d) -    dp sd  = let d = sd_dash_pattern sd in-             getDashPattern >>= \inh -> -             if d==inh +    dp = let d = dash_pattern sa in+         getDashPattern >>= \inh -> +         if d==inh                 then return Nothing                else setDashPattern d >> return (Just $ ps_setdash d) 

@@ -56,6 +56,7 @@  import Control.Applicative hiding ( empty, some ) import qualified Data.Foldable as F+import Data.Maybe  -- SvgMonad is two Readers plus Int state for clip paths... --@@ -96,29 +97,35 @@ -- (and /graphics state/ is via a Reader), so it is the same as  -- local with a Reader monad. ---runLocalGS :: GSUpdate -> SvgMonad a -> SvgMonad a+runLocalGS :: (GraphicsState -> GraphicsState) -> SvgMonad a -> SvgMonad a runLocalGS upd mf = -    SvgMonad $ \r1 r2 s -> getSvgMonad mf r1 (getGSU upd r2) s+    SvgMonad $ \r1 r2 s -> getSvgMonad mf r1 (upd r2) s  +askGraphicsState :: SvgMonad GraphicsState+askGraphicsState = SvgMonad $ \_ r2 s -> (r2,s)++asksGraphicsState :: (GraphicsState -> a) -> SvgMonad a+asksGraphicsState fn = SvgMonad $ \_ r2 s -> (fn r2,s)+ askFontAttr :: SvgMonad FontAttr askFontAttr = -    SvgMonad $ \_ r2 s -> (FontAttr (gs_font_size r2) (gs_font_face r2), s)+    asksGraphicsState $ \r -> FontAttr (gs_font_size r) (gs_font_face r)  askLineWidth    :: SvgMonad Double-askLineWidth    = SvgMonad $ \_ r2 s -> (gs_line_width r2, s)+askLineWidth    = asksGraphicsState (line_width . gs_stroke_attr)  askMiterLimit   :: SvgMonad Double-askMiterLimit   = SvgMonad $ \_ r2 s -> (gs_miter_limit r2, s)+askMiterLimit   = asksGraphicsState (miter_limit . gs_stroke_attr)  askLineCap      :: SvgMonad LineCap-askLineCap      = SvgMonad $ \_ r2 s -> (gs_line_cap r2, s)+askLineCap      = asksGraphicsState (line_cap . gs_stroke_attr)  askLineJoin     :: SvgMonad LineJoin-askLineJoin     = SvgMonad $ \_ r2 s -> (gs_line_join r2, s)+askLineJoin     = asksGraphicsState (line_join . gs_stroke_attr)  askDashPattern  :: SvgMonad DashPattern-askDashPattern  = SvgMonad $ \_ r2 s -> (gs_dash_pattern r2, s)+askDashPattern  = asksGraphicsState (dash_pattern . gs_stroke_attr)  -------------------------------------------------------------------------------- @@ -170,7 +177,7 @@                           ; d2  <- picture pic                           ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2))                           } -picture (Group   (_,xs) fn pic) = bracketTrafos xs (runLocalGS fn (picture pic))+picture (Group   (_,xs) fn pic) = bracketTrafos xs $ bracketGS fn (picture pic)   @@ -275,53 +282,105 @@  primLabel :: (Real u, Floating u, PSUnit u)        => LabelProps -> PrimLabel u -> SvgMonad Doc-primLabel (LabelProps rgb attrs) (PrimLabel pt etext ctm) = -    (\fa ca txt -> elem_text (fa <+> ca) txt)-      <$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm mkXY -                               <*> tspan rgb etext-  where-    mkXY (P2 x y) = pure $ attr_x x <+> attr_y y    +primLabel (LabelProps rgb attrs) (PrimLabel pt body ctm) = +    (\fa ca dtxt -> elem_text (fa <+> ca) (makeTspan rgb dtxt))+      <$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm (labelBodyCoords body)+                               <*> labelBodyText body+     -tspan :: RGBi -> EncodedText -> SvgMonad Doc-tspan rgb enctext = -    (\txt -> elem_tspan (attr_fill rgb) txt) -      <$> encodedText enctext +labelBodyCoords :: PSUnit u => LabelBody u -> Point2 u -> SvgMonad Doc+labelBodyCoords (StdLayout _)  pt = pure $ makeXY pt+labelBodyCoords (KernTextH xs) pt = pure $ makeXsY pt xs        +labelBodyCoords (KernTextV xs) pt = pure $ makeXYs pt xs++labelBodyText :: LabelBody u -> SvgMonad Doc+labelBodyText (StdLayout enctext) = encodedText enctext+labelBodyText (KernTextH xs)      = hcat <$> mapM kerningChar xs+labelBodyText (KernTextV xs)      = hcat <$> mapM kerningChar xs++ encodedText :: EncodedText -> SvgMonad Doc encodedText enctext = hcat <$> mapM textChunk (getEncodedText enctext) - textChunk :: TextChunk -> SvgMonad Doc-textChunk (SText s)  = pure $ text s-textChunk (EscInt i) = pure $ text $ escapeSpecial i-textChunk (EscStr s) = either text text <$> askGlyphName s +textChunk (TextSpan s)    = pure $ text s+textChunk (TextEscInt i)  = pure $ text $ escapeSpecial i+textChunk (TextEscName s) = either text text <$> askGlyphName s  +kerningChar :: KerningChar u -> SvgMonad Doc+kerningChar (_, CharLiteral c) = pure $ char c+kerningChar (_, CharEscInt i)  = pure $ text $ escapeSpecial i+kerningChar (_, CharEscName s) = either text text <$> askGlyphName s  ++makeTspan :: RGBi -> Doc -> Doc+makeTspan rgb body = elem_tspan (attr_fill rgb) body++makeXY :: PSUnit u => Point2 u -> Doc+makeXY (P2 x y) = attr_x x <+> attr_y y++-- This is for horizontal kerning text, the output is of the +-- form:+-- +-- > x="0 10 25 35" y="0"+--+makeXsY :: PSUnit u => Point2 u -> [KerningChar u] -> Doc+makeXsY (P2 x y) ks = attr_xs (step x ks) <+> attr_y y+  where +    step ax ((d,_):ds) = let a = ax+d in a : step a ds +    step _  []         = []+++-- This is for vertical kerning text, the output is of the +-- form:+-- +-- > x="0 0 0 0" y="0 10 25 35"+--+-- Note - this is different to the horizontal version as the +-- x-coord needs to be /realigned/ at each step.+--+makeXYs :: PSUnit u => Point2 u -> [KerningChar u] -> Doc+makeXYs (P2 x y) ks = attr_xs xcoords <+> attr_ys (step y ks)+  where +    xcoords            = replicate (length ks) x+    step ay ((d,_):ds) = let a = ay+d in a : step a ds +    step _  []         = []+    +    + -------------------------------------------------------------------------------- -- Stroke and font attribute delta -deltaStrokeAttrs :: [StrokeAttr] -> SvgMonad Doc-deltaStrokeAttrs xs = hsep <$> mapM df xs+deltaStrokeAttrs :: StrokeAttr -> SvgMonad Doc+deltaStrokeAttrs sa = +    (\d1 d2 d3 d4 d5 -> hsep $ catMaybes [d1,d2,d3,d4,d5])  +      <$> lw <*> ml <*> lc <*> lj <*> dp   where-    df (LineWidth d)    = (\inh -> if d==inh then empty -                                         else attr_stroke_width d) -                            <$> askLineWidth--    df (MiterLimit d)   = (\inh -> if d==inh then empty -                                         else attr_stroke_miterlimit d)-                            <$> askMiterLimit+    lw = let d = line_width sa in+         askLineWidth >>= \inh -> +         if d==inh then return Nothing +                   else return (Just $ attr_stroke_width d) +         +    ml = let d = miter_limit sa in+         askMiterLimit >>= \inh -> +         if d==inh then return Nothing +                   else return (Just $ attr_stroke_miterlimit d) -    df (LineCap d)      = (\inh -> if d==inh then empty -                                         else attr_stroke_linecap d)-                            <$> askLineCap+    lc = let d = line_cap sa in+         askLineCap >>= \inh -> +         if d==inh then return Nothing +                   else return (Just $ attr_stroke_linecap d) -    df (LineJoin d)     = (\inh -> if d==inh then empty -                                         else attr_stroke_linejoin d)-                            <$> askLineJoin+    lj = let d = line_join sa in+         askLineJoin >>= \inh -> +         if d==inh then return Nothing +                   else return (Just $ attr_stroke_linejoin d) -    df (DashPattern d)  = (\inh -> if d==inh then empty -                                             else makeDashPattern d) -                            <$> askDashPattern+    dp = let d = dash_pattern sa in +         askDashPattern >>= \inh -> +         if d==inh then return Nothing +                   else return (Just $ makeDashPattern d)   makeDashPattern :: DashPattern -> Doc makeDashPattern Solid       = attr_stroke_dasharray_none@@ -331,7 +390,7 @@   deltaFontAttrs :: FontAttr -> SvgMonad Doc-deltaFontAttrs fa  = +deltaFontAttrs fa =      (\inh -> if fa ==inh then empty else makeFontAttrs fa) <$> askFontAttr  makeFontAttrs :: FontAttr -> Doc@@ -353,6 +412,28 @@     suffix SVG_BOLD_OBLIQUE =          space <> attr_font_weight "bold" <+> attr_font_style "oblique" ++-- NOTE - as is only practical to delta the FontFace attributes +-- it might be good to specialize / simplify the graphics state+-- GSUpdate to a simpler type rather than a functional one...++bracketGS :: FontCtx -> SvgMonad Doc -> SvgMonad Doc+bracketGS (FontCtx new_font) mf = +    (\old body -> mkElem old body) +        <$> askGraphicsState <*> runLocalGS updateF mf+  where+    mkElem old body +      | fontMatch old new_font = elem_g_no_attrs body+      | otherwise              = let a = makeFontAttrs new_font+                                 in elem_g a body++    updateF s = s { gs_font_size = font_size new_font+                  , gs_font_face = font_face new_font }+                ++fontMatch :: GraphicsState -> FontAttr -> Bool+fontMatch gs fa = +   gs_font_size gs == font_size fa && gs_font_face gs == font_face fa   --------------------------------------------------------------------------------

@@ -23,6 +23,7 @@   -- * Construction     frame   , multi+  , fontDeltaContext   , path   , lineTo   , curveTo@@ -31,19 +32,42 @@   , xlinkhref    -- * Constructing primitives-  , Stroke(..)+  , ostroke+  , cstroke+  , xostroke+  , xcstroke   , zostroke   , zcstroke-  , Fill(..)++  , fill+  , xfill   , zfill-  , Ellipse(..)-  , zellipse +  , bordered+  , xbordered   , clip -  , TextLabel(..)+  , textlabel+  , xtextlabel   , ztextlabel+  , wumpus_default_font +  , hkernlabel+  , vkernlabel+  , xhkernlabel+  , xvkernlabel+  , kernchar+  , kernEscInt+  , kernEscName++  , strokeEllipse+  , fillEllipse+  , xstrokeEllipse+  , xfillEllipse+  , zellipse+  , borderedEllipse+  +   -- * Operations   , extendBoundary   @@ -63,7 +87,7 @@ import Wumpus.Core.AffineTrans import Wumpus.Core.BoundingBox import Wumpus.Core.Colour-import Wumpus.Core.FormatCombinators+import Wumpus.Core.FormatCombinators hiding ( fill ) import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState import Wumpus.Core.OneList@@ -112,7 +136,38 @@                     in ( boundary a `append` bb', cons a rest )  +-- | Update the font /delta/ attributes for SVG output.+--+-- Note - 'fontDeltaContext' does not set the font properties of+-- elements in the supplied Picture, it is solely a mechanism to+-- help reduce the code size of the generated SVG by factoring +-- common attributes into a group (g) element. For instance, +-- settting the font properties with 'fontDeltaContext' can +-- eliminate the repeated use of font-family and font-size in +-- this code:+--+-- > <text font-family="Helvetica" font-size="12"> ... </text>+-- > <text font-family="Helvetica" font-size="12"> ... </text>+-- > <text font-family="Helvetica" font-size="12"> ... </text>+--+-- With the appropriate font delta context, this code will be+-- generated:+-- +-- > <g font-family="Helvetica" font-size="12">+-- >   <text > ... </text>+-- >   <text > ... </text>+-- >   <text > ... </text>+-- > </g>+--+-- Wumpus ignores 'fontDeltaContext' directives when generating +-- PostScript. Unlike SVG, PostScript is not naturally nested, so +-- introducing nesting with @gsave@ and @grestore@ is not likely+-- to improve the PostScript Wumpus generates.+--+fontDeltaContext :: FontAttr -> Picture u -> Picture u+fontDeltaContext fa p = Group (boundary p, []) (FontCtx fa) p + -- | Create a Path from a start point and a list of PathSegments. -- path :: Point2 u -> [PrimPathSegment u] -> PrimPath u@@ -151,119 +206,108 @@     step _          = []  +-- | Create a hyperlink for SVG output.+-- xlinkhref :: String -> XLink xlinkhref = XLinkHRef ++ -------------------------------------------------------------------------------- -- Take Paths to Primitives  -- *** Stroke -ostrokePath :: Num u -            => RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u-ostrokePath rgb attrs xlink p = PPath (OStroke attrs rgb) xlink p+-- | Create a open, stroked path.+--+ostroke :: Num u +        => RGBi -> StrokeAttr -> PrimPath u -> Primitive u+ostroke rgb sa p = PPath (OStroke sa rgb) NoLink p -cstrokePath :: Num u -            => RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u-cstrokePath rgb attrs xlink p = PPath (CStroke attrs rgb) xlink p --- | Create a open, stroked path (@ostroke@) or a closed, stroked--- path (@cstroke@).+-- | Create a closed, stroked path. ----- @ostroke@ and @cstroke@ are overloaded to make attributing --- the path more convenient.--- -class Stroke t where-  ostroke :: Num u => t -> PrimPath u -> Primitive u-  cstroke :: Num u => t -> PrimPath u -> Primitive u+cstroke :: Num u +        => RGBi -> StrokeAttr -> PrimPath u -> Primitive u+cstroke rgb sa p = PPath (CStroke sa rgb) NoLink p -instance Stroke () where-  ostroke () = ostrokePath black [] NoLink-  cstroke () = cstrokePath black [] NoLink+-- | Create a open, stroked path with a hyperlink.+--+-- Note - hyperlinks are only rendered in SVG output.+--+xostroke :: Num u +         => RGBi -> StrokeAttr -> XLink -> PrimPath u -> Primitive u+xostroke rgb sa xlink p = PPath (OStroke sa rgb) xlink p -instance Stroke RGBi where-  ostroke rgb = ostrokePath rgb [] NoLink-  cstroke rgb = cstrokePath rgb [] NoLink -instance Stroke StrokeAttr where-  ostroke x = ostrokePath black [x] NoLink-  cstroke x = cstrokePath black [x] NoLink+-- | Create a closed, stroked path with a hyperlink.+--+--  Note - hyperlinks are only rendered in SVG output.+--+xcstroke :: Num u +         => RGBi -> StrokeAttr -> XLink -> PrimPath u -> Primitive u+xcstroke rgb sa xlink p = PPath (CStroke sa rgb) xlink p -instance Stroke [StrokeAttr] where-  ostroke xs = ostrokePath black xs NoLink-  cstroke xs = cstrokePath black xs NoLink -instance Stroke XLink where-  ostroke xlink = ostrokePath black [] xlink-  cstroke xlink = cstrokePath black [] xlink  -instance Stroke (RGBi,StrokeAttr) where-  ostroke (rgb,x) = ostrokePath rgb [x] NoLink-  cstroke (rgb,x) = cstrokePath rgb [x] NoLink+-- | Create an open, stroked path using the default stroke +-- attributes and coloured black.+--+zostroke :: Num u => PrimPath u -> Primitive u+zostroke = ostroke black default_stroke_attr+ +-- | Create a closed stroked path using the default stroke +-- attributes and coloured black.+--+zcstroke :: Num u => PrimPath u -> Primitive u+zcstroke = cstroke black default_stroke_attr -instance Stroke (RGBi,[StrokeAttr]) where-  ostroke (rgb,xs) = ostrokePath rgb xs NoLink-  cstroke (rgb,xs) = cstrokePath rgb xs NoLink+--------------------------------------------------------------------------------+-- *** Fill -instance Stroke (RGBi,XLink) where-  ostroke (rgb,xlink) = ostrokePath rgb [] xlink-  cstroke (rgb,xlink) = cstrokePath rgb [] xlink -instance Stroke (StrokeAttr,XLink) where-  ostroke (x,xlink) = ostrokePath black [x] xlink-  cstroke (x,xlink) = cstrokePath black [x] xlink--instance Stroke ([StrokeAttr],XLink) where-  ostroke (xs,xlink) = ostrokePath black xs xlink-  cstroke (xs,xlink) = cstrokePath black xs xlink--instance Stroke (RGBi,StrokeAttr,XLink) where-  ostroke (rgb,x,xlink) = ostrokePath rgb [x] xlink-  cstroke (rgb,x,xlink) = cstrokePath rgb [x] xlink--instance Stroke (RGBi,[StrokeAttr],XLink) where-  ostroke (rgb,xs,xlink) = ostrokePath rgb xs xlink-  cstroke (rgb,xs,xlink) = cstrokePath rgb xs xlink+-- | Create a filled path.+--+fill :: Num u => RGBi -> PrimPath u -> Primitive u+fill rgb p = PPath (CFill rgb) NoLink p  --- | Create an open stoke coloured black.+-- | Create a filled path with a hyperlink. ---zostroke :: Num u => PrimPath u -> Primitive u-zostroke = ostrokePath black [] NoLink- --- | Create a closed stroke coloured black.+--  Note - hyperlinks are only rendered in SVG output. ---zcstroke :: Num u => PrimPath u -> Primitive u-zcstroke = cstrokePath black [] NoLink+xfill :: Num u => RGBi -> XLink -> PrimPath u -> Primitive u+xfill rgb xlink p = PPath (CFill rgb) xlink p +-- | Create a filled path coloured black. +zfill :: Num u => PrimPath u -> Primitive u+zfill = fill black --- *** Fill -fillPath :: Num u => RGBi -> XLink -> PrimPath u -> Primitive u-fillPath rgb xlink p = PPath (CFill rgb) xlink p+--------------------------------------------------------------------------------+-- Bordered (closed) paths --- | Create a filled path (@fill@). Fills only have one --- property - colour. But there are various representations of --- colour.++-- | Create a closed path that is both filled and stroked (the fill+-- is below in the zorder). ----- @ fill () @ will fill with the default colour - black.--- -class Fill t where-  fill :: Num u => t -> PrimPath u -> Primitive u- +-- > fill colour * stroke attrs * stroke_colour * ...+--+bordered :: Num u +        => RGBi -> StrokeAttr -> RGBi -> PrimPath u -> Primitive u+bordered frgb sa srgb p = PPath (CFillStroke frgb sa srgb) NoLink p -instance Fill ()                where fill ()    = fillPath black NoLink-instance Fill RGBi              where fill rgb   = fillPath rgb   NoLink-instance Fill XLink             where fill xlink = fillPath black xlink -instance Fill (RGBi,XLink) where-  fill (rgb,xlink) = fillPath rgb xlink+-- | Create a bordered, closed path with a hyperlink.+--+--  Note - hyperlinks are only rendered in SVG output.+--+xbordered :: Num u +        => RGBi -> StrokeAttr -> RGBi -> XLink -> PrimPath u -> Primitive u+xbordered frgb sa srgb xlink p = PPath (CFillStroke frgb sa srgb) xlink p  --- | Create a filled path coloured black. -zfill :: Num u => PrimPath u -> Primitive u-zfill = fillPath black NoLink  -------------------------------------------------------------------------------- -- Clipping @@ -276,12 +320,37 @@ -------------------------------------------------------------------------------- -- Labels to primitive -mkTextLabel :: Num u -            => RGBi -> FontAttr -> XLink -> String -> Point2 u -> Primitive u-mkTextLabel rgb attr xlink txt pt = PLabel (LabelProps rgb attr) xlink lbl +-- | Create a text label. The string should not contain newline+-- or tab characters.+--+-- The supplied point is the left baseline.+--+textlabel :: Num u +          => RGBi -> FontAttr -> String -> Point2 u -> Primitive u+textlabel rgb attr txt = xtextlabel rgb attr NoLink txt +++-- | Create a text label with a hyperlink. The string should not +-- contain newline or tab characters.+--+-- The supplied point is the left baseline.+--+-- Note - hyperlinks are only rendered in SVG output.+--+xtextlabel :: Num u +           => RGBi -> FontAttr -> XLink -> String -> Point2 u -> Primitive u+xtextlabel rgb attr xlink txt pt = PLabel (LabelProps rgb attr) xlink lbl    where-    lbl = PrimLabel pt (lexLabel txt) identityCTM+    lbl = PrimLabel pt (StdLayout $ lexLabel txt) identityCTM ++-- | Create a label where the font is @Courier@, text size is 14pt+-- and colour is black.+--+ztextlabel :: Num u => String -> Point2 u -> Primitive u+ztextlabel = xtextlabel black wumpus_default_font NoLink++ -- | Constant for the default font, which is @Courier@ (aliased  -- to @Courier New@ for SVG) at 14 point. --@@ -294,124 +363,180 @@                     , svg_font_style    = SVG_REGULAR                     } +-------------------------------------------------------------------------------- --- | Create a text label. The string should not contain newline--- or tab characters. Use 'multilabel' to create text with --- multiple lines.--- --- @textlabel@ is overloaded to make attributing the label more --- convenient.+-- | Create a text label with horizontal /kerning/ for each +-- character.  ----- Unless a 'FontAttr' is specified, the label will use 14pt --- Courier.+-- Note - kerning is relative to the left baseline of the +-- previous character, it is \*not relative\* to the right-hand+-- boundary of the previous char. While the later would be more+-- obvious it would take a lot of effort to implement as it would +-- need access to the metrics encoded in font files.  ----- The supplied point is is the bottom left corner.+-- Characters are expected to be drawn left to right, so +-- displacements should not be negative. If the displacement is+-- zero the character will be drawn ontop of the previous char.+-- +-- The charcters should not contain newline or tab characters. ---class TextLabel t where -  textlabel :: Num u => t -> String -> Point2 u -> Primitive u+-- The supplied point is the left baseline.+--+hkernlabel :: Num u +            => RGBi -> FontAttr -> [KerningChar u] -> Point2 u +            -> Primitive u+hkernlabel rgb attr xs = xhkernlabel rgb attr NoLink xs   -instance TextLabel () where -    textlabel () = mkTextLabel black wumpus_default_font NoLink+ +-- | Create a horizontally kerned text label with a hyperlink.+--+-- The is the hyperlink version of 'hkernlabel'.+--+-- Note - hyperlinks are only rendered in SVG output.+--+xhkernlabel :: Num u +            => RGBi -> FontAttr -> XLink -> [KerningChar u] -> Point2 u +            -> Primitive u+xhkernlabel rgb attr xlink xs pt = PLabel (LabelProps rgb attr) xlink lbl +  where+    lbl = PrimLabel pt (KernTextH xs) identityCTM -instance TextLabel RGBi where-  textlabel rgb = mkTextLabel rgb wumpus_default_font NoLink -instance TextLabel FontAttr where-  textlabel a = mkTextLabel black a NoLink -instance TextLabel XLink where-    textlabel xlink = mkTextLabel black wumpus_default_font xlink+-- | Create a text label with vertical /kerning/ for each +-- character - the text is expected to grow downwards. +--+-- Note - /kerning/ here is the measure between baselines of +-- sucessive characters, it is \*not\* the distance between the +-- bottom of one chararter and the top of the next character.+-- +-- While the later maybe be more obvious from a drawing +-- perspective, it would take a lot of effort to implement as it +-- would need access to the metrics encoded in font files. +--+-- Characters are expected to be drawn downwards - a positive +-- number represents the downward displacement - so displacements +-- should not be negative. If the displacement is zero the +-- character will be drawn ontop of the previous char.+-- +-- The charcters should not contain newline or tab characters.+--+-- The supplied point is the left baseline of the top character.+--+vkernlabel :: Num u +            => RGBi -> FontAttr ->[KerningChar u] -> Point2 u +            -> Primitive u+vkernlabel rgb attr xs = xvkernlabel rgb attr NoLink xs   -instance TextLabel (RGBi,FontAttr) where-  textlabel (rgb,a) = mkTextLabel rgb a NoLink+-- | Create a vertically drawn text label with a hyperlink.+--+-- The is the hyperlink version of 'vkernlabel'.+--+-- Note - hyperlinks are only rendered in SVG output.+--+xvkernlabel :: Num u +            => RGBi -> FontAttr -> XLink -> [KerningChar u] -> Point2 u +            -> Primitive u+xvkernlabel rgb attr xlink xs pt = PLabel (LabelProps rgb attr) xlink lbl +  where+    lbl = PrimLabel pt (KernTextV xs) identityCTM -instance TextLabel (RGBi,XLink) where-  textlabel (rgb,xlink) = mkTextLabel rgb wumpus_default_font xlink -instance TextLabel (FontAttr,XLink) where-  textlabel (a,xlink) = mkTextLabel black a xlink -instance TextLabel (RGBi,FontAttr,XLink) where-  textlabel (rgb,a,xlink) = mkTextLabel rgb a xlink+-- | Construct a regular (i.e. non-special) Char along with its +-- displacement from the left-baseline of the previous Char.+--+kernchar :: u -> Char -> KerningChar u+kernchar u c = (u, CharLiteral c) --- | Create a label where the font is @Courier@, text size is 14pt--- and colour is black.+-- | Construct a Char by its character code along with its +-- displacement from the left-baseline of the previous Char. ---ztextlabel :: Num u => String -> Point2 u -> Primitive u-ztextlabel = mkTextLabel black wumpus_default_font NoLink+kernEscInt :: u -> Int -> KerningChar u+kernEscInt u i = (u, CharEscInt i) +-- | Construct a Char by its character name along with its +-- displacement from the left-baseline of the previous Char.+--+kernEscName :: u -> String -> KerningChar u+kernEscName u s = (u, CharEscName s)  -------------------------------------------------------------------------------- -mkEllipse :: Num u -          => EllipseProps -> XLink -> u -> u -> Point2 u -> Primitive u-mkEllipse props xlink hw hh pt = -    PEllipse props xlink (PrimEllipse pt hw hh identityCTM) --ellipseDefault :: EllipseProps-ellipseDefault = EFill black----- | Create an ellipse, the ellipse will be filled unless the --- supplied attributes /imply/ a stroked ellipse, e.g.:------ > ellipse (LineWidth 4) zeroPt 40 40 +-- | Create a stroked ellipse. -- -- Note - within Wumpus, ellipses are considered an unfortunate -- but useful /optimization/. Drawing good cicles with Beziers  -- needs at least eight curves, but drawing them with --- PostScript\'s @arc@ command is a single operation.  For +-- PostScript\'s @arc@ command needs a single operation. For  -- drawings with many dots (e.g. scatter plots) it seems sensible--- to employ this optimaztion.+-- to employ this optimization. -- -- A deficiency of Wumpus\'s ellipse is that (non-uniformly) -- scaling a stroked ellipse also (non-uniformly) scales the pen  -- it is drawn with. Where the ellipse is wider, the pen stroke  -- will be wider too.  ---class Ellipse t where-  ellipse :: Fractional u => t -> u -> u -> Point2 u -> Primitive u+-- Avoid non-uniform scaling stroked ellipses!+--+strokeEllipse :: Num u +             => RGBi -> StrokeAttr -> u -> u -> Point2 u -> Primitive u+strokeEllipse rgb sa = xstrokeEllipse rgb sa NoLink  -instance Ellipse ()             where ellipse () = zellipse+-- | Create a filled ellipse.+--+fillEllipse :: Num u +             => RGBi -> u -> u -> Point2 u -> Primitive u+fillEllipse rgb = xfillEllipse rgb NoLink -instance Ellipse RGBi where -  ellipse rgb = mkEllipse (EFill rgb) NoLink+-- | Create a stroked ellipse with a hyperlink.+--+-- Note - hyperlinks are only rendered in SVG output.+--+xstrokeEllipse :: Num u +             => RGBi -> StrokeAttr -> XLink -> u -> u -> Point2 u -> Primitive u+xstrokeEllipse rgb sa xlink hw hh pt = +    PEllipse (EStroke sa rgb) xlink (PrimEllipse pt hw hh identityCTM) -instance Ellipse StrokeAttr where-  ellipse x = mkEllipse (EStroke [x] black) NoLink+-- | Create a filled ellipse.+--+-- Note - hyperlinks are only rendered in SVG output.+-- +xfillEllipse :: Num u +             => RGBi -> XLink -> u -> u -> Point2 u -> Primitive u+xfillEllipse rgb xlink hw hh pt = +    PEllipse (EFill rgb) xlink (PrimEllipse pt hw hh identityCTM) -instance Ellipse [StrokeAttr] where-  ellipse xs = mkEllipse (EStroke xs black) NoLink -instance Ellipse XLink where -  ellipse xlink = mkEllipse (EFill black) xlink+-- | Create a black, filled ellipse. +zellipse :: Num u => u -> u -> Point2 u -> Primitive u+zellipse hw hh pt = xfillEllipse black NoLink hw hh pt -instance Ellipse (RGBi,StrokeAttr) where-  ellipse (rgb,x) = mkEllipse (EStroke [x] rgb) NoLink -instance Ellipse (RGBi,[StrokeAttr]) where-  ellipse (rgb,xs) = mkEllipse (EStroke xs rgb) NoLink+-- | Create a bordered (i.e. filled and stroked) ellipse.+--+borderedEllipse :: Num u +                => RGBi -> StrokeAttr -> RGBi -> u -> u -> Point2 u +                -> Primitive u+borderedEllipse frgb sa srgb = xborderedEllipse frgb sa srgb NoLink -instance Ellipse (RGBi,XLink) where-  ellipse (rgb,xlink) = mkEllipse (EFill rgb) xlink+-- | Create a bordered (i.e. filled and stroked) ellipse with a +-- hyperlink.+--+-- Note - hyperlinks are only rendered in SVG output.+--+xborderedEllipse :: Num u +                 => RGBi -> StrokeAttr -> RGBi -> XLink -> u -> u -> Point2 u +                 -> Primitive u+xborderedEllipse frgb sa srgb xlink hw hh pt = +    PEllipse (EFillStroke frgb sa srgb) xlink (PrimEllipse pt hw hh identityCTM) -instance Ellipse (StrokeAttr,XLink) where-  ellipse (x,xlink) = mkEllipse (EStroke [x] black) xlink -instance Ellipse ([StrokeAttr],XLink) where-  ellipse (xs,xlink) = mkEllipse (EStroke xs black) xlink -instance Ellipse (RGBi,[StrokeAttr],XLink) where-  ellipse (rgb,xs,xlink) = mkEllipse (EStroke xs rgb) xlink---- | Create a black, filled ellipse. -zellipse :: Num u => u -> u -> Point2 u -> Primitive u-zellipse hw hh pt = mkEllipse ellipseDefault NoLink hw hh pt- -------------------------------------------------------------------------------- -- Operations @@ -505,11 +630,12 @@ boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ]   where     (bl,br,tr,tl) = boundaryCorners $ boundary a-    bbox_rect     = cstroke (rgb, line_attr) $ vertexPath [bl,br,tr,tl]-    bl_to_tr      = ostroke (rgb, line_attr) $ vertexPath [bl,tr]-    br_to_tl      = ostroke (rgb, line_attr) $ vertexPath [br,tl]+    bbox_rect     = cstroke rgb line_attr $ vertexPath [bl,br,tr,tl]+    bl_to_tr      = ostroke rgb line_attr $ vertexPath [bl,tr]+    br_to_tl      = ostroke rgb line_attr $ vertexPath [br,tl] -    line_attr     = [LineCap $ CapRound, DashPattern $ Dash 0 [(1,2)]]+    line_attr     = default_stroke_attr { line_cap     = CapRound+                                        , dash_pattern = Dash 0 [(1,2)] }   -- | Generate the control points illustrating the Bezier @@ -546,7 +672,8 @@     step _ (PLineTo e:xs)        = step e xs     step s (PCurveTo c1 c2 e:xs) = mkLine s c1 : mkLine c2 e : step e xs  -    mkLine s e                   = ostroke rgb (PrimPath s [lineTo e]) +    mkLine s e                   = let pp = (PrimPath s [lineTo e]) in +                                   ostroke rgb default_stroke_attr pp    -- Generate lines illustrating the control points of an @@ -570,7 +697,7 @@     rest s (c1:c2:e:xs)  = mkLine s c1 : mkLine c2 e : rest e xs     rest _ _             = [] -    mkLine s e           = ostroke rgb (PrimPath s [lineTo e]) +    mkLine s e  = ostroke rgb default_stroke_attr (PrimPath s [lineTo e])    

@@ -23,7 +23,7 @@   , DPicture   , Locale   , AffineTrafo(..)-  , GSUpdate(..)+  , FontCtx(..)    , Primitive(..)   , DPrimitive@@ -37,6 +37,10 @@   , PrimLabel(..)   , DPrimLabel   , LabelProps(..)+  , LabelBody(..)+  , DLabelBody+  , KerningChar+  , DKerningChar     , PrimEllipse(..)   , EllipseProps(..)   , PrimCTM(..)@@ -124,21 +128,19 @@ data Picture u = Leaf     (Locale u)              (OneList (Primitive u))                | Picture  (Locale u)              (OneList (Picture u))                | Clip     (Locale u) (PrimPath u) (Picture u)-               | Group    (Locale u) GSUpdate     (Picture u)+               | Group    (Locale u) FontCtx      (Picture u)   deriving (Show)  --- | Update the graphics state for SVG rendering. +-- | Set the font /delta/ for SVG rendering.  -- --- Note - this does not change how any of the Primitives are --- drawn, nor does it change the default colour or font style. +-- Note - this does not change the default colour or font style.  -- It is solely a backdoor into the SVG renderer to potential  -- allow some code size reductions. ---newtype GSUpdate = GSUpdate { getGSU :: GraphicsState -> GraphicsState }+newtype FontCtx = FontCtx { getFontCtx :: FontAttr }+  deriving (Eq,Show) -instance Show GSUpdate where-  show _ = "*function*"  -- | Locale = (bounding box * current translation matrix) -- @@ -232,9 +234,9 @@ --   of the line (stroke width). -- data PathProps = CFill RGBi -               | CStroke [StrokeAttr] RGBi-               | OStroke [StrokeAttr] RGBi-               | CFillStroke RGBi [StrokeAttr] RGBi+               | CStroke StrokeAttr RGBi+               | OStroke StrokeAttr RGBi+               | CFillStroke RGBi StrokeAttr RGBi   deriving (Eq,Show)  @@ -242,13 +244,15 @@ -- data PrimLabel u = PrimLabel        { label_baseline_left :: Point2 u-      , label_text          :: EncodedText+      , label_body          :: LabelBody u       , label_ctm           :: PrimCTM u       }   deriving (Eq,Show)  type DPrimLabel = PrimLabel Double +-- | Font rendering properties for a PrimLabel.+-- data LabelProps   = LabelProps        { label_colour :: RGBi       , label_font   :: FontAttr@@ -256,6 +260,33 @@   deriving (Eq,Ord,Show)  +-- | Label can be draw with 3 layouts.+-- +-- The standard layout uses @show@ for PostScript and a single +-- initial point for SVG.+--+-- Kerned horizontal layout - each character is encoded with the+-- rightwards horizontal distance from the last charcaters left +-- base-line.+-- +-- Kerned vertical layout - each character is encoded with the+-- upwards distance from the last charcaters left base-line.+-- +data LabelBody u = StdLayout EncodedText+                 | KernTextH [KerningChar u]+                 | KernTextV [KerningChar u]+  deriving (Eq,Show)++type DLabelBody = LabelBody Double+++-- | A Char (possibly escaped) paired with is displacement from +-- the previous KerningChar.+--+type KerningChar u = (u,EncodedChar) ++type DKerningChar = KerningChar Double+ -- Ellipse represented by center and half_width * half_height -- data PrimEllipse u = PrimEllipse @@ -270,9 +301,9 @@ -- | Ellipses and circles are always closed. -- data EllipseProps = EFill RGBi-                  | EStroke [StrokeAttr] RGBi +                  | EStroke StrokeAttr RGBi                    -- Note - first colour fill, second colour stroke.-                  | EFillStroke RGBi [StrokeAttr] RGBi +                  | EFillStroke RGBi StrokeAttr RGBi    deriving (Eq,Show)  @@ -361,6 +392,12 @@             <+> text "ctm="           <> format ctm           ] +instance PSUnit u => Format (LabelBody u) where+  format (StdLayout enctext) = format enctext+  format (KernTextH xs)      = text "(KernH)" <+> hcat (map (format .snd) xs)+  format (KernTextV xs)      = text "(KernV)" <+> hcat (map (format .snd) xs)++ instance PSUnit u => Format (PrimEllipse u) where   format (PrimEllipse ctr hw hh ctm) = text "center="   <> format ctr                                    <+> text "hw="       <> dtruncFmt hw@@ -434,14 +471,55 @@  labelBoundary :: (Floating u, Real u, FromPtSize u)                => FontAttr -> PrimLabel u -> BoundingBox u-labelBoundary attr (PrimLabel (P2 x y) xs ctm) = +labelBoundary attr (PrimLabel (P2 x y) body ctm) =      retraceBoundary  (disp . (m33 *#)) untraf_bbox   where     disp        = (.+^ V2 x y)     m33         = matrixRepCTM ctm-    untraf_bbox = textBounds (font_size attr) zeroPt char_count-    char_count  = textLength xs+    untraf_bbox = labelBodyBoundary (font_size attr) body +labelBodyBoundary :: (Num u, Ord u, FromPtSize u) +                  => FontSize -> LabelBody u -> BoundingBox u+labelBodyBoundary sz (StdLayout etxt) = stdLayoutBB sz (textLength etxt)+labelBodyBoundary sz (KernTextH xs)   = hKerningBB sz xs+labelBodyBoundary sz (KernTextV xs)   = vKerningBB sz xs+++stdLayoutBB :: (Num u, Ord u, FromPtSize u) +            => FontSize -> CharCount -> BoundingBox u+stdLayoutBB sz len = textBounds sz zeroPt len++-- Note - this assumes positive deltas (and a nonempty list)...+--+-- Kern deltas are relative to the left basepoint, so they are+-- irrespective of the actual charater width. Thus to calculate+-- the bounding box Wumpus calculates the bounds of one character+-- then expands the right edge with the sum of the (rightwards)+-- displacements.+-- +hKerningBB :: (Num u, Ord u, FromPtSize u) +           => FontSize -> [(u,EncodedChar)] -> BoundingBox u+hKerningBB sz xs = rightGrow (sumDiffs xs) $ textBounds sz zeroPt 1+  where+    sumDiffs                          = foldr (\(u,_) i -> i+u)  0+    rightGrow u (BBox ll (P2 x1 y1))  = BBox ll (P2 (x1+u) y1)+++-- Note - likewise same assumptions as horizontal version.+-- (A postive distance represents a move downwards)...+--+-- The kern delta is the distance between baselines of successive+-- characters, so character height is irrespective when summing +-- the deltas.+-- +-- Also note, that the Label /grows/ downwards...+--+vKerningBB :: (Num u, Ord u, FromPtSize u) +           => FontSize -> [(u,EncodedChar)] -> BoundingBox u+vKerningBB sz xs = downGrow (sumDiffs xs) $ textBounds sz zeroPt 1+  where+    sumDiffs                                = foldr (\(u,_) i -> i+u)  0+    downGrow u (BBox (P2 x0 y0) (P2 x1 y1)) = BBox (P2 x0 (y0-u)) (P2 x1 y1)   -- | Ellipse bbox is the bounding rectangle, rotated as necessary 

@@ -18,6 +18,7 @@   (        escapeSpecial+  , escapeSpecialChar        , psHeader   , epsHeader@@ -88,6 +89,11 @@   where     f c ss | c `elem` ps_special = '\\' : c : ss            | otherwise           = c : ss++-- Note - this has to promote the Char to a String...+escapeSpecialChar :: Char -> String+escapeSpecialChar c | c `elem` ps_special = ['\\', c]+                    | otherwise           = [c]  ps_special :: [Char] ps_special = "\\()<>[]{}/%"

@@ -34,7 +34,9 @@    , attr_id   , attr_x+  , attr_xs   , attr_y+  , attr_ys   , attr_r   , attr_rx   , attr_ry@@ -199,10 +201,28 @@ attr_x :: PSUnit u => u -> Doc attr_x = svgAttr "x" . dtruncFmt ++-- | @ x=\"... ... ...\" @+--+-- /List/ version of attr_x+-- +attr_xs :: PSUnit u => [u] -> Doc+attr_xs = svgAttr "x" . hsep . map dtruncFmt++ -- | @ y=\"...\" @ -- attr_y :: PSUnit u => u -> Doc attr_y = svgAttr "y" . dtruncFmt+++-- | @ y=\"... ... ...\" @+--+-- /List/ version of attr_y+-- +attr_ys :: PSUnit u => [u] -> Doc+attr_ys = svgAttr "y" . hsep . map dtruncFmt+  -- | @ r=\"...\" @ --

@@ -17,20 +17,22 @@ -- -- > "regular ascii text &#egrave; more ascii text" --  --- i.e. character names and codes are delimited by @&#@ on the +-- i.e. character names and codes are delimited by @&\#@ on the  -- left and @;@ on the right. ----- In Wumpus strings both character names and character codes can--- be embedded - it seems conventional for PostScript to use --- names e.g.:  +-- In Wumpus both character names and character codes can+-- be embedded in strings - (e.g. @ &\#egrave; or &\#232; @). --+-- In the generated PostScript, Wumpus uses the character name, +-- e.g.:  +-- -- > (myst) show /egrave glyphshow (re) show -- --- ... and SVG to use codes, e.g.: +-- The generated SVG uses the numeric code, e.g.:  -- -- > mystère ----- To accommodate both Wumpus defines a TextEncoder record which +-- To accommodate both, Wumpus defines a TextEncoder record which -- provides a two-way mapping between character codes and glyph  -- names for a character set. --

@@ -19,6 +19,7 @@      EncodedText(..)       , TextChunk(..)+  , EncodedChar(..)    , textLength   , lookupByCharCode  @@ -36,10 +37,20 @@ newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] }   deriving (Eq,Show) +-- | Wumpus supports both escaped names e.g. @egrave@ and escaped+-- (numeric decimal) character codes in the input string for a +-- TextLabel.+-- +data TextChunk = TextSpan    String+               | TextEscInt  Int+               | TextEscName GlyphName+  deriving (Eq,Show) -data TextChunk = SText  String-               | EscInt Int-               | EscStr GlyphName+-- | For KernLabels Wumpus needs a Char version of TextChunk.+--+data EncodedChar = CharLiteral Char+                 | CharEscInt  Int+                 | CharEscName GlyphName   deriving (Eq,Show)  @@ -49,16 +60,22 @@   format = hcat . map format . getEncodedText  instance Format TextChunk where-  format (SText s)   = text s-  format (EscInt i)  = text "&#" <> int i  <> semicolon-  format (EscStr s)  = text "&#" <> text s <> semicolon+  format (TextSpan s)    = text s+  format (TextEscInt i)  = text "&#" <> int i  <> semicolon+  format (TextEscName s) = text "&#" <> text s <> semicolon +instance Format EncodedChar where+  format (CharLiteral c) = char c+  format (CharEscInt i)  = text "&#" <> int i  <> semicolon+  format (CharEscName s) = text "&#" <> text s <> semicolon++ --------------------------------------------------------------------------------  textLength :: EncodedText -> Int textLength = foldr add 0 . getEncodedText where -    add (SText s) n = n + length s-    add _         n = n + 1+    add (TextSpan s) n = n + length s+    add _            n = n + 1   lookupByCharCode :: CharCode -> TextEncoder -> Maybe GlyphName@@ -68,17 +85,27 @@ lookupByGlyphName i enc = (svg_lookup enc) i  --- | Output to PostScript as @ /egrave glyphshow @---- Output to SVG as an escaped decimal, e.g. @ &#232; @+-- | 'lexLabel' input is regular text and escaped glyph names or+-- decimal character codes. Escaping follows the SVG convention,+-- start with @&#@ (ampersand hash) end with @;@ (semicolon). --+-- Special chars are output to PostScript as:+--+-- > /egrave glyphshow+--+-- Special chars are output to SVG as an escaped decimal, e.g.:+--+-- > &#232;+-- -- Note, HTML entity names do not seem to be supported in SVG, -- @ &egrave; @ does not work in FireFox or Chrome.--+-- lexLabel :: String -> EncodedText lexLabel = EncodedText . lexer +-- Note - the lexer reads number spans with isDigit, so reads +-- decimals only.+--  lexer :: String -> [TextChunk] lexer []            = [] @@ -87,14 +114,14 @@     esc (c:cs) | isDigit c = let (s,cs') = span isDigit cs                               in  intval (c:s) cs'                | otherwise = let (s,cs') = span isAlpha cs -                             in EscStr (c:s) : optsemi cs'+                             in TextEscName (c:s) : optsemi cs'     esc []                 = []      optsemi (';':cs)   = lexer cs      -- let ill-formed go through     optsemi cs         = lexer cs      intval [] rest  = optsemi rest-    intval cs rest  = EscInt (read cs) : optsemi rest+    intval cs rest  = TextEscInt (read cs) : optsemi rest  lexer (x:xs)        = let (s,xs') = span (/= '&') xs -                      in SText (x:s) : lexer xs'+                      in TextSpan (x:s) : lexer xs'

@@ -22,7 +22,7 @@  -- | Version number. ----- > (0,30,0)+-- > (0,31,0) -- wumpus_core_version :: (Int,Int,Int)-wumpus_core_version = (0,30,0)+wumpus_core_version = (0,31,0)

@@ -28,15 +28,18 @@   -- * Picture types     Picture   , DPicture-  , GSUpdate+  , FontCtx   , Primitive   , DPrimitive+  , XLink   , PrimPath   , DPrimPath   , PrimPathSegment   , DPrimPathSegment   , PrimLabel   , DPrimLabel+  , KerningChar+  , DKerningChar    -- * Drawing styles   , PathProps       

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.30.0+version:          0.31.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -9,8 +9,6 @@ synopsis:         Pure Haskell PostScript and SVG generation.  description:   .-  Wumpus - (W)riter (M)onad (P)ost (S)cript. -  .   Wumpus is a kernel library for generating 2D vector pictures,    its salient feature is portability due to no FFI dependencies.    It can generate PostScript (EPS) files and SVG files. The @@ -21,7 +19,7 @@   Pictures in Wumpus are made from /paths/ and text /labels/.    Paths themselves are made from points. The usual affine    transformations (rotations, scaling, translations) can be-  applied to geometric objects. Unlike PostScript there is no +  applied to Pictures. Unlike PostScript there is no    notion of a current point, Wumpus builds pictures in a   coordinate-free style.    .@@ -37,12 +35,8 @@   sophisticated (e.g. how attributes like colour are handled,    and how the bounding boxes of text labels are calculated), so    Wumpus might be limited compared to other systems. However, -  the design permits a fairly simple implementation - which is -  a priority. Text encoding an exception - I\'m not sure how -  reasonable the design is. The current implementation -  appears okay for Latin 1 but may be inadequate for other -  character sets, so I may have to revise it significantly.-  .+  the design permits a fairly simple implementation, which is a +  priority.    .   \[1\] Because the output is simple, straight-line PostScript    code, it is possible to use GraphicsMagick or a similar tool @@ -51,6 +45,39 @@   .   Changelog:   .+  0.30.0 to 0.31.0:+  .+  * Extended the label type to optionally handle horizontal+    or vertical \"kerning\". This can be efficiently implemented +    in SVG.+  .+  * Major API change - the Primitive constructors defined in +    @Core.PictureLanguage@ are no longer overloaded (@cstroke@, +    @ostroke@, @fill@, @textlabel@, @ellipse@). The respective +    classes (@Stroke@, @TextLabel@, @Ellipse@) have been removed+    and the constructors now have monomorphic types. This is +    because Wumpus-Core now only has one colour type and stroke+    attributes are now a single type, so polymorphism became+    less useful (and the simplicity of monomorphic types became+    more favourable). @ellipse@ is no longer a constructor +    instead there variants @fillEllipse@ and @strokeEllipse@.+  .+  * Added support for /bordered/ closed paths - i.e. paths that+    are both stroked and filled. These can be efficiently drawn +    in SVG with a single @path@ element.+  .+  * Changed StrokeAttr representation to be a regular data type+    rather than a list of /deltas/ - i.e. differences to the +    graphics state.+  .+  * Added SVG font attribute /delta optimizations/ to help reduce +    SVG code size - via the @fontDeltaContext@ function in +    @Core.Picture@. This functionality was partially inplemented +    in the last release using the @GSUpdate@ datatype - this +    datatype it is now called @FontCtx@.+  .+  * Some internal work documenting text encoding.+  .   0.23.0 to 0.30.0:   .   * Substantial changes - the output machinery has been heavily @@ -92,29 +119,8 @@     now @boundaryCorners@, @within@ is now @withinBoundary@ and      @union@ is now @boundaryUnion@.    .-  0.22.0 TO 0.23.0:-  . -  * @Basic.GraphicsState@ - extracted the font face fields from -    @FontAttr@ datatype into a separate datatype @FontFace@.-  . -  * Added @PtSize@ a numeric type wrapping Double. This is -    specifically for text size calculations, vis the -    @Core.FontSize@ module.   .-  * Changed all functions in @Core.FontSize@ to return @PtSize@-    instead of a polymorphic type @u@ (where @u@ is an instance -    of Fractional). To get to another unit type rather than -    FontSize use an explicit conversion that scales the value -    accordingly.   .-  * Added FromPtSize class constraints to various functions in-    @Core.Picture@.-  .-  * Added @charWidth@ to @Core.FontSize@.-  .-  * Added @vlength@ to @Core.Geometry@-  .-  . build-type:         Simple stability:          unstable cabal-version:      >= 1.2@@ -126,8 +132,11 @@   demo/AffineTest02.hs,   demo/AffineTest03.hs,   demo/AffineTestBase.hs,-  demo/FontMetrics.hs+  demo/DeltaPic.hs,+  demo/FontMetrics.hs,+  demo/KernPic.hs,   demo/LabelPic.hs,+  demo/Latin1Pic.hs,   demo/MultiPic.hs,   demo/Rotated.hs,   demo/Scaled.hs,