wumpus-core 0.36.0 → 0.37.0

raw patch · 17 files changed

+528/−311 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +76/−0
• demo/DeltaPic.hs +5/−2
• doc-src/Guide.lhs +12/−8
• doc/Guide.pdf binary
• src/Wumpus/Core/AffineTrans.hs +1/−1
• src/Wumpus/Core/BoundingBox.hs +18/−11
• src/Wumpus/Core/FontSize.hs +1/−1
• src/Wumpus/Core/OutputPostScript.hs +7/−5
• src/Wumpus/Core/OutputSVG.hs +36/−26
• src/Wumpus/Core/PageTranslation.hs +3/−2
• src/Wumpus/Core/Picture.hs +44/−22
• src/Wumpus/Core/PictureInternal.hs +50/−32
• src/Wumpus/Core/PtSize.hs +1/−1
• src/Wumpus/Core/Utils/JoinList.hs +240/−0
• src/Wumpus/Core/Utils/OneList.hs +0/−133
• src/Wumpus/Core/VersionNumber.hs +2/−2
• wumpus-core.cabal +32/−65

@@ -1,4 +1,80 @@ ++0.36.0 to 0.37.0:++  * The bounding box constructors have been renamed - @bbox@ is +    now @boundingBox@ and @obbox@ becomes @oboundingBox@. The +    rationale for this change is that the names very cryptic in +    the first place and the constructors are used infrequently +    when @bbox@ in particular makes a descriptive variable name.++  * Changes to the Picture and Primitive types to enable better+    concatenation which is used heavily by Wumpus-Basic. The +    Picture API exposes a new function @primCat@.++  * SVG /font delta context/ change - font deltas are now +    annotated on Primitives not Pictures. The type of the +    function @fontDeltaContext@ in @Core.Picture@ has changed +    accordingly.++  * SVG hyperlink change - hyperlinks no longer group primitives+    (although a group of primitives can be hyperlinked). The +    function @xlinkGroup@ has been removed from @Core.Picture@, +    it is replaced by @xlink@.++  * @Core.Picture@ - the argument order for the function +    @rtextlabel@ has been changed, the positions of the angle and +    bottom-left corner have been swapped.++0.35.0 to 0.36.0:++  * API / behaviour change - rotation on primitives changed. New +    functions have been added to create rotated text labels and +    ellipses (@rtextlabel@, @rstrokeEllipse@, etc.), and +    Primitives have been made instances of the Affine classes+    except for the general matrix Transform class. The old+    functions for transforming Primitives (@rotatePrim@, +    @scalePrim@, etc.) have been removed. The demos (Rotated.hs,+    Scaled.hs, Translated.hs) have been removed as they pertain +    to the old behaviour, there are new demos highlighting the+    new behaviour (TransformEllipse.hs, etc.).++  * Major change - removed the PrimElement type. The (opaque) +    Primitive type has been changed to incorporate a grouping +    constructor equivalent to PrimElement\'s @XLinkGroup@ +    contructor. The change has made the implementation of SVG +    hyperlinks more efficient, but has forced various type +    signatures to change in @Core.Picture@. Client code will +    also have to change type signatures - @PrimElement@ becomes+    @Primitive@.++  * @Core.PtSize@ - the class @FromPtSize@ has been given a @Num@+    superclass constraint. This can shorten type signatures of +    functions that use @fromPtSize@.++  * Corrected a bug where textlabels would generate an invalid+    bounding box and cause a runtime error when supplied with an+    empty string. Now there is no runtime error - and /no-ops/ +    are generated in the output.++  * Internal changes - moved @PrimCTM@ from @Core.PictureInternal@+    into separate module. Moved /utility/ modules into their own +    directory @Utils@. Move /text/ modules into their own +    directory @Text@. ++  * Removed dependency on @algebra@ for @Semigroup@. The +    equivalent @append@ operation on @BoundingBox@ is +    @boundaryUnion@.++  * Renamed the @Core.GraphicsState@ to @Core.GraphicProps@. +    Moved the property datatypes from @Core.PictureInternal@ into +    @Core.GraphicProps@ (StrokeProps, LabelProps, etc.).++  * Moved @wumpus_default_font@ from @Core.Picture@ into +    @Core.Graphic.Props@.++  * Haddock docs improved.+ 0.34.0 to 0.35.0:    * Bug fix - PostScript output - when more than one stroke 

