diff --git a/demo/Latin1Pic.hs b/demo/Latin1Pic.hs --- a/demo/Latin1Pic.hs +++ b/demo/Latin1Pic.hs @@ -20,8 +20,10 @@ -- supports escapes as either numbers or names... -- pic1 :: DPicture -pic1 = frame [ helveticaLabel "mystère" (P2 0 40) - , helveticaLabel "myst&#egrave;re" (P2 0 20) +pic1 = frame [ helveticaLabel "mystère" (P2 0 60) + , helveticaLabel "myst&#egrave;re" (P2 0 40) + , helveticaLabel "myst�o350;re" (P2 0 20) + , helveticaLabel "myst�XE8;re" (P2 0 00) ] diff --git a/src/Wumpus/Core.hs b/src/Wumpus/Core.hs --- a/src/Wumpus/Core.hs +++ b/src/Wumpus/Core.hs @@ -12,46 +12,15 @@ -- -- Common interface to Wumpus.Core. -- --- This module re-exports types and functions from: --- --- * "Wumpus.Core.AffineTrans" --- --- * "Wumpus.Core.BoundingBox" --- --- * "Wumpus.Core.Colour" --- --- * "Wumpus.Core.FontSize" --- --- * "Wumpus.Core.Geometry" --- --- * "Wumpus.Core.GraphicsState" --- --- * "Wumpus.Core.OutputPostScript" --- --- * "Wumpus.Core.OutputSVG" --- --- * "Wumpus.Core.Picture" --- --- * "Wumpus.Core.PictureLanguage" --- --- * "Wumpus.Core.PtSize" --- --- * "Wumpus.Core.TextEncoder" --- --- * "Wumpus.Core.TextLatin1" --- --- * "Wumpus.Core.TextSymbolFont" --- --- * "Wumpus.Core.VersionNumber" --- --- * "Wumpus.Core.WumpusTypes" +-- This is a /shim/ module re-exporting types and functions from +-- the exposed Wumpus-Core modules. In most cases, importing just +-- this module should be sufficient to use Wumpus-Core. -- --- Named colours ( black, white etc.) are hidden from +-- Named colours ( black, white etc.) are hidden from the module -- "Wumpus.Core.Colour" to avoid collisions with modules that --- define colour sets (e.g. all the SVG colours). If needed, --- the module can be imported directly. --- --- +-- define colour sets (e.g. all the SVG colours). If named +-- colours are needed, "Wumpus.Core.Colour" can be imported +-- directly. -- -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Core/AffineTrans.hs b/src/Wumpus/Core/AffineTrans.hs --- a/src/Wumpus/Core/AffineTrans.hs +++ b/src/Wumpus/Core/AffineTrans.hs @@ -18,16 +18,23 @@ -- The common affine transformations represented as type classes - -- scaling, rotation, translation. -- --- Unlike other functional graphics systems (e.g. Clastic), Wumpus --- performs the affine transformations as matrix operations. This --- simplifies the implementation of pictures --- ("Wumpus.Core.PictureInternal"). When a picture is composed and --- transformed, transformations will be performed only on the --- bounding box in Wumpus but the transformation of the --- picture content (paths or text labels) will be communicated to --- PostScript or SVG to render. This is because Wumpus has no --- access to the paths that make fonts so cannot transform them --- directly. +-- Internally, when a picture is composed and transformed, Wumpus +-- only transforms the bounding box - transformations of the +-- picture content (paths or text labels) are communicated to +-- PostScript or SVG for final rendering. This is because Wumpus +-- has no access to the paths that make fonts so cannot transform +-- them directly. +-- +-- As well as Pictures, some elements - e.g. Vectors, Points and +-- BoundingBoxes - are also instances of the affine classes. The +-- implementation of the instances considers that under +-- transformation these objects are implicitly within the standard +-- affine frame (origin at point zero and unit basis vectors for +-- the horizontal and vertical). +-- +-- This assumption cannot hold for primitives because text is +-- special in PostScript and SVG, so there are no instances of +-- the affine classes for Primitive or PrimElement. -- -- To generate efficient PostScript, Wumpus relies on the matrix -- representations of the affine transformations being invertible. diff --git a/src/Wumpus/Core/BoundingBox.hs b/src/Wumpus/Core/BoundingBox.hs --- a/src/Wumpus/Core/BoundingBox.hs +++ b/src/Wumpus/Core/BoundingBox.hs @@ -14,8 +14,7 @@ -- Bounding box with no notion of \'empty\'. -- -- Empty pictures cannot be created with Wumpus. This greatly --- simplifies the implementation of pictures themselves and --- bounding boxes. +-- simplifies the implementation of pictures and bounding boxes. -- -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Core/Colour.hs b/src/Wumpus/Core/Colour.hs --- a/src/Wumpus/Core/Colour.hs +++ b/src/Wumpus/Core/Colour.hs @@ -13,9 +13,12 @@ -- Colour represented as RGB with each component in the range -- [0..255]. -- --- Note - the predifined colours are hidden when importing the --- /top-level/ module @Wumpus.Core@, import this module directly --- to use them. +-- Note - the predefined colours are hidden when importing the +-- /top-level/ shim module @Wumpus.Core@, import +-- @Wumpus.Core.Colour@ directly to use them. +-- +-- PostScript has no support for RGB-alpha and hence does not +-- transparency. Thus Wumpus in turn cannot support transparency. -- -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Core/FontSize.hs b/src/Wumpus/Core/FontSize.hs --- a/src/Wumpus/Core/FontSize.hs +++ b/src/Wumpus/Core/FontSize.hs @@ -13,14 +13,16 @@ -- Font size calculation for Label\'s and their bounding boxes. -- -- Calculations are based on metrics derived from Courier at --- 48pt. As Courier is a monospaced font, bounding boxes --- calculated for other font families will usually have longer --- width than is necessary for the printed text. +-- 48pt. As Courier is a monospaced font, applying these metrics +-- to other font families will usually produce over-estimates +-- (bounding boxes will be longer than the true visual length +-- of the text). -- -- This is a deficiency of Wumpus, and limits its text handling --- capabilities (for example, text cannot be automatically --- centered). However, alternatives would need access to font --- metrics - this would require a font loader and add +-- capabilities - for example, text cannot be reliably centered +-- as its true length is not known. However, more powerful +-- alternatives would need access to the metrics embedded within +-- font files. This would require a font loader and add -- significant implementation complexity. -- -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Core/GraphicsState.hs b/src/Wumpus/Core/GraphicsState.hs --- a/src/Wumpus/Core/GraphicsState.hs +++ b/src/Wumpus/Core/GraphicsState.hs @@ -10,25 +10,17 @@ -- Stability : unstable -- Portability : GHC -- --- Data types for stroke and label attributes and type classes --- for conversion to PostScript\'s colour and matrix --- representations. +-- Data types for stroke and label attributes. -- -- Wumpus represents pictures as trees - a leaf represents a -- path or text label. All attributes of a path or text label -- (colour, stroke width, font, ...) are stored in the leaf. So -- a picture is a leaf labelled tree. -- --- By contrast, PostScript maintains a /graphics state/. A +-- By contrast, PostScript maintains a global /graphics state/. A -- PostScript program is free to modify the graphics state --- anywhere in the program. Stroke width is a general property --- shared by all elements (initially it has the default value 1). --- Only stroked paths actually regard stroke width, fonts and --- filled and clipping paths ignore it. PostScript allows more --- control over the graphics state by allowing the current state --- to be saved and restored with the @gsave@ and @grestore@. --- This is useful for modularity but is a comparatively expensive --- procedure. +-- anywhere in the program and subsequent elements are all drawn +-- according to the modified graphics state. -- -- When Wumpus renders Pictures as PostScript it maintains a -- limited graphics state with just current colour and current diff --git a/src/Wumpus/Core/OutputPostScript.hs b/src/Wumpus/Core/OutputPostScript.hs --- a/src/Wumpus/Core/OutputPostScript.hs +++ b/src/Wumpus/Core/OutputPostScript.hs @@ -98,7 +98,10 @@ setsGS :: (GraphicsState -> GraphicsState) -> PsMonad () setsGS fn = PsMonad $ \_ s -> ((),fn s) +resetGS :: PsMonad () +resetGS = PsMonad $ \ _ _ -> ((),zeroGS) + setsSA :: (StrokeAttr -> StrokeAttr) -> PsMonad () setsSA fn = getsGS gs_stroke_attr >>= \sa -> setsGS (\s -> s { gs_stroke_attr = fn sa }) @@ -251,12 +254,19 @@ -- Note - PostScript ignotes any FontCtx changes via the @Group@ -- constructor. -- +-- Also - because Clip uses gsave grestore it has to resetGS on +-- ending, otherwise the next picture will be diffing against +-- a modified state (in Wumpus land) that contradicts the PostScript +-- state. +-- picture :: (Real u, Floating u, PSUnit u) => Picture u -> PsMonad Doc picture (Leaf (_,xs) ones) = bracketTrafos xs $ oneConcat primElement ones picture (Picture (_,xs) ones) = bracketTrafos xs $ oneConcat picture ones -picture (Clip (_,xs) cp pic) = bracketTrafos xs $ - (vconcat <$> clipPath cp <*> picture pic) 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 diff --git a/src/Wumpus/Core/OutputSVG.hs b/src/Wumpus/Core/OutputSVG.hs --- a/src/Wumpus/Core/OutputSVG.hs +++ b/src/Wumpus/Core/OutputSVG.hs @@ -18,14 +18,10 @@ -- 1. The coordinate space of SVG is /origin top-left/, for -- PostScript it is /origin bottom-left/. -- --- 2. Clipping in PostScript works by changing the graphics state --- Clip a path, then all subsequent drawing be rendered only --- when it is within the clip bounds. Clearly using clipping --- paths within a @gsave ... grestore@ block is a good idea... --- --- SVG uses /tagging/. A clipPath element is declared and named --- then referenced in subsequent elements via the clip-path --- attribute - @clip-path=\"url(#clip_path_tag)\"@. +-- 2. Clipping in SVG uses /tagging/. A clipPath element is +-- declared and named, subsequent elements within the clipping +-- area reference it via the clip-path attribute - +-- @clip-path=\"url(#clip_path_tag)\"@. -- -- -------------------------------------------------------------------------------- @@ -211,7 +207,9 @@ drawXLink (XLink href) doc = elem_a_xlink href doc clipPath :: PSUnit u => String -> PrimPath u -> SvgMonad Doc -clipPath clip_id pp = (\doc -> elem_clipPath (attr_id clip_id) doc) <$> path pp +clipPath clip_id pp = + (\doc -> elem_clipPath (attr_id clip_id) (elem_path_no_attrs doc)) + <$> path pp primPath :: PSUnit u => PathProps -> PrimPath u -> SvgMonad Doc diff --git a/src/Wumpus/Core/Picture.hs b/src/Wumpus/Core/Picture.hs --- a/src/Wumpus/Core/Picture.hs +++ b/src/Wumpus/Core/Picture.hs @@ -476,9 +476,13 @@ -- neither picture will be moved. -- picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u -a `picOver` b = Picture (bb,[]) (cons a $ one b) +a `picOver` b = Picture (bb,[]) (cons b $ one a) where bb = boundary a `append` boundary b + +-- picOver note - draw b, put b first in the list, so it draws +-- first in the output (this is also @behind@ in the Z-Order). + -- | 'picMoveBy' : @ picture -> vector -> picture @ -- diff --git a/src/Wumpus/Core/PictureInternal.hs b/src/Wumpus/Core/PictureInternal.hs --- a/src/Wumpus/Core/PictureInternal.hs +++ b/src/Wumpus/Core/PictureInternal.hs @@ -115,11 +115,8 @@ -- Omitting some details, Picture is a simple non-empty -- leaf-labelled rose tree via: -- --- > Leaf primitives | Picture [tree] +-- > tree = Leaf [primitive] | Picture [tree] -- --- Where OneList is a variant of the standard list type that --- disallows empty lists. --- -- The additional constructors are convenience: -- -- @Clip@ nests a picture (tree) inside a clipping path. @@ -137,10 +134,15 @@ type DPicture = Picture Double -- | To represent XLink hyperlinks, Primitives in a Leaf are --- encoded in a tree rather a list. +-- actualy encoded in a tree rather a list. -- --- (This is rather unfortunate as it expends an extra wrapper --- for ever element regardless of whether hyerlinks are needed). +-- As a design, this is rather unfortunate as it demands an extra +-- wrapper for ever element regardless of whether hyperlinks are +-- actually used. But it does mean that one hyperlink can cover a +-- complex graphic element - for example an arrow might be drawn +-- with one or more paths, plus extra (filled or stroked) paths +-- for the tip and tail, but each element should be within the +-- link. -- data PrimElement u = Atom (Primitive u) | XLinkGroup XLink (OneList (PrimElement u)) @@ -190,8 +192,8 @@ deriving (Eq,Show) -- | Wumpus\'s drawings are built from two fundamental --- primitives: paths (line segments and Bezier curves) and --- labels (single lines of text). +-- primitives: paths (straight line segments and Bezier curves) +-- and labels (single lines of text). -- -- Ellipses are a included as a primitive only for optimization -- - drawing a reasonable circle with Bezier curves needs at @@ -649,7 +651,7 @@ -- | Rotate a Primitive. -- -- Note - this is not an affine transformation as Primitives are --- not regarded as being in an affine frame. +-- not regarded as being within an affine frame. -- -- * Paths are rotated about their start point. -- @@ -679,7 +681,7 @@ -- | Scale a Primitive. -- -- Note - this is not an affine transformation as Primitives are --- not regarded as being in an affine frame. +-- not regarded as being within an affine frame. -- -- An affine scaling uniformly scales all the elements in a -- Picture. It is just a change of the Picture\'s basis vectors. @@ -749,8 +751,8 @@ -- -- This is a visually intuitive interpretation - Primitives are -- not in an affine space (they have an origin, i.e. the location --- (0,0), but don\'t not basis vectors) so manipulating them --- cannot follow the standard affine interpretation. +-- (0,0), but do not have tangible basis vectors) so manipulating +-- them cannot follow the standard affine interpretation. -- rotatePath :: (Real u, Floating u) => Radian -> PrimPath u -> PrimPath u rotatePath ang (PrimPath start xs) = PrimPath start $ map (mapSeg fn) xs diff --git a/src/Wumpus/Core/SVGDoc.hs b/src/Wumpus/Core/SVGDoc.hs --- a/src/Wumpus/Core/SVGDoc.hs +++ b/src/Wumpus/Core/SVGDoc.hs @@ -27,6 +27,7 @@ , elem_a_xlink , elem_clipPath , elem_path + , elem_path_no_attrs , elem_text , elem_tspan , elem_ellipse @@ -169,6 +170,12 @@ elem_path attrs path = svgElem "path" (attrs <+> svgAttr "d" path) +-- | @ \ @ +-- +elem_path_no_attrs :: Doc -> Doc +elem_path_no_attrs path = svgElem "path" (svgAttr "d" path) + + -- | @ \...\ @ -- elem_text :: Doc -> Doc -> Doc @@ -381,7 +388,7 @@ -- | @ clip_path="url(#...)" @ -- attr_clip_path :: String -> Doc -attr_clip_path ss = svgAttr "transform" (text "url" <> parens (text $ '#':ss)) +attr_clip_path ss = svgAttr "clip-path" (text "url" <> parens (text $ '#':ss)) -- | @ transform="..." @ diff --git a/src/Wumpus/Core/TextInternal.hs b/src/Wumpus/Core/TextInternal.hs --- a/src/Wumpus/Core/TextInternal.hs +++ b/src/Wumpus/Core/TextInternal.hs @@ -125,20 +125,49 @@ -- lexer :: String -> [TextChunk] lexer [] = [] +lexer ('&':'#':cs) = escStart cs +lexer (c:cs) = let (ss,rest) = span (/= '&') cs + in TextSpan (c:ss) : lexer rest -lexer ('&':'#':xs) = esc xs +escStart :: String -> [TextChunk] +escStart ('0':'o':cs) = escOct cs +escStart ('0':'O':cs) = escOct cs +escStart ('0':'x':cs) = escHex cs +escStart ('0':'X':cs) = escHex cs +escStart (c:cs) | isDigit c = escDec (digitToInt c) cs +escStart (c:cs) = let (ss,rest) = span isAlphaNum cs + in TextEscName (c:ss) : chompToSemi rest +escStart [] = [] + +-- | One digit consumed already... +-- +escDec :: Int -> String -> [TextChunk] +escDec n (c:cs) | isDigit c = escDec (n*10 + digitToInt c) cs +escDec n cs | n > 0 = TextEscInt n : chompToSemi cs + | otherwise = chompToSemi cs + +escHex :: String -> [TextChunk] +escHex = step 0 where - esc (c:cs) | isDigit c = let (s,cs') = span isDigit cs - in intval (c:s) cs' - | otherwise = let (s,cs') = span isAlpha cs - in TextEscName (c:s) : optsemi cs' - esc [] = [] + step n (c:cs) | isHexDigit c = step (n*16 + digitToInt c) cs + step n cs | n > 0 = TextEscInt n : chompToSemi cs + | otherwise = chompToSemi cs - optsemi (';':cs) = lexer cs -- let ill-formed go through - optsemi cs = lexer cs - intval [] rest = optsemi rest - intval cs rest = TextEscInt (read cs) : optsemi rest +escOct :: String -> [TextChunk] +escOct = step 0 + where + step n (c:cs) | isHexDigit c = step (n*8 + digitToInt c) cs + step n cs | n > 0 = TextEscInt n : chompToSemi cs + | otherwise = chompToSemi cs -lexer (x:xs) = let (s,xs') = span (/= '&') xs - in TextSpan (x:s) : lexer xs' + + +-- The last two conditions both indicate ill-formed input, but it +-- is /best/ if the lexer does not throw errors. +-- +chompToSemi :: String -> [TextChunk] +chompToSemi (';':cs) = lexer cs +chompToSemi (_:cs) = chompToSemi cs +chompToSemi [] = [] + diff --git a/src/Wumpus/Core/VersionNumber.hs b/src/Wumpus/Core/VersionNumber.hs --- a/src/Wumpus/Core/VersionNumber.hs +++ b/src/Wumpus/Core/VersionNumber.hs @@ -22,7 +22,7 @@ -- | Version number. -- --- > (0,33,0) +-- > (0,34,0) -- wumpus_core_version :: (Int,Int,Int) -wumpus_core_version = (0,33,0) +wumpus_core_version = (0,34,0) diff --git a/src/Wumpus/Core/WumpusTypes.hs b/src/Wumpus/Core/WumpusTypes.hs --- a/src/Wumpus/Core/WumpusTypes.hs +++ b/src/Wumpus/Core/WumpusTypes.hs @@ -12,7 +12,7 @@ -- -- This module re-exports types and functions from -- "Wumpus.Core.PictureInternal" but makes them opaque. - +-- Contructors are provided by "Wumpus.Core.Picture". -- -------------------------------------------------------------------------------- diff --git a/wumpus-core.cabal b/wumpus-core.cabal --- a/wumpus-core.cabal +++ b/wumpus-core.cabal @@ -1,5 +1,5 @@ name: wumpus-core -version: 0.33.0 +version: 0.34.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -37,7 +37,7 @@ Wumpus might be limited compared to other systems. However, the design permits a fairly simple implementation, which is a priority. - . + . . \[1\] Because the output is simple, straight-line PostScript code, it is possible to use GraphicsMagick or a similar tool @@ -46,6 +46,18 @@ . Changelog: . + 0.33.0 to 0.34.0: + . + * Clipping paths fixed. Previously they did not work for SVG or + PostScript. + . + * @picOver@ fixed. Drawing order was changed in version 0.33.0, + but @picOver@ was not updated accordingly (so it actually + started drawing pictures /under/). It now works correctly. + . + * The lexer for escape characters embedded in label strings has + been rewritten. It now supports octal and hexadecimal codes. + . 0.32.0 to 0.33.0: . * Major change - reworked support for text encoding. Encoding