wumpus-core 0.40.0 → 0.41.0

raw patch · 21 files changed

+728/−249 lines, 21 filesdep ~containersdep ~timePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: containers, time

API changes (from Hackage documentation)

Files

• CHANGES +56/−0
• demo/AffineTestBase.hs +2/−1
• demo/TransformEllipse.hs +6/−4
• demo/TransformPath.hs +4/−3
• demo/TransformTextlabel.hs +3/−2
• doc-src/Guide.lhs +53/−47
• doc/Guide.pdf binary
• src/Wumpus/Core/AffineTrans.hs +55/−8
• src/Wumpus/Core/BoundingBox.hs +11/−0
• src/Wumpus/Core/Geometry.hs +52/−4
• src/Wumpus/Core/OutputPostScript.hs +52/−26
• src/Wumpus/Core/OutputSVG.hs +54/−19
• src/Wumpus/Core/Picture.hs +57/−87
• src/Wumpus/Core/PictureInternal.hs +16/−3
• src/Wumpus/Core/PostScriptDoc.hs +139/−0
• src/Wumpus/Core/Text/Base.hs +15/−2
• src/Wumpus/Core/TrafoInternal.hs +5/−1
• src/Wumpus/Core/Utils/Common.hs +0/−34
• src/Wumpus/Core/Utils/HList.hs +92/−0
• src/Wumpus/Core/VersionNumber.hs +2/−2
• wumpus-core.cabal +54/−6

@@ -1,5 +1,61 @@  +0.37.0 to 0.40.0: ++  * Text handling substantially revised. SVG text output is now +    better aligned to Unicode. The encoding tables for PostScript+    have been re-thought, the previous implementation had some +    serious design flaws that should now be rectified.++  * The rules for escaping special characters has been clarified.+    Previously the documentation suggested +    @ampersand-name-semicolon@ could be used to escape glyph names+    however only @ampersand-hash-name-semicolon@ worked.+    @ampersand-name-semicolon@ is now the correct way. The +    ampersand-hash prefix is for numeric literals - +    @ampersand-hash-num_literal-semicolon@.++  * Versions of the textlabel functions have been added to +    @Core.Picture@ for escape-parsed text. It is useful for +    higher-level software to escape the text, do some calculations +    then render it - going back to un-escaped text for the +    rendering would be inefficient.++  * The internal representation of paths has changed. They are now +    represented as start-point plus list of /relative/ path +    segments rather than start-point plus list of absolute path +    segments. Using relative path segments makes it cheaper to+    move paths with @translate@, although calculating the bounding+    box and rendering to PostScript is more expensive. The +    rationale for the change is that to make complex pictures, +    paths are potentially moved many times but the other +    operations are only performed once.++  * Internal change to Primitives and the PrimCTM - ellipses and+    labels no longer have a point (center or baseline left)+    as an element in the datatype, the point is now represented +    within the PrimCTM.++  * Name change to @Core.Picture@ API - the path construction +    function @path@ has been renamed to @primPath@.++  * Name change in @Core.FontSize@, the function @textBoundsEnc@+    has been renamed to @textBoundsEsc@. Wumpus-Core now calls +    strings that have been parsed for escape characters +    /Escaped Text/ rather than /Encoded Text/.++  * Fixed bug where ellipse rotation and scaling calculated the +    wrong bounding box.+ +  * Fixed bug in @illustrateControlPoints@ where the control points+    were drawn but the original primitive was lost. ++  * Added initial support for arbitrary SVG attributes (e.g. +    onmouseover handlers) via @annotateGroup@ in @Core.Picture@. +    Arbitrary SVG \"defs\" can be written into the defs prologue +    by using @writeSVG_defs@ instead of @writeSVG@. This +    functionality is mostly untested!+ 0.36.0 to 0.37.0:    * The bounding box constructors have been renamed - @bbox@ is 

@@ -70,7 +70,7 @@     picture2 = illustrateBounds light_blue $ picF $ frame [mk blue]
 
     picture3 :: DPicture
-    picture3 = illustrateBoundsPrim light_blue $ prim
+    picture3 = illustrateBoundsPrim light_blue prim
       where
         prim :: DPrimitive
         prim = primF $ mk red
@@ -120,6 +120,7 @@ 
 rgbPath :: RGBi -> DPrimitive
 rgbPath rgb = ostroke rgb default_stroke_attr $ dog_kennel
+
 --------------------------------------------------------------------------------
 -- Demo - draw a dog kennel...
 

@@ -25,7 +25,8 @@     writeEPS "./out/transform_ellipse05.eps" pic5     writeSVG "./out/transform_ellipse05.svg" pic5 -+gray :: RGBi+gray = RGBi 127 127 127  pic1 :: Picture Double pic1 = cb `picOver` ell `picOver` xy_frame "no transform"@@ -41,7 +42,7 @@      ell  = mkRedEllipse (rotate ang) 20 10 pt      cb   = rotate ang $ crossbar 20 10 pt      pt   = P2 70 10-     ang  = 0.25*pi+     ang  = d2r (30::Double)  pic3 :: Picture Double pic3 = cb `picOver` ell `picOver` xy_frame "rotateAbout (60,0) 30deg"@@ -50,7 +51,7 @@      cb   = rotateAbout ang pto $ crossbar 20 10 pt      pt   = P2 70 10      pto  = P2 60 0-     ang  = 0.25*pi+     ang  = d2r (30::Double)   pic4 :: Picture Double@@ -71,7 +72,8 @@ mkRedEllipse :: (Real u, Floating u, FromPtSize u)               => (Primitive u -> Primitive u)               -> u -> u -> Point2 u -> Picture u-mkRedEllipse trafo rx ry pt = frame [ trafo $ fillEllipse red rx ry pt] +mkRedEllipse trafo rx ry pt = +    illustrateControlPoints gray $ trafo $ fillEllipse red rx ry pt  crossbar :: (Real u, Floating u, FromPtSize u)           => u -> u -> Point2 u -> Picture u

@@ -40,8 +40,9 @@      pth  = mkBlackPath (rotate ang) pt      ch   = rotate ang $ zcrosshair pt      pt   = P2 70 10-     ang  = 0.25*pi+     ang  = d2r (30::Double) + pic3 :: Picture Double pic3 = pth `picOver` ch `picOver` xy_frame "rotateAbout (60,0) 30deg"   where@@ -49,8 +50,8 @@      ch   = rotateAbout ang pto $ zcrosshair pt      pt   = P2 70 10      pto  = P2 60 0-     ang  = 0.25*pi-+     ang  = d2r (30::Double)+      pic4 :: Picture Double pic4 = pth `picOver` ch `picOver` xy_frame "scale 1 2"

@@ -40,8 +40,9 @@      txt  = mkBlackTextlabel (rotate ang) pt      ch   = rotate ang $ zcrosshair pt      pt   = P2 70 10-     ang  = 0.25*pi+     ang  = d2r (30::Double) + pic3 :: Picture Double pic3 = txt `picOver` ch `picOver` xy_frame "rotateAbout (60,0) 30deg"   where@@ -49,7 +50,7 @@      ch   = rotateAbout ang pto $ zcrosshair pt      pt   = P2 70 10      pto  = P2 60 0-     ang  = 0.25*pi+     ang  = d2r (30::Double)   pic4 :: Picture Double