@@ -1,6 +1,9 @@ {-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-} +-- SVG ouptut has some ability to minimization font change code.+-- This example demonstrates it.+ module DeltaPic where  import Wumpus.Core@@ -25,14 +28,14 @@   pic1 :: DPicture-pic1 = fontDeltaContext delta_ctx $ frame +pic1 = frame1 $ fontDeltaContext delta_ctx $ primGroup             [ 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- +   frame1 a   = frame [a]   common_ff :: FontFace common_ff = FontFace "Helvetica" "Helvetica" SVG_REGULAR latin1_font_encoder

@@ -23,7 +23,7 @@ \section{About \wumpuscore}
 %-----------------------------------------------------------------
 
-This guide was last updated for \wumpuscore version 0.36.0.
+This guide was last updated for \wumpuscore version 0.37.0.
 
 \wumpuscore is a Haskell library for generating 2D vector 
 pictures. It was written with portability as a priority, so it has 
@@ -124,14 +124,15 @@ type to represent them.
 
 \item[\texttt{Wumpus.Core.TextEncoder.}]
-Types for handling extended character codes e.g. for accented 
-characters or the Symbol font. Special characters generally have 
-to be escaped in the PostScript and SVG output, this module 
-provides data types for lookup tables between the escaped 
-character code and its PostScript or SVG representation. 
+Types for handling extended character codes within fonts e.g. 
+for accented characters or the Symbol font. Special characters 
+generally have to be escaped in the PostScript and SVG output, 
+this module provides data types for lookup tables between the 
+escaped character code and its PostScript or SVG representation. 
 Text encoders are associated with fonts - glyphs within a font 
 are located by their character name / code. Currently 
-\wumpuscore has encoders for Latin1 and the Symbol font. 
+\wumpuscore has encoders for the Standard Latin Encoding table 
+and the Symbol font character set. 
 
 \item[\texttt{Wumpus.Core.TextLatin1.}]
 A instance of the TextEncoder type for mapping Latin 1 characters
@@ -315,6 +316,9 @@ \texttt{Wumpus.Basic.SafeFonts} encoding the fonts in this list 
 and matching them to their appropriate \texttt{TextEncoder}.
 
+Note that the Symbol font, whilst incredibly useful, is a taboo
+with the W3C and they do not condone its use in SVG or HTML.
+Likewise, certain browsers reject it out of course.
 
 \begin{tabular}{ l l }
 PostScript name   & SVG name      \\
@@ -331,7 +335,7 @@ Courier-Oblique   & Courier New - style="italic" \\
 Courier-Bold      & Courier New - font-weight="bold" \\
 Courier-Bold-Oblique & Courier New - style="italic", font-weight="bold" \\
-Symbol & Symbol \\
+Symbol & (Symbol - see text) \\
 \hline
 \end{tabular}
 

binary file changed (59778 → 60184 bytes)

@@ -150,7 +150,7 @@ -- | Type class for translation. -- class Translate t where-  translate :: DUnit t -> DUnit t -> t -> t+  translate :: u ~ DUnit t => u -> u -> t -> t  instance Num u => Translate (Point2 u) where   translate dx dy (P2 x y) = P2 (x+dx) (y+dy)

@@ -31,9 +31,11 @@   -- * Type class   , Boundary(..)   +  -- * Constructors+  , boundingBox+  , oboundingBox+     -- * Operations-  , bbox-  , obbox   , destBoundingBox   , boundaryUnion    , traceBoundary@@ -124,27 +126,32 @@  -------------------------------------------------------------------------------- --- | 'bbox' : @lower_left_corner * upper_right_corner -> BoundingBox@+-- | 'boundingBox' : @lower_left_corner * upper_right_corner -> BoundingBox@ -- -- Contruct a bounding box, vis the BBox constructor with range  -- checking on the corner points. ----- @bbox@ throws an error if the width or height of the +-- 'boundingBox' throws an error if the width or height of the  -- constructed bounding box is negative. ---bbox :: Ord u => Point2 u -> Point2 u -> BoundingBox u-bbox ll@(P2 x0 y0) ur@(P2 x1 y1) -   | x0 <= x1 && y0 <= y1 = BBox ll ur -   | otherwise            = error "Wumpus.Core.BoundingBox.bbox - malformed."+boundingBox :: Ord u => Point2 u -> Point2 u -> BoundingBox u+boundingBox ll@(P2 x0 y0) ur@(P2 x1 y1) +    | x0 <= x1 && y0 <= y1 = BBox ll ur +    | otherwise            = error "Wumpus.Core.boundingBox - malformed."  --- | 'obbox' : @width * height -> BoundingBox@+-- | 'oboundingBbox' : @width * height -> BoundingBox@ -- -- Create a BoundingBox with bottom left corner at the origin, -- and dimensions @w@ and @h@. ---obbox :: Num u => u -> u -> BoundingBox u-obbox w h = BBox zeroPt (P2 w h)+-- 'oboundingBox' throws an error if either the suppplied width +-- or height is negative.+-- +oboundingBox :: (Num u, Ord u) => u -> u -> BoundingBox u+oboundingBox w h +    | h >= 0 && w >= 0 = BBox zeroPt (P2 w h)+    | otherwise        = error "Wumpus.Core.oboundingBox - malformed."  -- | 'destBoundingBox' : @ bbox -> (lower_left_x, lower_lefy_y,  --      upper_right_x, upper_right_y)@

@@ -247,7 +247,7 @@  textBoundsBody :: (Num u, Ord u, FromPtSize u)                 => FontSize -> Point2 u -> Int -> BoundingBox u-textBoundsBody sz baseline_left len = bbox bl tr +textBoundsBody sz baseline_left len = boundingBox bl tr    where     h           = fromPtSize $ textHeight sz     w           = fromPtSize $ textWidth  sz len

@@ -38,7 +38,7 @@ import Wumpus.Core.Text.TextInternal import Wumpus.Core.TrafoInternal import Wumpus.Core.Utils.Common-import Wumpus.Core.Utils.OneList+import Wumpus.Core.Utils.JoinList import Wumpus.Core.Utils.FormatCombinators  @@ -279,14 +279,13 @@ picture :: (Real u, Floating u, PSUnit u) => Picture u -> PsMonad Doc picture (Leaf    (_,xs) ones)   = bracketTrafos xs $ oneConcat primitive ones picture (Picture (_,xs) ones)   = bracketTrafos xs $ oneConcat picture ones-picture (Group   (_,xs) _ pic) = bracketTrafos xs (picture pic) picture (Clip    (_,xs) cp pic) = bracketTrafos xs $     (\d1 d2 -> vcat [ps_gsave,d1,d2,ps_grestore])       <$> clipPath cp <*> picture pic <* resetGS   -oneConcat :: (a -> PsMonad Doc) -> OneList a -> PsMonad Doc+oneConcat :: (a -> PsMonad Doc) -> JoinList a -> PsMonad Doc oneConcat fn ones = outstep (viewl ones)   where     outstep (e :< rest)   = fn e >>= \a -> instep a (viewl rest)@@ -296,14 +295,17 @@     instep ac (e :< rest) = fn e >>= \a -> instep (ac `vconcat` a) (viewl rest)  --- No action is taken for hyperlinks in PostScript.+-- No action is taken for hyperlinks or font context changes in +-- PostScript. --  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 (PEllipse props ell) = primEllipse props ell-primitive (PGroup _ ones)      = oneConcat primitive ones+primitive (PContext _ chi)     = primitive chi+primitive (PLink _ chi)        = primitive chi+primitive (PGroup ones)        = oneConcat primitive ones   primPath :: PSUnit u

@@ -49,7 +49,7 @@ import Wumpus.Core.TrafoInternal import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators-import Wumpus.Core.Utils.OneList+import Wumpus.Core.Utils.JoinList  import Control.Applicative hiding ( empty, some ) import Data.Maybe@@ -106,7 +106,7 @@ askGraphicsState = SvgMonad $ \_ r2 s -> (r2,s)  asksGraphicsState :: (GraphicsState -> a) -> SvgMonad a-asksGraphicsState fn = SvgMonad $ \_ r2 s -> (fn r2,s)+asksGraphicsState fn = fmap fn askGraphicsState  askFontAttr :: SvgMonad FontAttr askFontAttr = asksGraphicsState $ \r -> @@ -189,12 +189,11 @@                           ; d2  <- picture pic                           ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2))                           } -picture (Group   (_,xs) fn pic) = bracketTrafos xs $ bracketGS fn (picture pic)    -oneConcat :: (a -> SvgMonad Doc) -> OneList a -> SvgMonad Doc+oneConcat :: (a -> SvgMonad Doc) -> JoinList a -> SvgMonad Doc oneConcat fn ones = outstep (viewl ones)   where     outstep (e :< rest)   = fn e >>= \a -> instep a (viewl rest)@@ -205,13 +204,12 @@   primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc-primitive (PPath props pp)     = primPath props pp-primitive (PLabel props lbl)   = primLabel props lbl-primitive (PEllipse props ell) = primEllipse props ell-primitive (PGroup mb ones)     = -    case mb of-      Nothing -> oneConcat primitive ones-      Just xl -> drawXLink xl <$> oneConcat primitive ones+primitive (PPath props pp)      = primPath props pp+primitive (PLabel props lbl)    = primLabel props lbl+primitive (PEllipse props ell)  = primEllipse props ell+primitive (PContext fa chi)     = bracketGS fa (primitive chi)+primitive (PLink hypl chi)      = drawXLink hypl <$> primitive chi+primitive (PGroup ones)         = oneConcat primitive ones    drawXLink :: XLink -> Doc -> Doc@@ -405,11 +403,27 @@     attr_stroke_dashoffset n <+> attr_stroke_dasharray xs  +data FontMatch = FullMatch | DeltaPtSize | DeltaFont+  deriving (Eq,Show,Ord)  + deltaFontAttrs :: FontAttr -> SvgMonad Doc-deltaFontAttrs fa = -    (\inh -> if fa == inh then empty else makeFontAttrs fa) <$> askFontAttr+deltaFontAttrs fa = (\inh -> step $ fontMatch inh fa) <$> askFontAttr+  where+    step FullMatch      = empty+    step DeltaPtSize    = attr_font_size $ font_size fa+    step DeltaFont      = makeFontAttrs fa ++fontMatch :: FontAttr -> FontAttr -> FontMatch+fontMatch (FontAttr s1 f1) (FontAttr s2 f2) +   | s1 == s2 && f1 == f2 = FullMatch+   | f1 == f2             = DeltaPtSize+   | otherwise            = DeltaFont++-- Note this is always adding FontSize - there are cases where +-- this is redundant. +-- makeFontAttrs :: FontAttr -> Doc makeFontAttrs (FontAttr sz face) =      attr_font_family (svg_font_family face) <+> attr_font_size sz @@ -430,27 +444,23 @@         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... +-- Always update both the size and font-family even if only one+-- changes.+--+-- This seems more in the spirit of a font delta operation.+-- bracketGS :: FontCtx -> SvgMonad Doc -> SvgMonad Doc bracketGS (FontCtx new_font) mf = -    (\old body -> mkElem old body) -        <$> askGraphicsState <*> runLocalGS updateF mf+    (\old body -> mkElem (old == new_font) body) +        <$> askFontAttr <*> 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+    mkElem True body = elem_g_no_attrs body+    mkElem _    body = let a = makeFontAttrs new_font in elem_g a body      updateF s = s { gs_font_size = font_size new_font                   , gs_font_face = font_face new_font }                 --fontMatch :: GraphicsState -> FontAttr -> Bool-fontMatch gs fa = -   gs_font_size gs == font_size fa && gs_font_face gs == font_face fa   --------------------------------------------------------------------------------

@@ -47,13 +47,14 @@ trivPic (Leaf lc ones)      = Leaf lc $ fmap trivPrim ones trivPic (Picture lc ones)   = Picture lc $ fmap trivPic ones trivPic (Clip lc pp pic)    = Clip lc pp $ trivPic pic-trivPic (Group lc upd pic)  = Group lc upd $ trivPic pic  trivPrim :: Num u => Primitive u -> Primitive u trivPrim (PPath a pp)     = PPath a pp trivPrim (PLabel a lbl)   = PLabel a (trivLabel lbl) trivPrim (PEllipse a ell) = PEllipse a (trivEllipse ell)-trivPrim (PGroup xl ones) = PGroup xl $ fmap trivPrim ones+trivPrim (PContext a chi) = PContext a (trivPrim chi)+trivPrim (PLink a chi)    = PLink a (trivPrim chi)+trivPrim (PGroup ones)    = PGroup $ fmap trivPrim ones   trivLabel :: Num u => PrimLabel u -> PrimLabel u

@@ -30,9 +30,11 @@   , vertexPath   , curvedPath   , xlinkhref-  , xlinkGroup+  , xlink   , primGroup+  , primCat +   -- * Constructing primitives   , ostroke   , cstroke@@ -90,7 +92,7 @@ import Wumpus.Core.TrafoInternal import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators hiding ( fill )-import Wumpus.Core.Utils.OneList+import Wumpus.Core.Utils.JoinList  import Data.AffineSpace                         -- package: vector-space @@ -160,8 +162,8 @@ -- 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+fontDeltaContext :: FontAttr -> Primitive u -> Primitive u+fontDeltaContext fa p = PContext (FontCtx fa) p   -- | Create a Path from a start point and a list of PathSegments.@@ -216,17 +218,10 @@ xlinkhref = XLink  --- | Create a hyperlinked group of Primitives.+-- | Create a hyperlinked Primitive. ----- This function throws a runtime error when supplied with an--- empty list.--- -xlinkGroup :: XLink -> [Primitive u] -> Primitive u-xlinkGroup _     []     = error "Picture.xlinkGroup - empty prims list"-xlinkGroup xlink (x:xs) = PGroup (Just xlink) (step x xs)-  where-    step a []     = one a-    step a (y:ys) = cons a (step y ys) +xlink :: XLink -> Primitive u -> Primitive u+xlink hypl p = PLink hypl p     -- | Group a list of Primitives.@@ -236,11 +231,34 @@ -- primGroup :: [Primitive u] -> Primitive u primGroup []     = error "Picture.primGroup - empty prims list"-primGroup (x:xs) = PGroup Nothing (step x xs)+primGroup (x:xs) = PGroup (step x xs)   where     step a []     = one a     step a (y:ys) = cons a (step y ys)  ++-- | Concatenate two Primitives.+--+-- If both primitves are groups, then the groups are merged.+--+-- If one or other primitive is a group, the singleton is added+-- into the group at the respective end.+--+-- Otherwise a group is formed adding both elements as /children/.+--+-- The Primitive type in Wumpus is a tree. In theory 'primCat' +-- can make flatter and wider trees than 'primGroup', though in +-- practice this may have no noticeable benefit as Wumpus has very +-- simple access patterns into the Primitive tree. +--+primCat :: Primitive u -> Primitive u -> Primitive u+primCat (PGroup a) (PGroup b) = PGroup $ join a b+primCat (PGroup a) prim       = PGroup $ join a (one prim) +primCat prim       (PGroup b) = PGroup $ join (one prim) b+primCat p1         p2         = PGroup $ join (one p1) (one p2) +++ -------------------------------------------------------------------------------- -- Take Paths to Primitives @@ -339,10 +357,10 @@ -- textlabel :: Num u            => RGBi -> FontAttr -> String -> Point2 u -> Primitive u-textlabel rgb attr txt pt = rtextlabel rgb attr txt 0 pt+textlabel rgb attr txt pt = rtextlabel rgb attr txt pt 0 --- | 'rtextlabel' : @ rgb * font_attr * string * rotation * ---      baseline_left -> Primitive @+-- | 'rtextlabel' : @ rgb * font_attr * string * baseline_left * +--      rotation -> Primitive @ -- -- Create a text label rotated by the supplied angle about the  -- baseline-left. @@ -350,8 +368,8 @@ -- The supplied point is the left baseline. -- rtextlabel :: Num u -           => RGBi -> FontAttr -> String -> Radian -> Point2 u -> Primitive u-rtextlabel rgb attr txt theta pt = PLabel (LabelProps rgb attr) lbl +           => RGBi -> FontAttr -> String -> Point2 u -> Radian -> Primitive u+rtextlabel rgb attr txt pt theta = PLabel (LabelProps rgb attr) lbl    where     lbl = PrimLabel pt (StdLayout $ lexLabel txt) (thetaCTM theta) @@ -394,6 +412,8 @@ -- renderers. Chrome support is fine, but Firefox and Safari  -- currently seem lacking.  --+-- Also, currently the generated PostScript is inefficient.+-- hkernlabel :: Num u              => RGBi -> FontAttr -> [KerningChar u] -> Point2 u              -> Primitive u@@ -432,6 +452,8 @@ -- renderers. Chrome support is fine, but Firefox and Safari  -- currently seem lacking.  --+-- Also, currently the generated PostScript is inefficient.+-- vkernlabel :: Num u              => RGBi -> FontAttr -> [KerningChar u] -> Point2 u              -> Primitive u@@ -595,11 +617,11 @@ -- neither picture will be moved. -- picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u-a `picOver` b = Picture (bb,[]) (cons b $ one a) +a `picOver` b = Picture (bb,[]) (join (one b) (one a))      where     bb = boundary a `boundaryUnion` boundary b --- picOver note - draw b, put b first in the list, so it draws +-- NOTE - picOver - draw b, put b first in the list, so it draws  -- first in the output (this is also @behind@ in the Z-Order).  