@@ -23,7 +23,7 @@ \section{About \wumpuscore}
 %-----------------------------------------------------------------
 
-This guide was last updated for \wumpuscore version 0.40.0.
+This guide was last updated for \wumpuscore version 0.41.0.
 
 \wumpuscore is a Haskell library for generating 2D vector 
 pictures. It was written with portability as a priority, so it has 
@@ -32,9 +32,9 @@ 
 \wumpuscore is rather primitive, the basic drawing objects are 
 paths and text labels. A second library \texttt{wumpus-basic}
-contains code for higher level drawing but it experimental and the 
-APIs are a long way from stable (it should probably be considered 
-a \emph{technology preview}).
+contains code for higher level drawing but it is experimental and 
+the APIs are a long way from stable (it should probably be 
+considered a \emph{technology preview}).
 
 Although \wumpuscore is heavily inspired by PostScript it avoids 
 PostScript's notion of an (implicit) current point and the 
@@ -51,22 +51,23 @@ \begin{description}
 \item[\texttt{Wumpus.Core.}]
 Top-level \emph{shim} module to import all the exposed modules. 
-Some internal data types are also exported as opaque - the 
-implementation is hidden, but the type name is exposed so it can 
-be used in the type signatures of \emph{userland} functions. 
+Some internal data types are also exported as opaque signatures - 
+the implementation is hidden, but the type name is exposed so it 
+can be used in the type signatures of \emph{userland} functions. 
 Typically, where these data types need to be \emph{instantiated}
 smart constructors are provided.
 
 \item[\texttt{Wumpus.Core.AffineTrans.}]
 The standard affine transformations (scaling, rotation, 
-translation) implemented as type classes, with a of derived 
+translation) implemented as type classes, with a set of derived 
 operations - reflections about the X or Y axes, rotations through
 common angles. 
 
 \item[\texttt{Wumpus.Core.BoundingBox.}]
-Data type representing bounding boxes and operations on them. 
-Bounding boxes are important for Pictures as they support the 
-definition of \emph{picture composition} operators.
+A data type representing a bounding box and operations on it. 
+Bounding boxes are necessary for EPS output, they also support the 
+definition of \emph{picture composition} operators, e.g. aligning 
+composite pictures horizontally, vertically, etc.
 
 \item[\texttt{Wumpus.Core.Colour.}]
 A single colour type \texttt{RGBi} is supported. This type defines 
@@ -74,35 +75,37 @@ is (255, 255, 255). Some named colours are defined, although they 
 are hidden by the top level shim module to avoid name clashes with
 libraries providing more extensive lists of colours. 
-\texttt{Wumpus.Core.Colour} can be imported directly if the named 
-colours are required.
+\texttt{Wumpus.Core.Colour} can be imported directly if a simple 
+list of named colours is required.
 
 \item[\texttt{Wumpus.Core.FontSize.}]
-Various calculations for font size metrics. \wumpuscore has 
-limited handling of font / character size as it cannot interpret
-the metrics within font files (doing so would be a huge task).
-Instead this module provides some metrics based on the Courier
-mono-spaced font that can be used for rudimentary size
-calculations on text labels.
+Various calculations for font size metrics. \wumpuscore has only
+approximate handling of font / character size as it does not 
+interpret the metrics within font files (doing so is a 
+substantially task attempted by \texttt{Wumpus.Basic} but 
+currently only for the simple and out-dated \texttt{AFM} font 
+format). Instead, \wumpuscore makes do with operations based on 
+measurements derived from the Courier mono-spaced font. Generally 
+using metrics from a mono-spaced font over-estimates for 
+proportional fonts, though in practice this is tolerable.
 
 \item[\texttt{Wumpus.Core.Geometry.}]
 The usual types an operations from affine geometry - points, 
 vectors and 3x3 matrices, also the \texttt{DUnit} type family.
 Essentially this type family is a trick used heavily within 
 \wumpuscore to avoid annotating class declarations with 
-constraints on the unit - class constraints like 
-\texttt{Fractional u} can then be shifted to the instance 
-declaration rather than the class declaration.
+constraints on the unit of measurement (usually \texttt{Double}
+representing the Point unit of publishing). With the 
+\texttt{DUnit} trick, type constraints like 
+\texttt{Fractional u} can be shifted to instance declarations 
+rather than burden class declarations.
 
-\item[\texttt{Wumpus.Core.GraphicsState.}]
+\item[\texttt{Wumpus.Core.GraphicProps.}]
 Data types modelling the attributes of PostScript's graphics 
 state (stroke style, dash pattern, etc.). Note that 
-\wumpuscore annotates all primitives - paths, text labels - with 
-their rendering style, the \texttt{GraphicsState} here is an 
-internal detail used to generate more efficient PostScript and 
-SVG. The \emph{smaller} types in this module such as 
-\texttt{StrokeAttr} are the only ones relevant for the public 
-API.
+\wumpuscore labels all primitives - paths, text labels - with 
+their rendering style, unlike PostScript there is no 
+\emph{inheritance} of a Graphics State in \wumpuscore.
 
 \item[\texttt{Wumpus.Core.OutputPostScript.}]
 Functions to write PostScript or encapsulated PostScript files.
@@ -113,15 +116,15 @@ \item[\texttt{Wumpus.Core.Picture.}]
 Operations to build \emph{pictures} - paths and labels within
 an affine frame. Generally the functions here are convenience 
-constructors for types from the hidden module 
-\texttt{Wumpus.Core.PictureInternal}. The types from 
-\texttt{PictureInternal} are exported as opaque signatures by 
+constructors for data types from the hidden module 
+\texttt{Wumpus.Core.PictureInternal}. The data types from 
+\texttt{PictureInternal} are exported with opaque signatures by 
 \texttt{Wumpus.Core.WumpusTypes}.
 
 \item[\texttt{Wumpus.Core.PtSize.}]