@@ -66,7 +66,7 @@ import Wumpus.Core.TrafoInternal import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators-import Wumpus.Core.Utils.OneList+import Wumpus.Core.Utils.JoinList   import Data.AffineSpace                         -- package: vector-space@@ -110,25 +110,15 @@ -- updates for the SVG renderer - in some instances this can  -- improve the code size of the generated SVG. ---data Picture u = Leaf     (Locale u)              (OneList (Primitive u))-               | Picture  (Locale u)              (OneList (Picture u))+data Picture u = Leaf     (Locale u)              (JoinList (Primitive u))+               | Picture  (Locale u)              (JoinList (Picture u))                | Clip     (Locale u) (PrimPath u) (Picture u)-               | Group    (Locale u) FontCtx      (Picture u)   deriving (Show)  type DPicture = Picture Double  --- | Set the font /delta/ for SVG rendering. --- --- 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 FontCtx = FontCtx { getFontCtx :: FontAttr }-  deriving (Eq,Show) - -- | Locale = (bounding box * current translation matrix) --  -- Pictures (and sub-pictures) are located frame consisting of a @@ -173,18 +163,36 @@ -- Though typically for affine transformations a Fractional  -- constraint is also obliged. ----- To represent XLink hyperlinks, Primitives can be grouped --- together at the same type (so Primitives aren\'t strictly)--- /primitive/ as the actual implementation is a tree.+-- To represent XLink hyperlinks, Primitives can be annotated +-- with some a hyperlink (similarly a a font change for better+-- SVG code generation) and grouped - a hyperlinked arrow would+-- want the tip and the arrow body both to be incorporated in the+-- link even though they are two drawings. +--+-- This means that Primitives aren\'t strictly /primitive/ as +-- the actual implementation is a tree. --  data Primitive u = PPath    PathProps     (PrimPath u)                  | PLabel   LabelProps    (PrimLabel u)                  | PEllipse EllipseProps  (PrimEllipse u)-                 | PGroup   (Maybe XLink) (OneList (Primitive u))+                 | PContext FontCtx       (Primitive u)+                 | PLink    XLink         (Primitive u)+                 | PGroup   (JoinList (Primitive u))   deriving (Eq,Show) + type DPrimitive = Primitive Double ++-- | Set the font /delta/ for SVG rendering. +-- +-- 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 FontCtx = FontCtx { getFontCtx :: FontAttr }+  deriving (Eq,Show)+ -- | Primitives can be grouped with hyperlinks in SVG output. -- newtype XLink = XLink { getXLink :: String }@@ -305,12 +313,8 @@                                               , format path                                               , format pic  ] -  format (Group m _ pic)    = indent 2 $ vcat [ text "** Group **"-                                              , fmtLocale m-                                              , format pic  ] --fmtPics :: PSUnit u => OneList (Picture u) -> Doc+fmtPics :: PSUnit u => JoinList (Picture u) -> Doc fmtPics ones = snd $ F.foldl' fn (0,empty) ones   where     fn (n,acc) e = (n+1, vcat [ acc, text "-- " <+> int n, format e, line])@@ -330,11 +334,17 @@   format (PEllipse props e) =        indent 2 $ vcat [ text "ellipse:" <+> format props, format e ] -  format (PGroup xl ones)   = -      vcat [ text "-- group " <+> (maybe empty format xl), fmtPrimlist ones  ]+  format (PContext _ a)     = +      vcat [ text "-- svg ctx change " , format a ] +  format (PLink _ a)     = +      vcat [ text "-- svg link " , format a ] -fmtPrimlist :: PSUnit u => OneList (Primitive u) -> Doc+  format (PGroup ones)      = +      vcat [ text "-- group ", fmtPrimlist ones  ]+++fmtPrimlist :: PSUnit u => JoinList (Primitive u) -> Doc fmtPrimlist ones = snd $ F.foldl' fn (0,empty) ones   where     fn (n,acc) e = (n+1, vcat [ acc, text "-- leaf" <+> int n, format e, line])@@ -381,14 +391,15 @@   boundary (Leaf    (bb,_) _)   = bb   boundary (Picture (bb,_) _)   = bb   boundary (Clip    (bb,_) _ _) = bb-  boundary (Group   (bb,_) _ _) = bb   instance (Real u, Floating u, FromPtSize u) => Boundary (Primitive u) where   boundary (PPath _ p)      = pathBoundary p   boundary (PLabel a l)     = labelBoundary (label_font a) l   boundary (PEllipse _ e)   = ellipseBoundary e-  boundary (PGroup _ ones)  = outer $ viewl ones +  boundary (PContext _ a)   = boundary a+  boundary (PLink _ a)      = boundary a+  boundary (PGroup ones)    = outer $ viewl ones      where       outer (OneL a)     = boundary a       outer (a :< as)    = inner (boundary a) (viewl as)@@ -526,7 +537,6 @@ mapLocale f (Leaf lc ones)     = Leaf (f lc) ones mapLocale f (Picture lc ones)  = Picture (f lc) ones mapLocale f (Clip lc pp pic)   = Clip (f lc) pp pic-mapLocale f (Group lc upd pic) = Group (f lc) upd pic   --------------------------------------------------------------------------------@@ -542,28 +552,36 @@   rotate r (PPath a path)   = PPath a    $ rotatePath r path   rotate r (PLabel a lbl)   = PLabel a   $ rotateLabel r lbl   rotate r (PEllipse a ell) = PEllipse a $ rotateEllipse r ell-  rotate r (PGroup xln xs)  = PGroup xln $ fmap (rotate r) xs+  rotate r (PContext a chi) = PContext a $ rotate r chi +  rotate r (PLink a chi)    = PLink a    $ rotate r chi +  rotate r (PGroup xs)      = PGroup     $ fmap (rotate r) xs    instance (Real u, Floating u) => RotateAbout (Primitive u) where   rotateAbout r pt (PPath a path)   = PPath a    $ rotateAboutPath r pt path   rotateAbout r pt (PLabel a lbl)   = PLabel a   $ rotateAboutLabel r pt lbl   rotateAbout r pt (PEllipse a ell) = PEllipse a $ rotateAboutEllipse r pt ell-  rotateAbout r pt (PGroup xln xs)  = PGroup xln $ fmap (rotateAbout r pt) xs+  rotateAbout r pt (PContext a chi) = PContext a $ rotateAbout r pt chi+  rotateAbout r pt (PLink a chi)    = PLink a    $ rotateAbout r pt chi+  rotateAbout r pt (PGroup xs)      = PGroup     $ fmap (rotateAbout r pt) xs   instance Num u => Scale (Primitive u) where   scale sx sy (PPath a path)    = PPath a    $ scalePath sx sy path   scale sx sy (PLabel a lbl)    = PLabel a   $ scaleLabel sx sy lbl   scale sx sy (PEllipse a ell)  = PEllipse a $ scaleEllipse sx sy ell-  scale sx sy (PGroup xln xs)   = PGroup xln $ fmap (scale sx sy) xs+  scale sx sy (PContext a chi)  = PContext a $ scale sx sy chi+  scale sx sy (PLink a chi)     = PLink a    $ scale sx sy chi+  scale sx sy (PGroup xs)       = PGroup     $ fmap (scale sx sy) xs   instance Num u => Translate (Primitive u) where   translate dx dy (PPath a path)   = PPath a    $ translatePath dx dy path   translate dx dy (PLabel a lbl)   = PLabel a   $ translateLabel dx dy lbl   translate dx dy (PEllipse a ell) = PEllipse a $ translateEllipse dx dy ell-  translate dx dy (PGroup xln xs)  = PGroup xln $ fmap (translate dx dy) xs+  translate dx dy (PContext a chi) = PContext a $ translate dx dy chi+  translate dx dy (PLink a chi)    = PLink a    $ translate dx dy chi+  translate dx dy (PGroup xs)      = PGroup     $ fmap (translate dx dy) xs   --------------------------------------------------------------------------------

@@ -38,7 +38,7 @@ -- etc. --  newtype PtSize = PtSize { ptSize :: Double } -  deriving (Eq,Ord,Num,Floating,Fractional)+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)  instance Show PtSize where   showsPrec p d = showsPrec p (ptSize d)

@@ -0,0 +1,240 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Utils.JoinList+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- A \"join list\" datatype and operations. +--+-- A join list is implemented a binary tree, so joining two +-- lists (catenation, aka (++)) is a cheap operation. +--+-- This constrasts with the regular list datatype which is a +-- cons list: while consing on a regular list is by nature cheap, +-- joining (++) is expensive. +--+-- This version has no Empty constructor, so empty join lists +-- cannot be built.+--+--------------------------------------------------------------------------------+++module Wumpus.Core.Utils.JoinList +  ( +  -- * Join list datatype, opaque.+    JoinList++  -- * Left view as per Data.Sequence  +  , ViewL(..)++  -- * Conversion between join lists and regular lists+  , fromList+  , toList+  , toListF++  -- * Construction+  , one+  , cons+  , snoc+  , join++  -- * Basic functions  +  , head++  , accumMapL+  , isOne+  , isMany++  -- * Left view+  , viewl+++  +  ) where+++import Control.Applicative hiding ( empty )++import Data.Foldable ( Foldable )+import qualified Data.Foldable as F+import Data.Monoid ( mappend )+import Data.Traversable ( Traversable(..) )++import Prelude hiding ( head )++data JoinList a = One a +                | Join (JoinList a) (JoinList a)+  deriving (Eq)++data ViewL a = OneL a | a :< (JoinList a)+  deriving (Eq,Show)+++--------------------------------------------------------------------------------++instance Show a => Show (JoinList a) where+  showsPrec _ xs = showString "fromList " . shows (toList xs) +++instance Functor JoinList where+  fmap f (One a)    = One (f a)+  fmap f (Join t u) = Join (fmap f t) (fmap f u)++++instance Foldable JoinList where+  foldMap f (One a)    = f a+  foldMap f (Join t u) = F.foldMap f t `mappend` F.foldMap f u++  foldr                = joinfoldr+  foldl                = joinfoldl++instance Traversable JoinList where+  traverse f (One a)    = One <$> f a+  traverse f (Join t u) = Join <$> traverse f t <*> traverse f u++-- Views++instance Functor ViewL where+  fmap f (OneL a)       = OneL $ f a+  fmap f (a :< as)      = f a :< fmap f as+++--------------------------------------------------------------------------------+-- Conversion++-- | Convert a join list to a regular list.+--+toList :: JoinList a -> [a]+toList = joinfoldl (flip (:)) []++-- | Build a join list from a regular list.+--+-- This builds a tall skinny list.+--+-- WARNING - throws an error on empty list.+--++fromList :: [a] -> JoinList a+fromList []     = error "Wumpus.Core - internal error empty JoinList"+fromList [x]    = One x+fromList (x:xs) = Join (One x) (fromList xs)+++-- Note -- this works from Right to left...+--+toListF :: (a -> b) -> JoinList a -> [b]+toListF f = step []+  where+    step acc (One x)     = f x : acc+    step acc (Join t u)  = let acc' = step acc u in step acc' t++++--------------------------------------------------------------------------------++isOne :: JoinList a -> Bool+isOne (One _)       = True+isOne _             = False++isMany :: JoinList a -> Bool+isMany (Join _ _)   = True+isMany _            = False+++++-- | Create a singleton join list.+--+one :: a -> JoinList a+one = One+++-- | Cons an element to the front of the join list.+--+cons :: a -> JoinList a -> JoinList a+cons a xs = Join (One a) xs  ++-- | Snoc an element to the tail of the join list.+--+snoc :: JoinList a -> a -> JoinList a+snoc xs a = Join xs (One a)+++++infixr 5 `join`++-- | Because there is no empty join list, join is Join.+--+join :: JoinList a -> JoinList a -> JoinList a+join = Join++--------------------------------------------------------------------------------+-- Basic functions++-- | Extract the first element of a join list - i.e. the leftmost+-- element of the left spine. An error is thrown if the list is +-- empty. +-- +-- This function performs a traversal down the left spine, so +-- unlike @head@ on regular lists this function is not performed +-- in constant time.+--+head :: JoinList a -> a+head (One a)    = a+head (Join t _) = head t+++++accumMapL :: (x -> st -> (y,st)) -> JoinList x -> st -> (JoinList y,st)+accumMapL f xs st0 = go xs st0 +  where+    go (One x)     st = let (y,st') = f x st in (One y,st')+    go (Join t u)  st = (Join v w, st'')+                             where (v,st')  = go t st+                                   (w,st'') = go u st'+++++-- | Right-associative fold of a JoinList.+--+joinfoldr :: (a -> b -> b) -> b -> JoinList a -> b+joinfoldr f = go+  where+    go e (One a)    = f a e+    go e (Join t u) = go (go e t) u+++-- | Left-associative fold of a JoinList.+--+joinfoldl :: (b -> a -> b) -> b -> JoinList a -> b+joinfoldl f = go +  where+    go e (One a)    = f e a+    go e (Join t u) = go (go e u) t++--------------------------------------------------------------------------------+-- Views++-- | Access the left end of a sequence.+--+-- Unlike the corresponing operation on Data.Sequence this is +-- not a cheap operation, the joinlist must be traversed down +-- the left spine to find the leftmost node.+--+-- Also the traversal may involve changing the shape of the +-- underlying binary tree.+--+viewl :: JoinList a -> ViewL a+viewl (One a)    = OneL a+viewl (Join t u) = step t u+  where+    step (One a)      r = a :< r+    step (Join t' u') r = step t' (Join u' r)++