-Text size calculations in \texttt{Core.FontSize} use points 
-(i.e. 1/72 of an inch). The \texttt{PtSize} module is a numeric 
-type to represent them.
+Text size calculations in \texttt{Core.FontSize} use 
+\emph{printer's points} (i.e. 1/72 of an inch). The 
+\texttt{PtSize} module is a numeric type to represent them.
 
 \item[\texttt{Wumpus.Core.Text.Base.}]
 Types for handling escaped \emph{special} charcters within input 
@@ -130,19 +133,22 @@ names and never XML / SVG ones, e.g. for \texttt{\&} use 
 \texttt{\#ampersand;} not \texttt{\#amp;}. 
 
-Also note, unless you are generating only SVG output, glyph 
+Also note, unless only SVG output is being generated, glyph 
 names should be used rather than char codes. For PostScript the 
 resolution of char codes is dependent on the encoding of the font 
-used to render it. As core fonts do not use the common Latin1 
-encoding, using using numeric char codes in the input text may 
-produce unexpected results.
-
-Unfortunately fonts are often missing characters you might want, 
-and a PostScript renderer cannot do anything about it (SVG appears 
-to support glyph subsitution from other fonts). \wumpuscore is 
-oblivious to the contents of fonts so it cannot issue a warning 
-if a glyph is not present when it generates a document.
+used to render it. As the core PostScript fonts use their own 
+encoding rather than the common Latin1 encoding, using using 
+numeric char codes (intending to be Latin1) can produce unexpected 
+results.
 
+Unfortunately, even core fonts are often missing glyphs that 
+familiarity with Unicode and Web publishing might expect them 
+support. Generally, a PostScript renderer cannot do anything about 
+missing glyphs - it might print a space or an open, tall rectangle. 
+As \wumpuscore is oblivious to the contents of fonts, it cannot 
+issue a warning if a glyph is not present when it generates a 
+document, so PostScript output must be proof-read if extended 
+glyphs are used.
 
 \item[\texttt{Wumpus.Core.Text.GlyphIndices.}]
 An map of PostScript glyph names to Unicode code points. 
@@ -211,8 +217,8 @@ 
 \wumpuscore uses the same picture frame as PostScript where 
 the origin at the bottom left, see Figure 1. This contrasts to SVG 
-where the origin at the top-left. When \wumpuscore generates SVG, 
-the whole picture is generated within a matrix transformation 
+where the origin is at the top-left. When \wumpuscore generates 
+SVG, the whole picture is generated within a matrix transformation 
 [ 1.0, 0.0, 0.0, -1.0, 0.0, 0.0 ] that changes the picture to use 
 PostScript coordinates. This has the side-effect that text is 
 otherwise drawn upside down, so \wumpuscore adds a rectifying 

binary file changed (62287 → 62561 bytes)

@@ -2,7 +2,9 @@ {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}+{-# LANGUAGE UndecidableInstances       #-} + ------------------------------------------------------------------------------ -- | -- Module      :  Wumpus.Core.AffineTrans@@ -96,25 +98,37 @@ class Transform t where   transform :: u ~ DUnit t => Matrix3'3 u -> t -> t +instance Transform (UNil u) where+  transform _ = id +instance Num u => Transform (Point2 u) where+  transform ctm = (ctm *#) +instance Num u => Transform (Vec2 u) where+  transform ctm = (ctm *#)++--------------------------------------------------------------------------------+ -- | Type class for rotation. --  class Rotate t where   rotate :: Radian -> t -> t -instance Num u => Transform (Point2 u) where-  transform ctm = (ctm *#)+instance Rotate (UNil u) where+  rotate _ = id -instance Num u => Transform (Vec2 u) where-  transform ctm = (ctm *#)+instance Rotate a => Rotate (Maybe a) where+  rotate = fmap . rotate +instance (Rotate a, Rotate b, u ~ DUnit a, u ~ DUnit b) => Rotate (a,b) where+  rotate ang (a,b) = (rotate ang a, rotate ang b) + instance (Floating u, Real u) => Rotate (Point2 u) where-  rotate a = ((rotationMatrix a) *#)+  rotate ang = ((rotationMatrix ang) *#)  instance (Floating u, Real u) => Rotate (Vec2 u) where-  rotate a = ((rotationMatrix a) *#)+  rotate ang = ((rotationMatrix ang) *#)   -- | Type class for rotation about a point.@@ -123,12 +137,24 @@   rotateAbout :: u ~ DUnit t =>  Radian -> Point2 u -> t -> t   +instance RotateAbout (UNil u) where+  rotateAbout _ _ = id++instance RotateAbout a => RotateAbout (Maybe a) where+  rotateAbout ang pt = fmap (rotateAbout ang pt)++instance (RotateAbout a, RotateAbout b, u ~ DUnit a, u ~ DUnit b) => +    RotateAbout (a,b) where+  rotateAbout ang pt (a,b) = (rotateAbout ang pt a, rotateAbout ang pt b)+++ instance (Floating u, Real u) => RotateAbout (Point2 u) where-  rotateAbout a pt = ((originatedRotationMatrix a pt) *#) +  rotateAbout ang pt = ((originatedRotationMatrix ang pt) *#)    instance (Floating u, Real u) => RotateAbout (Vec2 u) where-  rotateAbout a pt = ((originatedRotationMatrix a pt) *#) +  rotateAbout ang pt = ((originatedRotationMatrix ang pt) *#)     -------------------------------------------------------------------------------- -- Scale@@ -138,6 +164,15 @@ class Scale t where   scale :: u ~ DUnit t => u -> u -> t -> t +instance Scale (UNil u) where+  scale _ _ = id++instance Scale a => Scale (Maybe a) where+  scale sx sy = fmap (scale sx sy)++instance (Scale a, Scale b, u ~ DUnit a, u ~ DUnit b) => Scale (a,b) where+  scale sx sy (a,b) = (scale sx sy a, scale sx sy b)+ instance Num u => Scale (Point2 u) where   scale sx sy = ((scalingMatrix sx sy) *#)  @@ -151,6 +186,18 @@ -- class Translate t where   translate :: u ~ DUnit t => u -> u -> t -> t+++instance Translate (UNil u) where+  translate _ _ = id++instance (Translate a, Translate b, u ~ DUnit a, u ~ DUnit b) => +    Translate (a,b) where+  translate dx dy (a,b) = (translate dx dy a, translate dx dy b)+++instance Translate a => Translate (Maybe a) where+  translate dx dy = fmap (translate dx dy)  instance Num u => Translate (Point2 u) where   translate dx dy (P2 x y) = P2 (x+dx) (y+dy)

@@ -43,6 +43,7 @@    , boundaryCorners   , boundaryCornerList+  , boundaryCenter   , withinBoundary   , boundaryWidth   , boundaryHeight@@ -227,6 +228,16 @@     br = P2 x1 y0     tl = P2 x0 y1 ++-- | 'boundaryCenter' : @bbox -> Point@+-- +-- Return the center of a bounding box.+--+boundaryCenter :: Fractional u => BoundingBox u -> Point2 u+boundaryCenter (BBox (P2 x0 y0) (P2 x1 y1)) = P2 x y +  where+    x = x0 + (0.5*(x1-x0))+    y = y0 + (0.5*(y1-y0))  -- | Within test - is the supplied point within the bounding box? --

@@ -28,8 +28,10 @@    -- * Type family      DUnit+  , GuardEq      -- * Data types+  , UNil   , Vec2(..)   , DVec2   , Point2(..)@@ -41,6 +43,9 @@    , MatrixMult(..) +  -- * UNil operations+  , uNil+   -- * Vector operations   , vec   , hvec@@ -90,7 +95,7 @@ import Data.AffineSpace                         -- package: vector-space import Data.VectorSpace -+import Data.Monoid   @@ -106,10 +111,33 @@ type family DUnit a :: *  +-- Not exported - thanks to Max Bollingbroke.+--+type family   GuardEq a b :: *+type instance GuardEq a a = a  ++--------------------------------------------------------------------------------+ -- Datatypes  +-- | Phantom @()@.+-- +-- This newtype is Haskell\'s @()@ with unit of dimension @u@ as+-- a phantom type.+-- +-- This has no use in @wumpus-core@, but it has affine instances +-- which cannot be written for @()@. By supporting affine +-- instances it becomes useful to higher-level software +-- (@wumpus-basic@ employs it for the @Graphic@ type.) +-- +newtype UNil u = UNil ()+  deriving (Bounded,Enum,Eq,Ord)++++ -- | 2D Vector - both components are strict. -- data Vec2 u = V2 @@ -186,10 +214,13 @@ -------------------------------------------------------------------------------- -- Family instances -type instance DUnit (Point2 u)    = u-type instance DUnit (Vec2 u)      = u-type instance DUnit (Matrix3'3 u) = u+type instance DUnit (UNil u)        = u+type instance DUnit (Point2 u)      = u+type instance DUnit (Vec2 u)        = u+type instance DUnit (Matrix3'3 u)   = u +type instance DUnit (Maybe a)       = DUnit a+type instance DUnit (a,b)           = GuardEq (DUnit a) (DUnit b)  -------------------------------------------------------------------------------- -- lifters / convertors@@ -208,6 +239,12 @@ -------------------------------------------------------------------------------- -- instances ++instance Monoid (UNil u) where+  mempty        = UNil ()+  _ `mappend` _ = UNil ()++ -- Functor  instance Functor Vec2 where@@ -225,6 +262,9 @@  -- Show +instance Show (UNil u) where+  show _ = "UNil"+ instance Show u => Show (Matrix3'3 u) where   show (M3'3 a b c d e f g h i) = "(M3'3 " ++ body ++ ")" where     body = show [[a,b,c],[d,e,f],[g,h,i]]@@ -344,6 +384,14 @@ instance Num u => MatrixMult (Point2 u) where   (M3'3 a b c d e f _ _ _) *# (P2 m n) = P2 (a*m+b*n+c*1) (d*m+e*n+f*1) ++--------------------------------------------------------------------------------+-- UNil++-- | Construct a UNil.+--+uNil :: UNil u+uNil = UNil ()  -------------------------------------------------------------------------------- -- Vectors

@@ -198,6 +198,7 @@ psDraw timestamp pics =      let body = vcat $ runPsMonad $ zipWithM psDrawPage pages pics     in vcat [ psHeader (length pics) timestamp+            , ps_wumpus_prolog             , body             , psFooter              ]@@ -230,6 +231,7 @@     let (bb,cmdtrans) = imageTranslation pic          body          = runPsMonad (picture pic)      in vcat [ epsHeader bb timestamp+            , ps_wumpus_prolog             , ps_gsave             , cmdtrans             , body@@ -256,7 +258,7 @@   psText :: EncodingVector -> EscapedText -> Doc-psText ev enc_text = cons $ foldr fn ([],empty) $ getEscapedText enc_text+psText ev enc_text = cons $ destrEscapedText (foldr fn ([],empty)) enc_text   where     cons ([],doc)               = doc     cons (cs,doc)               = ps_show cs `vconcat` doc@@ -318,11 +320,20 @@ --  primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> PsMonad Doc-primitive (PPath props pp)     = primPath props pp-primitive (PLabel props lbl)   = primLabel props lbl+primitive (PPath props pp)     +    | isEmptyPath pp           = pure empty +    | otherwise                = primPath props pp++primitive (PLabel props lbl)   +    | isEmptyLabel lbl         = pure empty+    | otherwise                = primLabel props lbl+ primitive (PEllipse props ell) = primEllipse props ell+ primitive (PContext _ chi)     = primitive chi+ primitive (PSVG _ chi)         = primitive chi+ primitive (PGroup ones)        = oneConcat primitive ones  @@ -375,36 +386,51 @@ -- primEllipse :: (Real u, Floating u, PSUnit u)              => EllipseProps -> PrimEllipse u -> PsMonad Doc-primEllipse props (PrimEllipse hw hh ctm) =-    bracketPrimCTM (scaleCTM 1 (hh/hw) ctm) (drawF props)+primEllipse props (PrimEllipse hw hh ctm) +    | hw == hh  = bracketPrimCTM ctm (drawC props)+    | otherwise = bracketPrimCTM ctm (drawE props)   where-    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+    drawC (EFill rgb)            pt = fillCircle rgb hw pt+    drawC (EStroke sa rgb)       pt = strokeCircle rgb sa hw pt+    drawC (EFillStroke fc sa sc) pt = +        vconcat <$> fillCircle fc hw pt <*>  strokeCircle sc sa hw pt++    drawE (EFill rgb)            pt = fillEllipse rgb hw hh pt+    drawE (EStroke sa rgb)       pt = strokeEllipse rgb sa hw hh pt+    drawE (EFillStroke fc sa sc) pt = +        vconcat <$> fillEllipse fc hw hh pt <*>  strokeEllipse sc sa hw hh pt                           -- This will need to become monadic to handle /colour delta/. ---fillArcPath :: PSUnit u => RGBi -> u -> Point2 u -> PsMonad Doc-fillArcPath rgb radius pt = -    (\rgbd -> vcat [ rgbd-                   , ps_newpath-                   , ps_arc pt radius 0 360-                   , ps_closepath-                   , ps_fill ])+fillEllipse :: PSUnit u => RGBi -> u -> u -> Point2 u -> PsMonad Doc+fillEllipse rgb rx ry pt = +    (\rgbd -> rgbd `vconcat` ps_wumpus_FELL pt rx ry)       <$> deltaDrawColour rgb -strokeArcPath :: PSUnit u +strokeEllipse :: PSUnit u +              => RGBi -> StrokeAttr -> u -> u -> Point2 u -> PsMonad Doc+strokeEllipse rgb sa rx ry pt =+    (\rgbd attrd -> vcat [ rgbd+                         , attrd+                         , ps_wumpus_SELL pt rx ry ])+      <$> deltaDrawColour rgb <*> deltaStrokeAttrs sa+++-- This will need to become monadic to handle /colour delta/.+--+fillCircle :: PSUnit u => RGBi -> u -> Point2 u -> PsMonad Doc+fillCircle rgb r pt = +    (\rgbd -> rgbd `vconcat` ps_wumpus_FCIRC pt r)+      <$> deltaDrawColour rgb++strokeCircle :: PSUnit u                => RGBi -> StrokeAttr -> u -> Point2 u -> PsMonad Doc-strokeArcPath rgb sa radius pt =+strokeCircle rgb sa r pt =     (\rgbd attrd -> vcat [ rgbd                          , attrd-                         , ps_newpath-                         , ps_arc pt radius 0 360-                         , ps_closepath-                         , ps_stroke ])+                         , ps_wumpus_SCIRC pt r ])       <$> deltaDrawColour rgb <*> deltaStrokeAttrs sa  @@ -455,6 +481,7 @@                                   pt   = P2 (x+dx) y                                in (pt, vcat [acc, ps_moveto pt, doc1]) + -- Note - vertical labels grow downwards... -- kernTextV :: PSUnit u @@ -535,8 +562,7 @@                else setFontAttr fa >> return (makeFontAttrs fa)  makeFontAttrs :: FontAttr -> Doc-makeFontAttrs (FontAttr sz face) = -    vcat [ ps_findfont (ps_font_name face), ps_scalefont sz, ps_setfont ]+makeFontAttrs (FontAttr sz face) = ps_wumpus_FL sz (ps_font_name face)   --------------------------------------------------------------------------------@@ -559,11 +585,11 @@ bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u)                => PrimCTM u                 -> (Point2 u -> PsMonad Doc) -> PsMonad Doc-bracketPrimCTM ctm0 mf= step $ unCTM ctm0 +bracketPrimCTM ctm0 mf = step $ unCTM ctm0    where      step (pt,ctm)        | ctm == identityCTM  = mf pt-      | otherwise           = let mtrx = matrixRepCTM ctm0  -- originalCTM+      | otherwise           = let mtrx  = matrixRepCTM ctm0  -- originalCTM                                   inn   = ps_concat $ mtrx                                   out   = ps_concat $ invert mtrx                               in (\doc -> vcat [inn, doc, out]) <$> mf zeroPt

@@ -185,7 +185,7 @@ picture (Picture (_,xs) ones)   = bracketTrafos xs $ oneConcat picture ones picture (Clip    (_,xs) cp pic) =      bracketTrafos xs $ do { lbl <- newClipLabel-                          ; d1  <- clipPath lbl cp+                          ; let d1 = clipPath lbl cp                           ; d2  <- picture pic                           ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2))                           } @@ -204,11 +204,20 @@   primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc-primitive (PPath props pp)      = primPath props pp-primitive (PLabel props lbl)    = primLabel props lbl+primitive (PPath props pp)      +    | isEmptyPath pp            = pure empty+    | otherwise                 = primPath props pp++primitive (PLabel props lbl)    +    | isEmptyLabel lbl          = pure empty+    | otherwise                 = primLabel props lbl+ primitive (PEllipse props ell)  = primEllipse props ell+ primitive (PContext fa chi)     = bracketGS fa (primitive chi)+ primitive (PSVG anno chi)       = svgAnnoPrim anno <$> primitive chi+ primitive (PGroup ones)         = oneConcat primitive ones   @@ -230,15 +239,13 @@ svgAttribute :: SvgAttr -> Doc svgAttribute (SvgAttr n v) = svgAttr n $ text v  -clipPath :: PSUnit u => String -> PrimPath u -> SvgMonad Doc+clipPath :: PSUnit u => String -> PrimPath u -> Doc clipPath clip_id pp = -    (\doc -> elem_clipPath (attr_id clip_id) (elem_path_no_attrs doc)) -      <$> path pp+    elem_clipPath (attr_id clip_id) (elem_path_no_attrs $ path pp)    primPath :: PSUnit u => PathProps -> PrimPath u -> SvgMonad Doc-primPath props pp = (\(a,f) d -> elem_path a (f d)) -                      <$> pathProps props <*> path pp+primPath props pp = (\(a,f) -> elem_path a (f $ path pp)) <$> pathProps props  -- -- Paths are printed as absolute paths. Internally they are @@ -252,9 +259,9 @@ -- an encouragement to change when it moved to relative ones.  --  -path :: PSUnit u => PrimPath u -> SvgMonad Doc+path :: PSUnit u => PrimPath u -> Doc path (PrimPath start xs) = -    pure $ path_m start <+> hsep (snd $ mapAccumL step start xs)+    path_m start <+> hsep (snd $ mapAccumL step start xs)   where     step pt (RelLineTo v)         = let p1 = pt .+^ v in (p1, path_l p1)     step pt (RelCurveTo v1 v2 v3) = let p1 = pt .+^ v1 @@ -287,16 +294,15 @@   - -- Note - if hw==hh then draw the ellipse as a circle. -- primEllipse :: (Real u, Floating u, PSUnit u)             => EllipseProps -> PrimEllipse u -> SvgMonad Doc primEllipse props (PrimEllipse hw hh ctm)      | hw == hh  = (\a b -> elem_circle (a <+> circle_radius <+> b))-                    <$> bracketPrimCTM ctm mkCXCY <*> ellipseProps props+                    <$> bracketEllipseCTM ctm mkCXCY <*> ellipseProps props     | otherwise = (\a b -> elem_ellipse (a <+> ellipse_radius <+> b))-                    <$> bracketPrimCTM ctm mkCXCY <*> ellipseProps props+                    <$> bracketEllipseCTM ctm mkCXCY <*> ellipseProps props   where    mkCXCY (P2 x y) = pure $ attr_cx x <+> attr_cy y    @@ -328,7 +334,7 @@       => LabelProps -> PrimLabel u -> SvgMonad Doc primLabel (LabelProps rgb attrs) (PrimLabel body ctm) =      (\fa ca -> elem_text (fa <+> ca) (makeTspan rgb dtext))-      <$> deltaFontAttrs attrs <*> bracketPrimCTM ctm coordf+      <$> deltaFontAttrs attrs <*> bracketTextCTM ctm coordf                                   where     coordf = \p0 -> pure $ labelBodyCoords body p0@@ -346,7 +352,7 @@   encodedText :: EscapedText -> Doc-encodedText enctext = hcat $ map svgChar $ getEscapedText enctext+encodedText enctext = hcat $ destrEscapedText (map svgChar) enctext  kerningText :: [KerningChar u] -> Doc kerningText xs = hcat $ map (\(_,c) -> svgChar c) xs@@ -503,15 +509,44 @@     trafo = attr_transform $ val_matrix mtrx  --- Note - the otherwise step uses the origina ctm (ctm0).+-- Note - there are versions of the /same/ function for text and +-- ellipses. -- -bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u)+-- For text we always want a matrix transformation in the +-- generated SVG - wumpus has flipped the page coordinates, so+-- it must flip text accordingly.+--+-- For ellipses and circles we dont\'t have to bother with the+-- rectifying flip transformation /if/ the ellipse or circle has +-- not been scaled or rotated.+--+bracketTextCTM :: forall u. (Real u, Floating u, PSUnit u)                => PrimCTM u                 -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc-bracketPrimCTM ctm0 pf = step $ unCTM ctm0+bracketTextCTM ctm0 pf = (\xy -> xy <+> mtrx) <$> pf zeroPt   where+    mtrx = attr_transform $ val_matrix $ matrixRepCTM ctm0+++-- Note - the otherwise step uses the original ctm (ctm0).+-- +-- Note v0.41.0 otherwise step always fires because the matrix +-- has been transformed for SVG coordspace to [1,0,0,-1].+--+bracketEllipseCTM :: forall u. (Real u, Floating u, PSUnit u)+                  => PrimCTM u +                  -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc+bracketEllipseCTM ctm0 pf = step $ unCTM ctm0+  where     step (pt, ctm) -        | ctm == identityCTM  = pf pt+        | ctm == flippedCTM   = pf pt         | otherwise           = let mtrx = attr_transform $                                               val_matrix $ matrixRepCTM ctm0                                 in (\xy -> xy <+> mtrx) <$> pf zeroPt+++flippedCTM :: Num u => PrimCTM u+flippedCTM = PrimCTM { ctm_transl_x = 0,  ctm_transl_y = 0+                     , ctm_scale_x  = 1,  ctm_scale_y  = (-1)+                     , ctm_rotation = 0 }+

@@ -43,6 +43,8 @@   , lineTo   , curveTo   , vertexPath+  , vectorPath+  , emptyPath   , curvedPath   , xlinkhref   , xlink@@ -115,6 +117,7 @@ import Wumpus.Core.TrafoInternal import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators hiding ( fill )+import Wumpus.Core.Utils.HList import Wumpus.Core.Utils.JoinList  import Data.AffineSpace                         -- package: vector-space@@ -214,17 +217,21 @@ -- | 'curveTo' : @ control_point1 * control_point2 * end_point ->  --        path_segment @ -- --- Create a curved PathSegment, the start point is --- implicitly the previous point in a path.+-- Create a curved PathSegment, the start point is implicitly the +-- previous point in a path. -- -- curveTo :: Point2 u -> Point2 u -> Point2 u -> AbsPathSegment u curveTo = AbsCurveTo  --- | Convert the list of vertices to a path of straight line +-- | 'vertexPath' : @ [point] -> PrimPath @+-- +-- Convert the list of vertices to a path of straight line  -- segments. --+-- This function throws an error when supplied the empty list.+-- vertexPath :: Num u => [Point2 u] -> PrimPath u vertexPath []     = error "Picture.vertexPath - empty point list" vertexPath (x:xs) = PrimPath x $ snd $ mapAccumL step x xs@@ -232,7 +239,30 @@     step a b = let v = b .-. a in (b, RelLineTo v)  +-- | 'vectorPath' : @ start_point -> [next_vector] -> PrimPath @+-- +-- Build a \"relative\" path from the start point, appending +-- successive straight line segments formed from the list of +-- next_vectors.+-- +-- This function can be supplied with an empty list - this +-- simulates a null graphic.+--+vectorPath :: Num u => Point2 u -> [Vec2 u] -> PrimPath u+vectorPath pt xs = PrimPath pt $ map RelLineTo xs ++-- | 'emptyPath' : @ start_point -> PrimPath @+-- +-- Build an empty path. The start point must be specified even+-- though the path is not drawn - a start point is the minimum +-- information needed to calculate a bounding box. +--+emptyPath :: Num u => Point2 u -> PrimPath u+emptyPath pt  = PrimPath pt []+++ -- | Convert a list of vertices to a path of curve segments. -- The first point in the list makes the start point, each curve  -- segment thereafter takes 3 points. /Spare/ points at the end @@ -418,10 +448,10 @@ -- textlabel :: Num u            => RGBi -> FontAttr -> String -> Point2 u -> Primitive u-textlabel rgb attr txt pt = rtextlabel rgb attr txt pt 0+textlabel rgb attr txt pt = rtextlabel rgb attr txt 0 pt --- | 'rtextlabel' : @ rgb * font_attr * string * baseline_left * ---      rotation -> Primitive @+-- | 'rtextlabel' : @ rgb * font_attr * string * rotation * +--      baseline_left -> Primitive @ -- -- Create a text label rotated by the supplied angle about the  -- baseline-left. @@ -429,7 +459,7 @@ -- The supplied point is the left baseline. -- rtextlabel :: Num u -           => RGBi -> FontAttr -> String -> Point2 u -> Radian -> Primitive u+           => RGBi -> FontAttr -> String -> Radian -> Point2 u -> Primitive u rtextlabel rgb attr txt pt theta =      rescapedlabel rgb attr (escapeString txt) pt theta @@ -444,7 +474,8 @@   --- | 'escapedlabel' : @ rgb * font_attr * escaped_text * baseline_left -> Primitive @+-- | 'escapedlabel' : @ rgb * font_attr * escaped_text * +--      baseline_left -> Primitive @ -- -- Version of 'textlabel' where the label text has already been  -- parsed for special characters.@@ -453,10 +484,10 @@ -- escapedlabel :: Num u               => RGBi -> FontAttr -> EscapedText -> Point2 u -> Primitive u-escapedlabel rgb attr txt pt = rescapedlabel rgb attr txt pt 0+escapedlabel rgb attr txt pt = rescapedlabel rgb attr txt 0 pt --- | 'rescapedlabel' : @ rgb * font_attr * escaped_text * baseline_left * ---      rotation -> Primitive @+-- | 'rescapedlabel' : @ rgb * font_attr * escaped_text * rotation * +--      baseline_left -> Primitive @ -- -- Version of 'rtextlabel' where the label text has already been  -- parsed for special characters.@@ -464,8 +495,9 @@ -- The supplied point is the left baseline. -- rescapedlabel :: Num u -              => RGBi -> FontAttr -> EscapedText -> Point2 u -> Radian -> Primitive u-rescapedlabel rgb attr txt (P2 dx dy) theta = PLabel (LabelProps rgb attr) lbl +              => RGBi -> FontAttr -> EscapedText -> Radian -> Point2 u +              -> Primitive u+rescapedlabel rgb attr txt theta (P2 dx dy) = PLabel (LabelProps rgb attr) lbl    where     lbl = PrimLabel (StdLayout txt) (makeThetaCTM dx dy theta) @@ -761,7 +793,7 @@ -- illustrateBounds :: (Real u, Floating u, FromPtSize u)                   => RGBi -> Picture u -> Picture u-illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb p) +illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb p $ [])    -- | 'illustrateBoundsPrim' : @ bbox_rgb * primitive -> Picture @@@ -773,7 +805,7 @@ --  illustrateBoundsPrim :: (Real u, Floating u, FromPtSize u)                       => RGBi -> Primitive u -> Picture u-illustrateBoundsPrim rgb p = frame (p : boundsPrims rgb p)+illustrateBoundsPrim rgb p = frame $ boundsPrims rgb p $ [p]   @@ -781,8 +813,8 @@ -- joining the corners. -- boundsPrims :: (Num u, Ord u, Boundary t, u ~ DUnit t) -            => RGBi -> t -> [Primitive u]-boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ]+            => RGBi -> t -> H (Primitive u)+boundsPrims rgb a = fromListH $ [ 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]@@ -801,18 +833,14 @@ -- This has no effect on TextLabels. Nor does it draw Beziers of  -- a hyperlinked object. -- --- Pseudo control points are generated for ellipses, although --- strictly speaking ellipses do not use Bezier curves - they --- are implemented with PostScript\'s @arc@ command.  --- illustrateControlPoints :: (Real u, Floating u, FromPtSize u)                         => RGBi -> Primitive u -> Picture u-illustrateControlPoints rgb elt = frame $ elt : step elt+illustrateControlPoints rgb elt = frame $ fn elt   where-    step (PEllipse _ e) = ellipseCtrlLines rgb e-    step (PPath    _ p) = pathCtrlLines rgb p-    step a              = [a]+    fn (PPath    _ p) = pathCtrlLines rgb p $ [elt]+    fn a              = [a] + -- Genrate lines illustrating the control points of curves on  -- a Path. --@@ -821,76 +849,18 @@ -- -- Nothing is generated for a straight line. ---pathCtrlLines :: (Num u, Ord u) => RGBi -> PrimPath u -> [Primitive u]+pathCtrlLines :: (Num u, Ord u) => RGBi -> PrimPath u -> H (Primitive u) pathCtrlLines rgb (PrimPath start ss) = step start ss   where      step s (RelLineTo v:xs)         = step (s .+^ v) xs      step s (RelCurveTo v1 v2 v3:xs) = let e   = s .+^ (v1 ^+^ v2 ^+^ v3)                                           v3r = vreverse v3-                                      in mkLine s v1 : mkLine e v3r : step e xs+                                      in mkLine s v1 `consH` mkLine e v3r +                                                     `consH` step e xs -    step _ []                       = []+    step _ []                       = emptyH      mkLine s v                      = let pp = (PrimPath s [RelLineTo v])                                        in ostroke rgb default_stroke_attr pp ----- Generate lines illustrating the control points of an --- ellipse:--- --- Two lines for each quadrant: --- start-point to control-point1; control-point2 to end-point----ellipseCtrlLines :: (Real u, Floating u) -                 => RGBi -> PrimEllipse u -> [Primitive u]-ellipseCtrlLines rgb pe = start all_points-  where -    -- list in order: -    -- [s,cp1,cp2,e, cp1,cp2,e, cp1,cp2,e, cp1,cp2,e]--    all_points           = ellipseControlPoints pe--    start (s:c1:c2:e:xs) = mkLine s c1 : mkLine c2 e : rest e xs-    start _              = []--    rest s (c1:c2:e:xs)  = mkLine s c1 : mkLine c2 e : rest e xs-    rest _ _             = []--    mkLine s e  = let path = PrimPath s [RelLineTo (e .-. s)]-                  in ostroke rgb default_stroke_attr path------ | Get the control points as a list--- --- There are no duplicates in the list except for the final --- /wrap-around/. We take 4 points initially (start,cp1,cp2,end)--- then (cp1,cp2,end) for the other three quadrants.----ellipseControlPoints :: (Floating u, Real u)-                     => PrimEllipse u -> [Point2 u]-ellipseControlPoints (PrimEllipse hw hh ctm) = map (new_mtrx *#) circ-  where-    (radius,(dx,dy)) = circleScalingProps hw hh-    new_mtrx         = matrixRepCTM $ scaleCTM dx dy ctm-    circ             = bezierCircle 1 radius (P2 0 0)--    -- subdivide the bezierCircle with 1 to get two-    -- control points per quadrant.    -------- I don't know how to calculate bezier arcs (and thus control--- points) for an ellipse but I know how to do it for a circle...------ So a make a circle with the largest of half-width and --- half-height then apply a scale to the points--- -circleScalingProps  :: (Fractional u, Ord u) => u -> u -> (u,(u,u))-circleScalingProps hw hh  = (radius, (dx,dy))-  where-    radius     = max hw hh-    (dx,dy)    = if radius == hw then (1, rescale (0,hw) (0,1) hh)-                                 else (rescale (0,hh) (0,1) hw, 1) 

@@ -55,6 +55,8 @@   , repositionDeltas    , zeroGS+  , isEmptyPath+  , isEmptyLabel    ) where @@ -321,9 +323,6 @@   --- -------------------------------------------------------------------------------- -- Graphics state datatypes @@ -794,4 +793,18 @@      no_encoding      = IntMap.empty  ++-- | Is the path empty - if so we might want to avoid printing it.+--+isEmptyPath :: PrimPath u -> Bool+isEmptyPath (PrimPath _ xs) = null xs++-- | Is the label empty - if so we might want to avoid printing it.+--+isEmptyLabel :: PrimLabel u -> Bool+isEmptyLabel (PrimLabel txt _) = body txt+   where+     body (StdLayout esc) = destrEscapedText null esc+     body (KernTextH xs)  = null xs+     body (KernTextV xs)  = null xs 

@@ -62,6 +62,14 @@   , ps_show   , ps_glyphshow +  , ps_wumpus_FELL+  , ps_wumpus_SELL+  , ps_wumpus_FCIRC+  , ps_wumpus_SCIRC+  , ps_wumpus_FL++  , ps_wumpus_prolog+   )  where  import Wumpus.Core.BoundingBox@@ -361,3 +369,134 @@ ps_glyphshow :: String -> Doc ps_glyphshow ss = command "glyphshow" [text $ '/':ss] ++--------------------------------------------------------------------------------+++-- | @ X Y RX RY FELL  @+--+-- Custom Wumpus proc for filled ellipse.+--+ps_wumpus_FELL :: PSUnit u => Point2 u -> u -> u -> Doc+ps_wumpus_FELL (P2 x y) rx ry = +    command "FELL" $ map dtruncFmt [x, y, rx, ry]++++-- | @ X Y RX RY SELL  @+--+-- Custom Wumpus proc for stroked ellipse.+--+ps_wumpus_SELL :: PSUnit u => Point2 u -> u -> u -> Doc+ps_wumpus_SELL (P2 x y) rx ry = +    command "SELL" $ map dtruncFmt [x, y, rx, ry]++++-- | @ X Y R FCIRC  @+--+-- Custom Wumpus proc for filled circle.+--+ps_wumpus_FCIRC :: PSUnit u => Point2 u -> u -> Doc+ps_wumpus_FCIRC (P2 x y) r = command "FCIRC" $ map dtruncFmt [x, y, r]++-- | @ X Y R SCIRC  @+--+-- Custom Wumpus proc for stroked circle.+--+ps_wumpus_SCIRC :: PSUnit u => Point2 u -> u -> Doc+ps_wumpus_SCIRC (P2 x y) r = command "SCIRC" $ map dtruncFmt [x, y, r]++-- | @ SZ NAME FL  @+--+-- Custom Wumpus proc for findfont, fontsize, setfont.+--+ps_wumpus_FL :: Int -> String -> Doc+ps_wumpus_FL sz name = command "FL" $ [int sz, text $ '/':name]++++--------------------------------------------------------------------------------+++++ps_wumpus_prolog :: Doc+ps_wumpus_prolog = vcat $ map text $+    [ "/RY 0 def"+    , "/RX 0 def"+    , "/Y 0 def"+    , "/X 0 def"+    , "/R 0 def"+    , ""+    , "% Filled ellipse"+    , "/FELL     % X Y RX RY FELL"+    , "{"+    , "  /RY exch def"+    , "  /RX exch def"+    , "  /Y  exch def"+    , "  /X  exch def"+    , "  X Y translate"+    , "  1 RY RX div scale"+    , "  newpath"+    , "  0 0 RX 0.0 360.0 arc"+    , "  closepath"+    , "  fill"+    , "  1 RX RY div scale"+    , "  X neg Y neg translate"+    , "} bind def"+    , ""+    , ""+    , "% Stroked ellipse"+    , "/SELL     % X Y RX RY SELL"+    , "{"+    , "  /RY exch def"+    , "  /RX exch def"+    , "  /Y  exch def"+    , "  /X  exch def"+    , "  X Y translate"+    , "  1 RY RX div scale"+    , "  newpath"+    , "  0 0 RX 0.0 360.0 arc"+    , "  closepath"+    , "  stroke"+    , "  1 RX RY div scale"+    , "  X neg Y neg translate"+    , "} bind def"+    , ""+    , ""+    , "% Stroked circle"+    , "/SCIRC     % X Y R SCIRC"+    , "{"+    , "  /R exch def"+    , "  /Y  exch def"+    , "  /X  exch def"+    , "  newpath"+    , "  X Y R 0.0 360.0 arc"+    , "  closepath"+    , "  stroke"+    , "} bind def"+    , ""+    , ""+    , "% Filled circle"+    , "/FCIRC     % X Y R FCIRC"+    , "{"+    , "  /R exch def"+    , "  /Y  exch def"+    , "  /X  exch def"+    , "  newpath"+    , "  X Y R 0.0 360.0 arc"+    , "  closepath"+    , "  fill"+    , "} bind def"+    , ""+    , ""+    , "% Font load"+    , "/FL   % SZ NAME FL"+    , "{"+    , "  findfont exch"+    , "  scalefont"+    , "  setfont"+    , "} bind def"+    , ""+    ]

@@ -67,11 +67,13 @@ module Wumpus.Core.Text.Base   (  -    EscapedText(..)    +    EscapedText   , EscapedChar(..)   , EncodingVector    , escapeString+  , wrapEscChar+  , destrEscapedText   , textLength      ) where@@ -92,6 +94,7 @@   deriving (Eq,Show)  + -- | Internal character representation for Wumpus-Core. --  -- An 'EscapedChar' may be either a regular character, an integer@@ -150,11 +153,21 @@ escapeString :: String -> EscapedText escapeString = EscapedText . lexer +-- | Build an 'EscapedText' from a single 'EscChar'.+--+wrapEscChar :: EscapedChar -> EscapedText+wrapEscChar ec = EscapedText [ec] +-- | /Destructor/ for 'EscapedText'.+--+destrEscapedText :: ([EscapedChar] -> a) -> EscapedText -> a+destrEscapedText f = f . getEscapedText++ -- | Get the character count of an 'EscapedText' string. -- textLength :: EscapedText -> Int-textLength = length . getEscapedText +textLength = destrEscapedText length  -- -- Design note.

@@ -124,6 +124,9 @@ translateCTM x1 y1 (PrimCTM dx dy sx sy ang) =      PrimCTM (x1+dx) (y1+dy) sx sy ang +++ -- Note - the matrix is not used entirely conventionally. -- -- It is expected that the point is extracted from the matrix, so@@ -151,7 +154,8 @@ -- of a point) and the CTM is crucial as matrix multiplication is  -- not commutative. ----- This function encapsulates the correct order.+-- This function encapsulates the correct order (or does it? - +-- some of the demos are not working properly...). -- matrixRepCTM :: (Real u, Floating u) => PrimCTM u -> Matrix3'3 u matrixRepCTM (PrimCTM dx dy sx sy ang) = 

@@ -40,14 +40,6 @@   -- * PostScript time stamp   , psTimeStamp -  -- * Hughes list-  , H-  , emptyH-  , wrapH-  , consH-  , snocH  -  , appendH-  , toListH    ) where @@ -162,31 +154,5 @@  floori :: RealFrac a => a -> Int floori = floor--------------------------------------------------------------------------------------- Hughes list--type H a = [a] -> [a]--emptyH :: H a-emptyH = id---wrapH :: a -> H a-wrapH a = consH a id --consH :: a -> H a -> H a-consH a f = (a:) . f--snocH :: H a -> a -> H a-snocH hl a = hl . (a:)--appendH :: H a -> H a -> H a-appendH f g = f . g--toListH :: H a -> [a]-toListH = ($ [])  

@@ -0,0 +1,92 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Utils.HList+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Hughes list+--+--------------------------------------------------------------------------------++module Wumpus.Core.Utils.HList+  (++  -- * Hughes list+    H+  , emptyH+  , wrapH+  , consH+  , snocH+  , appendH+  , unfoldrH+  , veloH+  , concatH++  , toListH+  , fromListH+++  ) where++++--------------------------------------------------------------------------------+-- Hughes list++type H a = [a] -> [a]++emptyH :: H a+emptyH = id++wrapH :: a -> H a+wrapH a = consH a id ++infixr 5 `consH`++consH :: a -> H a -> H a+consH a f = (a:) . f++snocH :: H a -> a -> H a+snocH  f a = f . (a:)++appendH :: H a -> H a -> H a+appendH f g = f . g++++unfoldrH :: (b -> Maybe (a,b)) -> b -> H a+unfoldrH phi = step+  where step b = case phi b of+                  Nothing -> emptyH+                  Just (a,s) -> a `consH` step s+++-- | velo consumes the list as per map, but builds it back+-- as a Hughes list - so items can be dropped+-- replaced, repeated, etc...+-- +veloH :: (a -> H b) -> [a] -> H b+veloH f = foldr step id +  where step a hf = f a . hf++concatH :: [H a] -> H a+concatH = foldr (.) id+++toListH :: H a -> [a]+toListH = ($ [])++fromListH :: [a] -> H a+fromListH xs = (xs++)+++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+

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

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.40.0+version:          0.41.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -42,8 +42,14 @@   systems. However, the design permits a fairly simple    implementation, which is a priority.    .  -  UPDATING to 0.40.0   .+  UPDATING from 0.37.0 or earlier to 0.41.0.+  .+  There were substantial changes in verion 0.40.0 - hence the +  version number jump from 0.37.0. Version 0.41.0 introduces +  mostly cosmetic changes, but for upgrading from 0.37.0 or+  earlier the change-notes that follow are still relevant.+  .   @Core.Picture@ API change - the path construction function has    changed from @path@ to @primPath@. The type of the path segments   has changed, the functions @lineTo@ and @curveTo@ now build@@ -75,8 +81,49 @@   .   Changelog:   . -  0.37.0 to 0.40.0: +  v0.40.0 to v0.41.0:   .+  * Changed PostScript output to use pre-defined procedures for +    circles and ellipses. This should be a significant +    optimization for drawings that have many circles or ellipses.+    For drawings that do not use circles or ellipses, it adds +    circa. 75 lines to the generated PostScript which is +    tolerable.+  .+  * API change - @Core.Text.Base@ no longer exports the +    constructor and field label for @EscapedText@, it is now an +    opaque type. For a building @EscapedText@ either the existing +    /safe/constructor @escapeString@ or the new function +    @wrapEscChar@ should be used. For destructing @EscapedText@ +    there is a new function @destrEscapedText@.+  .+  * API change - the argument order of the functions @rtextlabel@ +    and @rescapedlabel@ in @Core.Picture@ has changed. The order +    of angle of rotation and the baseline-left has been swapped so +    that angle of rotation is first. This matches the other +    rotated graphics in @Core.Picture@.+  .+  * Upper bounds of Cabal build depends relaxed a bit.+  . +  * Added the @UNil@ type to @Core.Geometry@ and added affine +    instances for the UNil type, plus Maybe and Pair. @UNil@ is+    useful for higher-level drawing (it is used extensively in+    Wumpus-Basic).+  .+  * Added the function @emptyPath@ to @Core.Picture@. This creates +    a /null path/ with an empty list of path segments. Null paths +    still need a start point - this is minimum needed for bounding +    box calculation. Improved the PostScript and SVG output so +    there is no code generated for empty paths and textlabels.+  .+  * Added @vectorPath@ to @Core.Picture@.+  .+  * Added @boundaryCenter@ to @Core.BoundingBox@.+  .+  * Improved generated SVG code generation for ellipses / circles.+  .+  v0.37.0 to v0.40.0: +  .   * Text handling substantially revised. SVG text output is now      better aligned to Unicode. The encoding tables for PostScript     have been re-thought, the previous implementation had some @@ -165,9 +212,9 @@ library   hs-source-dirs:     src   build-depends:      base            <  5, -                      containers      >= 0.3      && <= 0.4, -                      time            >= 1.1.3    && < 1.2,-                      vector-space    >= 0.6      && < 1.0+                      containers      >= 0.3      && <= 0.6, +                      time            >= 1.1.3    && <  1.6,+                      vector-space    >= 0.6      && <  1.0                            exposed-modules:     Wumpus.Core,@@ -197,6 +244,7 @@     Wumpus.Core.SVGDoc,     Wumpus.Core.TrafoInternal,     Wumpus.Core.Utils.Common,+    Wumpus.Core.Utils.HList,     Wumpus.Core.Utils.JoinList,     Wumpus.Core.Utils.FormatCombinators