@@ -1,133 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.Utils.OneList--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Data type for non-empty lists.--- -----------------------------------------------------------------------------------module Wumpus.Core.Utils.OneList-  (-   -- OneMany-    OneList-  , ViewL(..)--  , one-  , cons-  , head-  , viewl--  , fromList--  , toListF-  , accumMapL-  , isOne-  , isMany-   -  ) where----import Control.Applicative-import Data.Foldable-import Data.Monoid-import Data.Traversable--import Prelude hiding ( head )---data OneList a = One a | Many a (OneList a)-  deriving (Eq)--data ViewL a = OneL a | a :< (OneList a)-  deriving (Eq)--------------------------------------------------------------------------------------- Instances--instance Show a => Show (OneList a) where-  show = ('{':) . ($ []) . step where-     step (One a)     = shows a . showChar '}'-     step (Many a as) = shows a . showChar ',' . step as---instance Functor OneList where-  fmap f (One a)        = One $ f a-  fmap f (Many a as)    = Many (f a) (fmap f as)--instance Foldable OneList where-  foldMap f (One a)     = f a-  foldMap f (Many a as) = f a `mappend` foldMap f as--  foldr f b0 = step b0 where-    step b (One a)      = f a b-    step b (Many a as)  = f a (step b as)--  foldl f b0 = step b0 where-    step b (One a)      = f b a-    step b (Many a as)  = step (f b a) as---instance Traversable OneList where-  traverse f (One a)      = One  <$> f a-  traverse f (Many a as)  = Many <$> f a <*> traverse f as--------------------------------------------------------------------------------------- | Construct One.-one :: a -> OneList a-one = One----- | Prepend an element. Obviously this transforms a One to a Many.-cons :: a -> OneList a -> OneList a-cons a as   = Many a as---- | 'head' is total of course.-head :: OneList a -> a-head (One a)    = a-head (Many a _) = a--viewl :: OneList a -> ViewL a-viewl (One a)     = OneL a-viewl (Many a as) = a :< as---- | Construct Many. Not this function throws a error if the list has--- zero or one elements-fromList :: [a] -> OneList a-fromList []     = error "OneList.fromList: cannot build Many from empty list"-fromList [a]    = One a-fromList (a:as) = Many a (fromList as)---toListF :: (a -> b) -> OneList a -> [b]-toListF f = step where-  step (One x)     = [f x]-  step (Many x xs) = f x : step xs---accumMapL :: (x -> st -> (y,st)) -> OneList x -> st -> (OneList y,st)-accumMapL f (One x)     st = let (y,st') = f x st in (One y,st')-accumMapL f (Many x xs) st = (Many y ys,st'')-                             where (y, st')  = f x st-                                   (ys,st'') = accumMapL f xs st'--isMany :: OneList a -> Bool-isMany (Many _ _) = True-isMany _          = False--isOne :: OneList a -> Bool-isOne (One _)     = True-isOne _           = False-

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

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.36.0+version:          0.37.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -38,82 +38,49 @@   the design permits a fairly simple implementation, which is a    priority.    .  +  NOTE version 0.37.0 - there will be no release of Wumpus-Basic+  to match this release of Wumpus-Core. Wumpus-Basic is +  undergoing substantial change to accommodate glyph metrics and+  thus enable proper text bounding boxes and right and center+  aligned text. The improvements to Wumpus-Core merit a release+  so that there is not a large hiatus between the APIs of the +  Hackage published latest version and the SVN repository.   .+  .   \[1\] Because the output is simple, straight-line PostScript    code, it is possible to use GraphicsMagick or a similar tool    to convert EPS files generated by Wumpus to many other formats    (bitmaps).    .-  VERSION 0.36.0 UPGRADE NOTES   .-  There are two major changes between 0.35.0 and 0.36.0. -  .-  @PrimElement@ has been removed and the grouping constructor it -  provided has been moved into the @Primitive@ type. As both -  types are opaque, definitions in client code will work without -  change, /but all/ type signatures referencing @PrimElement@ will -  need to replace @PrimElement@ with @Primitive@.-  .-  Rotations and scalings on Primitives have changed again.-  Primitives are now instances of the affine classes so support - -  @rotate@, @rotateAbout@, @scale@, @translate@. Primitives are -  now considered to be in the implicit affine frame with origin at -  (0,0). Previously rotatation on Primitives (via the function -  @rotatePrim@) was really a special case to allow slanted text, -  the rotation was about the text\'s baseline origin and not the -  affine frame. As rotation now works differently there is a -  special constructor for slanted text @rtextlabel@.-  .   Changelog:-  .-  0.35.0 to 0.36.0:-  .-  * API / behaviour change - rotation on primitives changed. New -    functions have been added to create rotated text labels and -    ellipses (@rtextlabel@, @rstrokeEllipse@, etc.), and -    Primitives have been made instances of the Affine classes-    except for the general matrix Transform class. The old-    functions for transforming Primitives (@rotatePrim@, -    @scalePrim@, etc.) have been removed. The demos (Rotated.hs,-    Scaled.hs, Translated.hs) have been removed as they pertain -    to the old behaviour, there are new demos highlighting the-    new behaviour (TransformEllipse.hs, etc.).-  .-  * Major change - removed the PrimElement type. The (opaque) -    Primitive type has been changed to incorporate a grouping -    constructor equivalent to PrimElement\'s @XLinkGroup@ -    contructor. The change has made the implementation of SVG -    hyperlinks more efficient, but has forced various type -    signatures to change in @Core.Picture@. Client code will -    also have to change type signatures - @PrimElement@ becomes-    @Primitive@.-  .-  * @Core.PtSize@ - the class @FromPtSize@ has been given a @Num@-    superclass constraint. This can shorten type signatures of -    functions that use @fromPtSize@.-  .-  * Corrected a bug where textlabels would generate an invalid-    bounding box and cause a runtime error when supplied with an-    empty string. Now there is no runtime error - and /no-ops/ -    are generated in the output.+  . +  0.36.0 to 0.37.0:   .-  * Internal changes - moved @PrimCTM@ from @Core.PictureInternal@-    into separate module. Moved /utility/ modules into their own -    directory @Utils@. Move /text/ modules into their own -    directory @Text@. +  * The bounding box constructors have been renamed - @bbox@ is +    now @boundingBox@ and @obbox@ becomes @oboundingBox@. The +    rationale for this change is that the names very cryptic in +    the first place and the constructors are used infrequently +    when @bbox@ in particular makes a descriptive variable name.   .-  * Removed dependency on @algebra@ for @Semigroup@. The -    equivalent @append@ operation on @BoundingBox@ is -    @boundaryUnion@.+  * Changes to the Picture and Primitive types to enable better+    concatenation which is used heavily by Wumpus-Basic. The +    Picture API exposes a new function @primCat@.   .-  * Renamed the @Core.GraphicsState@ to @Core.GraphicProps@. -    Moved the property datatypes from @Core.PictureInternal@ into -    @Core.GraphicProps@ (StrokeProps, LabelProps, etc.).+  * SVG /font delta context/ change - font deltas are now +    annotated on Primitives not Pictures. The type of the +    function @fontDeltaContext@ in @Core.Picture@ has changed +    accordingly.   .-  * Moved @wumpus_default_font@ from @Core.Picture@ into -    @Core.Graphic.Props@.+  * SVG hyperlink change - hyperlinks no longer group primitives+    (although a group of primitives can be hyperlinked). The +    function @xlinkGroup@ has been removed from @Core.Picture@, +    it is replaced by @xlink@. Primitives are now grouped with the+    function @primGroup@.   .-  * Haddock docs improved.+  * @Core.Picture@ - the argument order for the function +    @rtextlabel@ has been changed, the positions of the angle and +    bottom-left corner have been swapped.   .   . build-type:         Simple@@ -178,7 +145,7 @@     Wumpus.Core.Text.TextInternal,     Wumpus.Core.TrafoInternal,     Wumpus.Core.Utils.Common,-    Wumpus.Core.Utils.OneList,+    Wumpus.Core.Utils.JoinList,     Wumpus.Core.Utils.FormatCombinators        extensions: