diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,78 @@ +0.30.0 to 0.31.0: + + * Extended the label type to optionally handle horizontal + or vertical \"kerning\". This can be efficiently implemented + in SVG. + + * Major API change - the Primitive constructors defined in + @Core.PictureLanguage@ are no longer overloaded (@cstroke@, + @ostroke@, @fill@, @textlabel@, @ellipse@). The respective + classes (@Stroke@, @TextLabel@, @Ellipse@) have been removed + and the constructors now have monomorphic types. This is + because Wumpus-Core now only has one colour type and stroke + attributes are now a single type, so polymorphism became + less useful (and the simplicity of monomorphic types became + more favourable). @ellipse@ is no longer a constructor + instead there variants @fillEllipse@ and @strokeEllipse@. + + * Added support for /bordered/ closed paths - i.e. paths that + are both stroked and filled. These can be efficiently drawn + in SVG with a single @path@ element. + + * Changed StrokeAttr representation to be a regular data type + rather than a list of /deltas/ - i.e. differences to the + graphics state. + + * Added SVG font attribute /delta optimizations/ to help reduce + SVG code size - via the @fontDeltaContext@ function in + @Core.Picture@. This functionality was partially inplemented + in the last release using the @GSUpdate@ datatype - this + datatype it is now called @FontCtx@. + + * Some internal work documenting text encoding. + +0.23.0 to 0.30.0: + + * Substantial changes - the output machinery has been heavily + modified, the intention was to reduce the use of matrix + transformations in SVG output. Though this goal has not been + achieved, some code-size improvements in the SVG output have + been made. + + * The code generation monads have been changed - Wumpus no + longer uses a writer monad for code generation, but it will + keep the Wumpus name. + + * Added support for hyperlinks in the SVG output. + + * Improved internal pretty printing and added the function + @printPicture@ for debugging. + + * The @Core.Colour@ module has been simplified to support just + one (new) type - RGBi, and the conversion type class + @PSColour@ has been eliminated. + + * @Core.Picture@ - the type of the @frame@ function has been + changed to take a list of Primitives rather than a single + Primitive. The function @frameMulti@ which previously + provided this functionality has been removed. SVG hyperlinks + are now supported for Primitives. + + * The default font size has been changed to 14 pt. + + * The Path datatype has been renamed PrimPath, likewise Ellipse + is now PrimEllispe and Label becomes PrimLabel. + + * @Core.Geometry@ now longer defines an affine frame datatype. + + * @Core.BoundingBox@ module changed significantly. The corner + functions (@boundaryBottomLeft@, etc.) have been removed, + along with the plane functions (@leftPlane@, etc.). Some + functions have been given more verbose names - @corners@ is + now @boundaryCorners@, @within@ is now @withinBoundary@ and + @union@ is now @boundaryUnion@. + 0.22.0 TO 0.23.0: * @Basic.GraphicsState@ - extracted the font face fields from @@ -41,7 +115,6 @@ * Exposed the PSUnit type class. - 0.20.0 to 0.21.0: * Removed the Primitive instances of the Affine transformation @@ -70,7 +143,6 @@ * Removed the Ord superclass constriant from the @Stroke@ and @Fill@ classes and derived operations (e.g. @zostroke@). - 0.19.0 to 0.20.0: * Removed the modules: @@ -93,7 +165,6 @@ * Guide updated regarding the new package @wumpus-basic@. - 0.18.0 to 0.19.0: * Added @Transform@ type class to apply a matrix transformation @@ -149,7 +220,6 @@ missing with the generated file @WorldFrame.eps@ incorrectly included instead. - 0.16.0 to 0.17.0: * Added Core.WumpusTypes to export opaque versions of @@ -176,7 +246,6 @@ * Removed dependency on \'old-time\'. - 0.15.0 to 0.16.0: * Additions to Core.Geometry (direction, pvec, vangle, @@ -216,12 +285,10 @@ * Removed DList dependency. - 0.13.0 to 0.13.1: * Wumpus.Core.SVG changed path_s to path_c - \'S\' was the wrongSVG command to match PostScript\'s @curveto@. - 0.12.0 to 0.13.0: diff --git a/demo/AffineTestBase.hs b/demo/AffineTestBase.hs --- a/demo/AffineTestBase.hs +++ b/demo/AffineTestBase.hs @@ -110,16 +110,16 @@ -------------------------------------------------------------------------------- rgbLabel :: RGBi -> DPrimitive -rgbLabel rgb = textlabel rgb "Wumpus!" zeroPt +rgbLabel rgb = textlabel rgb wumpus_default_font "Wumpus!" zeroPt rgbCircle :: RGBi -> DPrimitive -rgbCircle rgb = ellipse rgb 60 60 zeroPt +rgbCircle rgb = fillEllipse rgb 60 60 zeroPt rgbEllipse :: RGBi -> DPrimitive -rgbEllipse rgb = ellipse rgb 60 30 zeroPt +rgbEllipse rgb = fillEllipse rgb 60 30 zeroPt rgbPath :: RGBi -> DPrimitive -rgbPath rgb = ostroke rgb $ dog_kennel +rgbPath rgb = ostroke rgb default_stroke_attr $ dog_kennel -------------------------------------------------------------------------------- -- Demo - draw a dog kennel... diff --git a/demo/DeltaPic.hs b/demo/DeltaPic.hs new file mode 100644 --- /dev/null +++ b/demo/DeltaPic.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +module DeltaPic where + +import Wumpus.Core + +import System.Directory + + +peru :: RGBi +peru = RGBi 205 133 63 + +black :: RGBi +black = RGBi 0 0 0 + + + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + writeEPS_latin1 "./out/delta_pic01.eps" pic1 + writeSVG_latin1 "./out/delta_pic01.svg" pic1 + + +pic1 :: DPicture +pic1 = fontDeltaContext delta_ctx $ frame + [ helveticaLabel 18 "Optimized - size and face" (P2 0 60) + , helveticaLabel 14 "Optimized - face only" (P2 0 40) + , courierLabel "No optimization" (P2 0 20) + ] + where + delta_ctx = FontAttr 18 common_ff + + +common_ff :: FontFace +common_ff = FontFace "Helvetica" "Helvetica" SVG_REGULAR + + +-- Note - each label is fully attributed with the font style. +-- There really is not attribute inheritance. +-- +helveticaLabel :: Int -> String -> DPoint2 -> DPrimitive +helveticaLabel sz ss pt = textlabel peru attrs ss pt + where + attrs = FontAttr sz common_ff + +courierLabel :: String -> DPoint2 -> DPrimitive +courierLabel ss pt = textlabel black wumpus_default_font ss pt diff --git a/demo/FontMetrics.hs b/demo/FontMetrics.hs --- a/demo/FontMetrics.hs +++ b/demo/FontMetrics.hs @@ -57,18 +57,19 @@ bodyHeight = vertLine peru $ fromPtSize courier48_numeral_height agraveU :: PrimF -agraveU = textlabel (black, courier_attr) "&#Agrave" +agraveU = textlabel black courier_attr "&#Agrave" letter :: Char -> DPoint2 -> DPrimitive -letter ch pt = textlabel (black, courier_attr) [ch] pt +letter ch pt = textlabel black courier_attr [ch] pt vertLine :: RGBi -> Double -> DPoint2 -> DPrimitive -vertLine rgb height pt = ostroke rgb $ vertexPath [pt, pt .+^ vvec height] +vertLine rgb height pt = + ostroke rgb default_stroke_attr $ vertexPath [pt, pt .+^ vvec height] haxis :: RGBi -> PtSize -> DPrimitive haxis rgb ypos = - ostroke (rgb, dash_attr) $ vertexPath [ pt, pt .+^ hvec 440 ] + ostroke rgb dash_attr $ vertexPath [ pt, pt .+^ hvec 440 ] where - dash_attr = DashPattern (Dash 0 [(2,2)]) + dash_attr = default_stroke_attr { dash_pattern = Dash 0 [(2,2)] } pt = P2 0 (fromPtSize ypos) diff --git a/demo/KernPic.hs b/demo/KernPic.hs new file mode 100644 --- /dev/null +++ b/demo/KernPic.hs @@ -0,0 +1,53 @@ +{-# OPTIONS -Wall #-} + +module KernPic where + +import Wumpus.Core +import Wumpus.Core.Colour + +import System.Directory + + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + writeEPS_latin1 "./out/kern_pic01.eps" kern_pic + writeSVG_latin1 "./out/kern_pic01.svg" kern_pic + + +kern_pic :: DPicture +kern_pic = pic1 `picOver` pic2 + +pic1 :: DPicture +pic1 = frame [ helveticaLabelH mystere (P2 0 40) + , helveticaLabelH mystere (P2 0 20) + ] + +pic2 :: DPicture +pic2 = illustrateBoundsPrim blue_violet $ + helveticaLabelV mystere (P2 100 140) + + +mystere ::[DKerningChar] +mystere = [ kernchar 0 'm' + , kernchar 15 'y' + , kernchar 10 's' + , kernchar 10 't' + , kernEscInt 6 232 + , kernchar 10 'r' + , kernchar 6 'e' + ] + +helveticaLabelH :: [KerningChar Double] -> DPoint2 -> DPrimitive +helveticaLabelH xs pt = hkernlabel black helvetica18 xs pt + +helveticaLabelV :: [KerningChar Double] -> DPoint2 -> DPrimitive +helveticaLabelV xs pt = vkernlabel black helvetica18 xs pt + + +helvetica18 :: FontAttr +helvetica18 = FontAttr 18 (FontFace "Helvetica" "Helvetica" SVG_REGULAR) + +blue_violet :: RGBi +blue_violet = RGBi 0x8a 0x2b 0xe2 diff --git a/demo/LabelPic.hs b/demo/LabelPic.hs --- a/demo/LabelPic.hs +++ b/demo/LabelPic.hs @@ -12,7 +12,7 @@ drawBounds :: (Floating u, Real u, FromPtSize u) => Picture u -> Picture u -drawBounds p = p `picOver` (frame [cstroke () ph]) +drawBounds p = p `picOver` (frame [zcstroke ph]) where ph = vertexPath $ [bl,br,tr,tl] (bl,br,tr,tl) = boundaryCorners $ boundary p @@ -41,9 +41,9 @@ lbl1 :: Picture Double lbl1 = line1 `picBeside` line2 where - line1 = frame [textlabel attrs "Hello" zeroPt] - line2 = frame [textlabel attrs "World" zeroPt] - attrs = (peru, FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)) + line1 = frame [textlabel peru attrs "Hello" zeroPt] + line2 = frame [textlabel peru attrs "World" zeroPt] + attrs = FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR) demo01 :: IO () @@ -90,9 +90,9 @@ bigT = bigLetter plum 'T' bigLetter :: RGBi -> Char -> Picture Double -bigLetter col ch = uniformScale 5 $ frame [textlabel attrs [ch] zeroPt] +bigLetter rgb ch = uniformScale 5 $ frame [textlabel rgb attrs [ch] zeroPt] where - attrs = (col, FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)) + attrs = FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR) -- | A should be above B, above T diff --git a/demo/Latin1Pic.hs b/demo/Latin1Pic.hs new file mode 100644 --- /dev/null +++ b/demo/Latin1Pic.hs @@ -0,0 +1,34 @@ +{-# OPTIONS -Wall #-} + +module Latin1Pic where + +import Wumpus.Core +import Wumpus.Core.Colour + +import System.Directory + + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + writeEPS_latin1 "./out/latin1_pic01.eps" pic1 + writeSVG_latin1 "./out/latin1_pic01.svg" pic1 + + +-- | Provided the respective lookups can be found, Wumpus +-- supports escapes as either numbers or names... +-- +pic1 :: DPicture +pic1 = frame [ helveticaLabel "mystère" (P2 0 40) + , helveticaLabel "myst&#egrave;re" (P2 0 20) + ] + + + + +helveticaLabel :: String -> DPoint2 -> DPrimitive +helveticaLabel ss pt = textlabel black helvetica18 ss pt + +helvetica18 :: FontAttr +helvetica18 = FontAttr 18 (FontFace "Helvetica" "Helvetica" SVG_REGULAR) diff --git a/demo/MultiPic.hs b/demo/MultiPic.hs --- a/demo/MultiPic.hs +++ b/demo/MultiPic.hs @@ -19,8 +19,8 @@ pic1 :: DPicture pic1 = uniformScale 2 $ frame $ - [ ellipse blue 10 10 zeroPt - , ellipse red 10 10 (P2 40 40) + [ fillEllipse blue 10 10 zeroPt + , fillEllipse red 10 10 (P2 40 40) , ztextlabel "Wumpus!" (P2 40 20) , square red 5 (P2 50 10) ] diff --git a/demo/Rotated.hs b/demo/Rotated.hs --- a/demo/Rotated.hs +++ b/demo/Rotated.hs @@ -58,10 +58,10 @@ ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u -ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr +ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr label :: Num u => RGBi -> Point2 u -> Primitive u -label rgb bl = textlabel rgb "Wumpus" bl +label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl grey :: RGBi diff --git a/demo/Scaled.hs b/demo/Scaled.hs --- a/demo/Scaled.hs +++ b/demo/Scaled.hs @@ -51,10 +51,10 @@ [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen] ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u -ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr +ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr label :: Num u => RGBi -> Point2 u -> Primitive u -label rgb bl = textlabel rgb "Wumpus" bl +label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl grey :: RGBi diff --git a/demo/Translated.hs b/demo/Translated.hs --- a/demo/Translated.hs +++ b/demo/Translated.hs @@ -46,10 +46,10 @@ [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen] ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u -ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr +ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr label :: Num u => RGBi -> Point2 u -> Primitive u -label rgb bl = textlabel rgb "Wumpus" bl +label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl grey :: RGBi diff --git a/demo/ZOrderPic.hs b/demo/ZOrderPic.hs --- a/demo/ZOrderPic.hs +++ b/demo/ZOrderPic.hs @@ -28,8 +28,8 @@ prim_list :: DPoint2 -> [DPrimitive] -prim_list = sequence [ ellipse red 20 20 - , \p -> ellipse green 20 20 (p .+^ hvec 20) - , \p -> ellipse blue 20 20 (p .+^ hvec 40) +prim_list = sequence [ fillEllipse red 20 20 + , \p -> fillEllipse green 20 20 (p .+^ hvec 20) + , \p -> fillEllipse blue 20 20 (p .+^ hvec 40) ] diff --git a/doc-src/Guide.lhs b/doc-src/Guide.lhs --- a/doc-src/Guide.lhs +++ b/doc-src/Guide.lhs @@ -95,11 +95,11 @@ \item[\texttt{Wumpus.Core.Picture.}] Operations to build \emph{pictures} - paths and labels within -an affine frame. Type classes overloading convenience -constructors for building paths, labels, ellipses... The -constructors are convenient in that attributes - colour, line -width, etc. - may be specified or not. The technique is due to -Iavor S. Diatchki's XML-Light. +an affine frame. Generally the functions here are convenience +constructors for types from the hidden module +\texttt{Wumpus.Core.PictureInternal}. The types from this +module are exported as opaque signatures by +\texttt{Wumpus.Core.WumpusTypes}. \item[\texttt{Wumpus.Core.PtSize.}] Text size calculations in \texttt{Core.FontSize} use points diff --git a/doc-src/WorldFrame.hs b/doc-src/WorldFrame.hs --- a/doc-src/WorldFrame.hs +++ b/doc-src/WorldFrame.hs @@ -27,11 +27,11 @@ makeLabelPrim :: String -> DPoint2 -> DPrimitive -makeLabelPrim = textlabel attrs +makeLabelPrim = textlabel black attrs where - attrs = (black, FontAttr 10 (FontFace "Helvetica" "Helvetica" SVG_REGULAR)) + attrs = FontAttr 10 (FontFace "Helvetica" "Helvetica" SVG_REGULAR) makeLinePrim :: Double -> DPoint2 -> DPoint2 -> DPrimitive -makeLinePrim lw a b = ostroke attrs $ path a [lineTo b] +makeLinePrim lw a b = ostroke black attrs $ path a [lineTo b] where - attrs = (black, [LineWidth lw]) + attrs = default_stroke_attr {line_width=lw} diff --git a/doc/Guide.pdf b/doc/Guide.pdf Binary files a/doc/Guide.pdf and b/doc/Guide.pdf differ 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 @@ -209,7 +209,7 @@ -- For variable width fonts the calculated bounding box will -- usually be too long. -- -textBounds :: (Fractional u, Ord u, FromPtSize u) +textBounds :: (Num u, Ord u, FromPtSize u) => FontSize -> Point2 u -> CharCount -> BoundingBox u textBounds sz body_bl n = bbox bl tr where h = fromPtSize $ textHeight sz 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 @@ -56,8 +56,9 @@ , FontFace(..) , SVGFontStyle(..) - -- ** Default graphic state + -- * Initial graphic state , zeroGS + , default_stroke_attr ) where @@ -73,29 +74,23 @@ { gs_draw_colour :: RGBi , gs_font_size :: Int , gs_font_face :: FontFace - , gs_line_width :: Double - , gs_miter_limit :: Double - , gs_line_cap :: LineCap - , gs_line_join :: LineJoin - , gs_dash_pattern :: DashPattern + , gs_stroke_attr :: StrokeAttr } deriving (Eq,Show) - --- | Stroke attributes are an algebriac type rather than a --- record type. This is for convenience when attributing paths - --- paths can be attibuted with just the differences from the --- default settings, rather than all the settings whether or not --- they are important. +-- | Stroke attributes for drawing paths. -- -data StrokeAttr = LineWidth Double - | MiterLimit Double - | LineCap LineCap - | LineJoin LineJoin - | DashPattern DashPattern +data StrokeAttr = StrokeAttr + { line_width :: Double + , miter_limit :: Double + , line_cap :: LineCap + , line_join :: LineJoin + , dash_pattern :: DashPattern + } deriving (Eq,Show) + -- | Line cap - default in output is butt. -- data LineCap = CapButt | CapRound | CapSquare @@ -159,11 +154,18 @@ zeroGS = GraphicsState { gs_draw_colour = black , gs_font_size = (-1) , gs_font_face = unmatchable_face - , gs_line_width = 1 - , gs_miter_limit = 1 - , gs_line_cap = CapButt - , gs_line_join = JoinMiter - , gs_dash_pattern = Solid + , gs_stroke_attr = default_stroke_attr } where unmatchable_face = FontFace "DONT_MATCH" "" SVG_BOLD_OBLIQUE + + +-- | Default stroke attributes. +-- +default_stroke_attr :: StrokeAttr +default_stroke_attr = StrokeAttr { line_width = 1 + , miter_limit = 1 + , line_cap = CapButt + , line_join = JoinMiter + , dash_pattern = Solid + } 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 @@ -85,9 +85,9 @@ Just n -> (Right n,s) Nothing -> (Left $ ps_fallback r,s) -runLocalGS :: GSUpdate -> PsMonad a -> PsMonad a -runLocalGS upd mf = - PsMonad $ \r s -> let (a,_) = getPsMonad mf r (getGSU upd s) in (a,s) +-- runLocalGS :: GSUpdate -> PsMonad a -> PsMonad a +-- runLocalGS upd mf = +-- PsMonad $ \r s -> let (a,_) = getPsMonad mf r (getGSU upd s) in (a,s) getDrawColour :: PsMonad RGBi getDrawColour = PsMonad $ \_ s -> (gs_draw_colour s, s) @@ -107,38 +107,52 @@ getLineWidth :: PsMonad Double -getLineWidth = PsMonad $ \_ s -> (gs_line_width s, s) +getLineWidth = PsMonad $ \_ s -> (line_width $ gs_stroke_attr s, s) setLineWidth :: Double -> PsMonad () -setLineWidth a = PsMonad $ \_ s -> ((), s { gs_line_width=a }) - +setLineWidth a = PsMonad $ \_ s -> + ((), s { gs_stroke_attr = fn $ gs_stroke_attr s }) + where + fn sa = sa { line_width = a } getMiterLimit :: PsMonad Double -getMiterLimit = PsMonad $ \_ s -> (gs_miter_limit s,s) +getMiterLimit = PsMonad $ \_ s -> (miter_limit $ gs_stroke_attr s,s) setMiterLimit :: Double -> PsMonad () -setMiterLimit a = PsMonad $ \_ s -> ((), s { gs_miter_limit=a }) +setMiterLimit a = PsMonad $ \_ s -> + ((), s { gs_stroke_attr = fn $ gs_stroke_attr s }) + where + fn sa = sa { miter_limit = a } getLineCap :: PsMonad LineCap -getLineCap = PsMonad $ \_ s -> (gs_line_cap s,s) +getLineCap = PsMonad $ \_ s -> (line_cap $ gs_stroke_attr s,s) setLineCap :: LineCap -> PsMonad () -setLineCap a = PsMonad $ \_ s -> ((), s { gs_line_cap=a }) +setLineCap a = PsMonad $ \_ s -> + ((), s { gs_stroke_attr = fn $ gs_stroke_attr s }) + where + fn sa = sa { line_cap = a } getLineJoin :: PsMonad LineJoin -getLineJoin = PsMonad $ \_ s -> (gs_line_join s,s) +getLineJoin = PsMonad $ \_ s -> (line_join $ gs_stroke_attr s,s) setLineJoin :: LineJoin -> PsMonad () -setLineJoin a = PsMonad $ \_ s -> ((), s { gs_line_join=a }) +setLineJoin a = PsMonad $ \_ s -> + ((), s { gs_stroke_attr = fn $ gs_stroke_attr s }) + where + fn sa = sa { line_join = a } getDashPattern :: PsMonad DashPattern -getDashPattern = PsMonad $ \_ s -> (gs_dash_pattern s,s) +getDashPattern = PsMonad $ \_ s -> (dash_pattern $ gs_stroke_attr s,s) setDashPattern :: DashPattern -> PsMonad () -setDashPattern a = PsMonad $ \_ s -> ((), s { gs_dash_pattern=a }) +setDashPattern a = PsMonad $ \_ s -> + ((), s { gs_stroke_attr = fn $ gs_stroke_attr s }) + where + fn sa = sa { dash_pattern = a } -------------------------------------------------------------------------------- @@ -237,13 +251,15 @@ -------------------------------------------------------------------------------- - +-- Note - PostScript ignotes any FontCtx changes via the @Group@ +-- constructor. +-- picture :: (Real u, Floating u, PSUnit u) => Picture u -> PsMonad Doc picture (Leaf (_,xs) ones) = bracketTrafos xs $ revConcat primitive ones picture (Picture (_,xs) ones) = bracketTrafos xs $ revConcat picture ones picture (Clip (_,xs) cp pic) = bracketTrafos xs $ (vconcat <$> clipPath cp <*> picture pic) -picture (Group (_,xs) fn pic) = bracketTrafos xs (runLocalGS fn (picture pic)) +picture (Group (_,xs) _ pic) = bracketTrafos xs (picture pic) revConcat :: (a -> PsMonad Doc) -> OneList a -> PsMonad Doc @@ -310,10 +326,10 @@ primEllipse props (PrimEllipse center hw hh ctm) = bracketPrimCTM center (scaleCTM 1 (hh/hw) ctm) (drawF props) where - drawF (EFill rgb) pt = fillArcPath rgb hw pt - drawF (EStroke attrs rgb) pt = strokeArcPath rgb attrs hw pt - drawF (EFillStroke fc attrs sc) pt = - vconcat <$> fillArcPath fc hw pt <*> strokeArcPath sc attrs hw pt + drawF (EFill rgb) pt = fillArcPath rgb hw pt + drawF (EStroke sa rgb) pt = strokeArcPath rgb sa hw pt + drawF (EFillStroke fc sa sc) pt = + vconcat <$> fillArcPath fc hw pt <*> strokeArcPath sc sa hw pt @@ -329,15 +345,15 @@ <$> deltaDrawColour rgb strokeArcPath :: PSUnit u - => RGBi -> [StrokeAttr] -> u -> Point2 u -> PsMonad Doc -strokeArcPath rgb attrs radius pt = + => RGBi -> StrokeAttr -> u -> Point2 u -> PsMonad Doc +strokeArcPath rgb sa radius pt = (\rgbd attrd -> vcat [ rgbd , attrd , ps_newpath , ps_arc pt radius 0 360 , ps_closepath , ps_stroke ]) - <$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs + <$> deltaDrawColour rgb <*> deltaStrokeAttrs sa -- Note - for the otherwise case, the x-and-y coordinates are @@ -345,24 +361,56 @@ -- primLabel :: (Real u, Floating u, PSUnit u) => LabelProps -> PrimLabel u -> PsMonad Doc -primLabel (LabelProps rgb font) (PrimLabel basept txt ctm) = +primLabel (LabelProps rgb font) (PrimLabel basept body ctm) = bracketPrimCTM basept ctm mf where - mf pt = (\rgbd fontd showd -> vcat [ rgbd, fontd, ps_moveto pt, showd ]) + mf pt = (\rgbd fontd showd -> vcat [ rgbd, fontd, showd ]) <$> deltaDrawColour rgb <*> deltaFontAttrs font - <*> encodedText txt + <*> labelBody pt body +labelBody :: PSUnit u => Point2 u -> LabelBody u -> PsMonad Doc +labelBody pt (StdLayout txt) = (\d1 -> ps_moveto pt `vconcat` d1) + <$> encodedText txt +labelBody pt (KernTextH xs) = kernTextH pt xs +labelBody pt (KernTextV xs) = kernTextV pt xs + + encodedText :: EncodedText -> PsMonad Doc encodedText etext = vcat <$> (mapM textChunk $ getEncodedText etext) textChunk :: TextChunk -> PsMonad Doc -textChunk (SText s) = pure (ps_show $ escapeSpecial s) -textChunk (EscStr s) = pure (ps_glyphshow s) -textChunk (EscInt i) = (either failk ps_glyphshow) <$> askCharCode i +textChunk (TextSpan s) = pure (ps_show $ escapeSpecial s) +textChunk (TextEscName s) = pure (ps_glyphshow s) +textChunk (TextEscInt i) = (either failk ps_glyphshow) <$> askCharCode i where failk gly_name = missingCharCode i gly_name +kernTextH :: PSUnit u => Point2 u -> [KerningChar u] -> PsMonad Doc +kernTextH pt0 xs = snd <$> F.foldlM fn (pt0,empty) xs + where + fn (P2 x y,acc) (dx,ch) = (\doc1 -> let pt = P2 (x+dx) y in + (pt, vcat [acc, ps_moveto pt, doc1])) + <$> encodedChar ch + +-- Note - vertical labels grow downwards... +-- +kernTextV :: PSUnit u => Point2 u -> [KerningChar u] -> PsMonad Doc +kernTextV pt0 xs = snd <$> F.foldlM fn (pt0,empty) xs + where + fn (P2 x y,acc) (dy,ch) = (\doc1 -> let pt = P2 x (y-dy) in + (pt, vcat [acc, ps_moveto pt, doc1])) + <$> encodedChar ch + + +encodedChar :: EncodedChar -> PsMonad Doc +encodedChar (CharLiteral c) = pure (ps_show $ escapeSpecialChar c) +encodedChar (CharEscName s) = pure (ps_glyphshow s) +encodedChar (CharEscInt i) = (either failk ps_glyphshow) <$> askCharCode i + where + failk gly_name = missingCharCode i gly_name + + -------------------------------------------------------------------------------- -- Stroke, font and drawing colour attribute delta @@ -389,74 +437,38 @@ else setDrawColour rgb >> return (ps_setrgbcolor rgb) --- Note - the current way of handling Stroke Deltas for --- PostScript uses an awful lot of operations. --- --- The GraphicsState data types need some more thought --- - -data StrokeDelta = StrokeDelta - { sd_line_width :: Double - , sd_miter_limit :: Double - , sd_line_cap :: LineCap - , sd_line_join :: LineJoin - , sd_dash_pattern :: DashPattern - } - --- | Note - the values here must be in- sync with zeroGS. --- -zeroSD :: StrokeDelta -zeroSD = StrokeDelta { sd_line_width = 1 - , sd_miter_limit = 1 - , sd_line_cap = CapButt - , sd_line_join = JoinMiter - , sd_dash_pattern = Solid - } - - -makeStrokeDelta :: [StrokeAttr] -> StrokeDelta -makeStrokeDelta = foldr fn zeroSD - where - fn (LineWidth a) sd = sd { sd_line_width = a } - fn (MiterLimit a) sd = sd { sd_miter_limit = a } - fn (LineCap a) sd = sd { sd_line_cap = a } - fn (LineJoin a) sd = sd { sd_line_join = a } - fn (DashPattern a) sd = sd { sd_dash_pattern = a} - - -deltaStrokeAttrs :: [StrokeAttr] -> PsMonad Doc -deltaStrokeAttrs xs = step $ makeStrokeDelta xs +deltaStrokeAttrs :: StrokeAttr -> PsMonad Doc +deltaStrokeAttrs sa = + (\d1 d2 d3 d4 d5 -> hcat $ catMaybes [d1,d2,d3,d4,d5]) + <$> lw <*> ml <*> lc <*> lj <*> dp where - step sd = (\d1 d2 d3 d4 d5 -> hcat $ catMaybes [d1,d2,d3,d4,d5]) - <$> lw sd <*> ml sd <*> lc sd <*> lj sd <*> dp sd - - lw sd = let d = sd_line_width sd in - getLineWidth >>= \inh -> - if d == inh + lw = let d = line_width sa in + getLineWidth >>= \inh -> + if d == inh then return Nothing else setLineWidth d >> return (Just $ ps_setlinewidth d) - ml sd = let d = sd_miter_limit sd in - getMiterLimit >>= \inh -> - if d==inh + ml = let d = miter_limit sa in + getMiterLimit >>= \inh -> + if d==inh then return Nothing else setMiterLimit d >> return (Just $ ps_setmiterlimit d) - lc sd = let d = sd_line_cap sd in - getLineCap >>= \inh -> - if d==inh + lc = let d = line_cap sa in + getLineCap >>= \inh -> + if d==inh then return Nothing else setLineCap d >> return (Just $ ps_setlinecap d) - lj sd = let d = sd_line_join sd in - getLineJoin >>= \inh -> - if d==inh + lj = let d = line_join sa in + getLineJoin >>= \inh -> + if d==inh then return Nothing else setLineJoin d >> return (Just $ ps_setlinejoin d) - dp sd = let d = sd_dash_pattern sd in - getDashPattern >>= \inh -> - if d==inh + dp = let d = dash_pattern sa in + getDashPattern >>= \inh -> + if d==inh then return Nothing else setDashPattern d >> return (Just $ ps_setdash d) 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 @@ -56,6 +56,7 @@ import Control.Applicative hiding ( empty, some ) import qualified Data.Foldable as F +import Data.Maybe -- SvgMonad is two Readers plus Int state for clip paths... -- @@ -96,29 +97,35 @@ -- (and /graphics state/ is via a Reader), so it is the same as -- local with a Reader monad. -- -runLocalGS :: GSUpdate -> SvgMonad a -> SvgMonad a +runLocalGS :: (GraphicsState -> GraphicsState) -> SvgMonad a -> SvgMonad a runLocalGS upd mf = - SvgMonad $ \r1 r2 s -> getSvgMonad mf r1 (getGSU upd r2) s + SvgMonad $ \r1 r2 s -> getSvgMonad mf r1 (upd r2) s +askGraphicsState :: SvgMonad GraphicsState +askGraphicsState = SvgMonad $ \_ r2 s -> (r2,s) + +asksGraphicsState :: (GraphicsState -> a) -> SvgMonad a +asksGraphicsState fn = SvgMonad $ \_ r2 s -> (fn r2,s) + askFontAttr :: SvgMonad FontAttr askFontAttr = - SvgMonad $ \_ r2 s -> (FontAttr (gs_font_size r2) (gs_font_face r2), s) + asksGraphicsState $ \r -> FontAttr (gs_font_size r) (gs_font_face r) askLineWidth :: SvgMonad Double -askLineWidth = SvgMonad $ \_ r2 s -> (gs_line_width r2, s) +askLineWidth = asksGraphicsState (line_width . gs_stroke_attr) askMiterLimit :: SvgMonad Double -askMiterLimit = SvgMonad $ \_ r2 s -> (gs_miter_limit r2, s) +askMiterLimit = asksGraphicsState (miter_limit . gs_stroke_attr) askLineCap :: SvgMonad LineCap -askLineCap = SvgMonad $ \_ r2 s -> (gs_line_cap r2, s) +askLineCap = asksGraphicsState (line_cap . gs_stroke_attr) askLineJoin :: SvgMonad LineJoin -askLineJoin = SvgMonad $ \_ r2 s -> (gs_line_join r2, s) +askLineJoin = asksGraphicsState (line_join . gs_stroke_attr) askDashPattern :: SvgMonad DashPattern -askDashPattern = SvgMonad $ \_ r2 s -> (gs_dash_pattern r2, s) +askDashPattern = asksGraphicsState (dash_pattern . gs_stroke_attr) -------------------------------------------------------------------------------- @@ -170,7 +177,7 @@ ; d2 <- picture pic ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2)) } -picture (Group (_,xs) fn pic) = bracketTrafos xs (runLocalGS fn (picture pic)) +picture (Group (_,xs) fn pic) = bracketTrafos xs $ bracketGS fn (picture pic) @@ -275,53 +282,105 @@ primLabel :: (Real u, Floating u, PSUnit u) => LabelProps -> PrimLabel u -> SvgMonad Doc -primLabel (LabelProps rgb attrs) (PrimLabel pt etext ctm) = - (\fa ca txt -> elem_text (fa <+> ca) txt) - <$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm mkXY - <*> tspan rgb etext - where - mkXY (P2 x y) = pure $ attr_x x <+> attr_y y +primLabel (LabelProps rgb attrs) (PrimLabel pt body ctm) = + (\fa ca dtxt -> elem_text (fa <+> ca) (makeTspan rgb dtxt)) + <$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm (labelBodyCoords body) + <*> labelBodyText body + -tspan :: RGBi -> EncodedText -> SvgMonad Doc -tspan rgb enctext = - (\txt -> elem_tspan (attr_fill rgb) txt) - <$> encodedText enctext +labelBodyCoords :: PSUnit u => LabelBody u -> Point2 u -> SvgMonad Doc +labelBodyCoords (StdLayout _) pt = pure $ makeXY pt +labelBodyCoords (KernTextH xs) pt = pure $ makeXsY pt xs +labelBodyCoords (KernTextV xs) pt = pure $ makeXYs pt xs + +labelBodyText :: LabelBody u -> SvgMonad Doc +labelBodyText (StdLayout enctext) = encodedText enctext +labelBodyText (KernTextH xs) = hcat <$> mapM kerningChar xs +labelBodyText (KernTextV xs) = hcat <$> mapM kerningChar xs + + encodedText :: EncodedText -> SvgMonad Doc encodedText enctext = hcat <$> mapM textChunk (getEncodedText enctext) - textChunk :: TextChunk -> SvgMonad Doc -textChunk (SText s) = pure $ text s -textChunk (EscInt i) = pure $ text $ escapeSpecial i -textChunk (EscStr s) = either text text <$> askGlyphName s +textChunk (TextSpan s) = pure $ text s +textChunk (TextEscInt i) = pure $ text $ escapeSpecial i +textChunk (TextEscName s) = either text text <$> askGlyphName s +kerningChar :: KerningChar u -> SvgMonad Doc +kerningChar (_, CharLiteral c) = pure $ char c +kerningChar (_, CharEscInt i) = pure $ text $ escapeSpecial i +kerningChar (_, CharEscName s) = either text text <$> askGlyphName s + +makeTspan :: RGBi -> Doc -> Doc +makeTspan rgb body = elem_tspan (attr_fill rgb) body + +makeXY :: PSUnit u => Point2 u -> Doc +makeXY (P2 x y) = attr_x x <+> attr_y y + +-- This is for horizontal kerning text, the output is of the +-- form: +-- +-- > x="0 10 25 35" y="0" +-- +makeXsY :: PSUnit u => Point2 u -> [KerningChar u] -> Doc +makeXsY (P2 x y) ks = attr_xs (step x ks) <+> attr_y y + where + step ax ((d,_):ds) = let a = ax+d in a : step a ds + step _ [] = [] + + +-- This is for vertical kerning text, the output is of the +-- form: +-- +-- > x="0 0 0 0" y="0 10 25 35" +-- +-- Note - this is different to the horizontal version as the +-- x-coord needs to be /realigned/ at each step. +-- +makeXYs :: PSUnit u => Point2 u -> [KerningChar u] -> Doc +makeXYs (P2 x y) ks = attr_xs xcoords <+> attr_ys (step y ks) + where + xcoords = replicate (length ks) x + step ay ((d,_):ds) = let a = ay+d in a : step a ds + step _ [] = [] + + + -------------------------------------------------------------------------------- -- Stroke and font attribute delta -deltaStrokeAttrs :: [StrokeAttr] -> SvgMonad Doc -deltaStrokeAttrs xs = hsep <$> mapM df xs +deltaStrokeAttrs :: StrokeAttr -> SvgMonad Doc +deltaStrokeAttrs sa = + (\d1 d2 d3 d4 d5 -> hsep $ catMaybes [d1,d2,d3,d4,d5]) + <$> lw <*> ml <*> lc <*> lj <*> dp where - df (LineWidth d) = (\inh -> if d==inh then empty - else attr_stroke_width d) - <$> askLineWidth - - df (MiterLimit d) = (\inh -> if d==inh then empty - else attr_stroke_miterlimit d) - <$> askMiterLimit + lw = let d = line_width sa in + askLineWidth >>= \inh -> + if d==inh then return Nothing + else return (Just $ attr_stroke_width d) + + ml = let d = miter_limit sa in + askMiterLimit >>= \inh -> + if d==inh then return Nothing + else return (Just $ attr_stroke_miterlimit d) - df (LineCap d) = (\inh -> if d==inh then empty - else attr_stroke_linecap d) - <$> askLineCap + lc = let d = line_cap sa in + askLineCap >>= \inh -> + if d==inh then return Nothing + else return (Just $ attr_stroke_linecap d) - df (LineJoin d) = (\inh -> if d==inh then empty - else attr_stroke_linejoin d) - <$> askLineJoin + lj = let d = line_join sa in + askLineJoin >>= \inh -> + if d==inh then return Nothing + else return (Just $ attr_stroke_linejoin d) - df (DashPattern d) = (\inh -> if d==inh then empty - else makeDashPattern d) - <$> askDashPattern + dp = let d = dash_pattern sa in + askDashPattern >>= \inh -> + if d==inh then return Nothing + else return (Just $ makeDashPattern d) makeDashPattern :: DashPattern -> Doc makeDashPattern Solid = attr_stroke_dasharray_none @@ -331,7 +390,7 @@ deltaFontAttrs :: FontAttr -> SvgMonad Doc -deltaFontAttrs fa = +deltaFontAttrs fa = (\inh -> if fa ==inh then empty else makeFontAttrs fa) <$> askFontAttr makeFontAttrs :: FontAttr -> Doc @@ -353,6 +412,28 @@ suffix SVG_BOLD_OBLIQUE = space <> attr_font_weight "bold" <+> attr_font_style "oblique" + +-- NOTE - as is only practical to delta the FontFace attributes +-- it might be good to specialize / simplify the graphics state +-- GSUpdate to a simpler type rather than a functional one... + +bracketGS :: FontCtx -> SvgMonad Doc -> SvgMonad Doc +bracketGS (FontCtx new_font) mf = + (\old body -> mkElem old body) + <$> askGraphicsState <*> runLocalGS updateF mf + where + mkElem old body + | fontMatch old new_font = elem_g_no_attrs body + | otherwise = let a = makeFontAttrs new_font + in elem_g a body + + updateF s = s { gs_font_size = font_size new_font + , gs_font_face = font_face new_font } + + +fontMatch :: GraphicsState -> FontAttr -> Bool +fontMatch gs fa = + gs_font_size gs == font_size fa && gs_font_face gs == font_face fa -------------------------------------------------------------------------------- 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 @@ -23,6 +23,7 @@ -- * Construction frame , multi + , fontDeltaContext , path , lineTo , curveTo @@ -31,19 +32,42 @@ , xlinkhref -- * Constructing primitives - , Stroke(..) + , ostroke + , cstroke + , xostroke + , xcstroke , zostroke , zcstroke - , Fill(..) + + , fill + , xfill , zfill - , Ellipse(..) - , zellipse + , bordered + , xbordered , clip - , TextLabel(..) + , textlabel + , xtextlabel , ztextlabel + , wumpus_default_font + , hkernlabel + , vkernlabel + , xhkernlabel + , xvkernlabel + , kernchar + , kernEscInt + , kernEscName + + , strokeEllipse + , fillEllipse + , xstrokeEllipse + , xfillEllipse + , zellipse + , borderedEllipse + + -- * Operations , extendBoundary @@ -63,7 +87,7 @@ import Wumpus.Core.AffineTrans import Wumpus.Core.BoundingBox import Wumpus.Core.Colour -import Wumpus.Core.FormatCombinators +import Wumpus.Core.FormatCombinators hiding ( fill ) import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState import Wumpus.Core.OneList @@ -112,7 +136,38 @@ in ( boundary a `append` bb', cons a rest ) +-- | Update the font /delta/ attributes for SVG output. +-- +-- Note - 'fontDeltaContext' does not set the font properties of +-- elements in the supplied Picture, it is solely a mechanism to +-- help reduce the code size of the generated SVG by factoring +-- common attributes into a group (g) element. For instance, +-- settting the font properties with 'fontDeltaContext' can +-- eliminate the repeated use of font-family and font-size in +-- this code: +-- +-- > ... +-- > ... +-- > ... +-- +-- With the appropriate font delta context, this code will be +-- generated: +-- +-- > +-- > ... +-- > ... +-- > ... +-- > +-- +-- Wumpus ignores 'fontDeltaContext' directives when generating +-- PostScript. Unlike SVG, PostScript is not naturally nested, so +-- introducing nesting with @gsave@ and @grestore@ is not likely +-- to improve the PostScript Wumpus generates. +-- +fontDeltaContext :: FontAttr -> Picture u -> Picture u +fontDeltaContext fa p = Group (boundary p, []) (FontCtx fa) p + -- | Create a Path from a start point and a list of PathSegments. -- path :: Point2 u -> [PrimPathSegment u] -> PrimPath u @@ -151,119 +206,108 @@ step _ = [] +-- | Create a hyperlink for SVG output. +-- xlinkhref :: String -> XLink xlinkhref = XLinkHRef + + -------------------------------------------------------------------------------- -- Take Paths to Primitives -- *** Stroke -ostrokePath :: Num u - => RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u -ostrokePath rgb attrs xlink p = PPath (OStroke attrs rgb) xlink p +-- | Create a open, stroked path. +-- +ostroke :: Num u + => RGBi -> StrokeAttr -> PrimPath u -> Primitive u +ostroke rgb sa p = PPath (OStroke sa rgb) NoLink p -cstrokePath :: Num u - => RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u -cstrokePath rgb attrs xlink p = PPath (CStroke attrs rgb) xlink p --- | Create a open, stroked path (@ostroke@) or a closed, stroked --- path (@cstroke@). +-- | Create a closed, stroked path. -- --- @ostroke@ and @cstroke@ are overloaded to make attributing --- the path more convenient. --- -class Stroke t where - ostroke :: Num u => t -> PrimPath u -> Primitive u - cstroke :: Num u => t -> PrimPath u -> Primitive u +cstroke :: Num u + => RGBi -> StrokeAttr -> PrimPath u -> Primitive u +cstroke rgb sa p = PPath (CStroke sa rgb) NoLink p -instance Stroke () where - ostroke () = ostrokePath black [] NoLink - cstroke () = cstrokePath black [] NoLink +-- | Create a open, stroked path with a hyperlink. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xostroke :: Num u + => RGBi -> StrokeAttr -> XLink -> PrimPath u -> Primitive u +xostroke rgb sa xlink p = PPath (OStroke sa rgb) xlink p -instance Stroke RGBi where - ostroke rgb = ostrokePath rgb [] NoLink - cstroke rgb = cstrokePath rgb [] NoLink -instance Stroke StrokeAttr where - ostroke x = ostrokePath black [x] NoLink - cstroke x = cstrokePath black [x] NoLink +-- | Create a closed, stroked path with a hyperlink. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xcstroke :: Num u + => RGBi -> StrokeAttr -> XLink -> PrimPath u -> Primitive u +xcstroke rgb sa xlink p = PPath (CStroke sa rgb) xlink p -instance Stroke [StrokeAttr] where - ostroke xs = ostrokePath black xs NoLink - cstroke xs = cstrokePath black xs NoLink -instance Stroke XLink where - ostroke xlink = ostrokePath black [] xlink - cstroke xlink = cstrokePath black [] xlink -instance Stroke (RGBi,StrokeAttr) where - ostroke (rgb,x) = ostrokePath rgb [x] NoLink - cstroke (rgb,x) = cstrokePath rgb [x] NoLink +-- | Create an open, stroked path using the default stroke +-- attributes and coloured black. +-- +zostroke :: Num u => PrimPath u -> Primitive u +zostroke = ostroke black default_stroke_attr + +-- | Create a closed stroked path using the default stroke +-- attributes and coloured black. +-- +zcstroke :: Num u => PrimPath u -> Primitive u +zcstroke = cstroke black default_stroke_attr -instance Stroke (RGBi,[StrokeAttr]) where - ostroke (rgb,xs) = ostrokePath rgb xs NoLink - cstroke (rgb,xs) = cstrokePath rgb xs NoLink +-------------------------------------------------------------------------------- +-- *** Fill -instance Stroke (RGBi,XLink) where - ostroke (rgb,xlink) = ostrokePath rgb [] xlink - cstroke (rgb,xlink) = cstrokePath rgb [] xlink -instance Stroke (StrokeAttr,XLink) where - ostroke (x,xlink) = ostrokePath black [x] xlink - cstroke (x,xlink) = cstrokePath black [x] xlink - -instance Stroke ([StrokeAttr],XLink) where - ostroke (xs,xlink) = ostrokePath black xs xlink - cstroke (xs,xlink) = cstrokePath black xs xlink - -instance Stroke (RGBi,StrokeAttr,XLink) where - ostroke (rgb,x,xlink) = ostrokePath rgb [x] xlink - cstroke (rgb,x,xlink) = cstrokePath rgb [x] xlink - -instance Stroke (RGBi,[StrokeAttr],XLink) where - ostroke (rgb,xs,xlink) = ostrokePath rgb xs xlink - cstroke (rgb,xs,xlink) = cstrokePath rgb xs xlink +-- | Create a filled path. +-- +fill :: Num u => RGBi -> PrimPath u -> Primitive u +fill rgb p = PPath (CFill rgb) NoLink p --- | Create an open stoke coloured black. +-- | Create a filled path with a hyperlink. -- -zostroke :: Num u => PrimPath u -> Primitive u -zostroke = ostrokePath black [] NoLink - --- | Create a closed stroke coloured black. +-- Note - hyperlinks are only rendered in SVG output. -- -zcstroke :: Num u => PrimPath u -> Primitive u -zcstroke = cstrokePath black [] NoLink +xfill :: Num u => RGBi -> XLink -> PrimPath u -> Primitive u +xfill rgb xlink p = PPath (CFill rgb) xlink p +-- | Create a filled path coloured black. +zfill :: Num u => PrimPath u -> Primitive u +zfill = fill black --- *** Fill -fillPath :: Num u => RGBi -> XLink -> PrimPath u -> Primitive u -fillPath rgb xlink p = PPath (CFill rgb) xlink p +-------------------------------------------------------------------------------- +-- Bordered (closed) paths --- | Create a filled path (@fill@). Fills only have one --- property - colour. But there are various representations of --- colour. + +-- | Create a closed path that is both filled and stroked (the fill +-- is below in the zorder). -- --- @ fill () @ will fill with the default colour - black. --- -class Fill t where - fill :: Num u => t -> PrimPath u -> Primitive u - +-- > fill colour * stroke attrs * stroke_colour * ... +-- +bordered :: Num u + => RGBi -> StrokeAttr -> RGBi -> PrimPath u -> Primitive u +bordered frgb sa srgb p = PPath (CFillStroke frgb sa srgb) NoLink p -instance Fill () where fill () = fillPath black NoLink -instance Fill RGBi where fill rgb = fillPath rgb NoLink -instance Fill XLink where fill xlink = fillPath black xlink -instance Fill (RGBi,XLink) where - fill (rgb,xlink) = fillPath rgb xlink +-- | Create a bordered, closed path with a hyperlink. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xbordered :: Num u + => RGBi -> StrokeAttr -> RGBi -> XLink -> PrimPath u -> Primitive u +xbordered frgb sa srgb xlink p = PPath (CFillStroke frgb sa srgb) xlink p --- | Create a filled path coloured black. -zfill :: Num u => PrimPath u -> Primitive u -zfill = fillPath black NoLink -------------------------------------------------------------------------------- -- Clipping @@ -276,12 +320,37 @@ -------------------------------------------------------------------------------- -- Labels to primitive -mkTextLabel :: Num u - => RGBi -> FontAttr -> XLink -> String -> Point2 u -> Primitive u -mkTextLabel rgb attr xlink txt pt = PLabel (LabelProps rgb attr) xlink lbl +-- | Create a text label. The string should not contain newline +-- or tab characters. +-- +-- The supplied point is the left baseline. +-- +textlabel :: Num u + => RGBi -> FontAttr -> String -> Point2 u -> Primitive u +textlabel rgb attr txt = xtextlabel rgb attr NoLink txt + + +-- | Create a text label with a hyperlink. The string should not +-- contain newline or tab characters. +-- +-- The supplied point is the left baseline. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xtextlabel :: Num u + => RGBi -> FontAttr -> XLink -> String -> Point2 u -> Primitive u +xtextlabel rgb attr xlink txt pt = PLabel (LabelProps rgb attr) xlink lbl where - lbl = PrimLabel pt (lexLabel txt) identityCTM + lbl = PrimLabel pt (StdLayout $ lexLabel txt) identityCTM + +-- | Create a label where the font is @Courier@, text size is 14pt +-- and colour is black. +-- +ztextlabel :: Num u => String -> Point2 u -> Primitive u +ztextlabel = xtextlabel black wumpus_default_font NoLink + + -- | Constant for the default font, which is @Courier@ (aliased -- to @Courier New@ for SVG) at 14 point. -- @@ -294,124 +363,180 @@ , svg_font_style = SVG_REGULAR } +-------------------------------------------------------------------------------- --- | Create a text label. The string should not contain newline --- or tab characters. Use 'multilabel' to create text with --- multiple lines. --- --- @textlabel@ is overloaded to make attributing the label more --- convenient. +-- | Create a text label with horizontal /kerning/ for each +-- character. -- --- Unless a 'FontAttr' is specified, the label will use 14pt --- Courier. +-- Note - kerning is relative to the left baseline of the +-- previous character, it is \*not relative\* to the right-hand +-- boundary of the previous char. While the later would be more +-- obvious it would take a lot of effort to implement as it would +-- need access to the metrics encoded in font files. -- --- The supplied point is is the bottom left corner. +-- Characters are expected to be drawn left to right, so +-- displacements should not be negative. If the displacement is +-- zero the character will be drawn ontop of the previous char. +-- +-- The charcters should not contain newline or tab characters. -- -class TextLabel t where - textlabel :: Num u => t -> String -> Point2 u -> Primitive u +-- The supplied point is the left baseline. +-- +hkernlabel :: Num u + => RGBi -> FontAttr -> [KerningChar u] -> Point2 u + -> Primitive u +hkernlabel rgb attr xs = xhkernlabel rgb attr NoLink xs -instance TextLabel () where - textlabel () = mkTextLabel black wumpus_default_font NoLink + +-- | Create a horizontally kerned text label with a hyperlink. +-- +-- The is the hyperlink version of 'hkernlabel'. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xhkernlabel :: Num u + => RGBi -> FontAttr -> XLink -> [KerningChar u] -> Point2 u + -> Primitive u +xhkernlabel rgb attr xlink xs pt = PLabel (LabelProps rgb attr) xlink lbl + where + lbl = PrimLabel pt (KernTextH xs) identityCTM -instance TextLabel RGBi where - textlabel rgb = mkTextLabel rgb wumpus_default_font NoLink -instance TextLabel FontAttr where - textlabel a = mkTextLabel black a NoLink -instance TextLabel XLink where - textlabel xlink = mkTextLabel black wumpus_default_font xlink +-- | Create a text label with vertical /kerning/ for each +-- character - the text is expected to grow downwards. +-- +-- Note - /kerning/ here is the measure between baselines of +-- sucessive characters, it is \*not\* the distance between the +-- bottom of one chararter and the top of the next character. +-- +-- While the later maybe be more obvious from a drawing +-- perspective, it would take a lot of effort to implement as it +-- would need access to the metrics encoded in font files. +-- +-- Characters are expected to be drawn downwards - a positive +-- number represents the downward displacement - so displacements +-- should not be negative. If the displacement is zero the +-- character will be drawn ontop of the previous char. +-- +-- The charcters should not contain newline or tab characters. +-- +-- The supplied point is the left baseline of the top character. +-- +vkernlabel :: Num u + => RGBi -> FontAttr ->[KerningChar u] -> Point2 u + -> Primitive u +vkernlabel rgb attr xs = xvkernlabel rgb attr NoLink xs -instance TextLabel (RGBi,FontAttr) where - textlabel (rgb,a) = mkTextLabel rgb a NoLink +-- | Create a vertically drawn text label with a hyperlink. +-- +-- The is the hyperlink version of 'vkernlabel'. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xvkernlabel :: Num u + => RGBi -> FontAttr -> XLink -> [KerningChar u] -> Point2 u + -> Primitive u +xvkernlabel rgb attr xlink xs pt = PLabel (LabelProps rgb attr) xlink lbl + where + lbl = PrimLabel pt (KernTextV xs) identityCTM -instance TextLabel (RGBi,XLink) where - textlabel (rgb,xlink) = mkTextLabel rgb wumpus_default_font xlink -instance TextLabel (FontAttr,XLink) where - textlabel (a,xlink) = mkTextLabel black a xlink -instance TextLabel (RGBi,FontAttr,XLink) where - textlabel (rgb,a,xlink) = mkTextLabel rgb a xlink +-- | Construct a regular (i.e. non-special) Char along with its +-- displacement from the left-baseline of the previous Char. +-- +kernchar :: u -> Char -> KerningChar u +kernchar u c = (u, CharLiteral c) --- | Create a label where the font is @Courier@, text size is 14pt --- and colour is black. +-- | Construct a Char by its character code along with its +-- displacement from the left-baseline of the previous Char. -- -ztextlabel :: Num u => String -> Point2 u -> Primitive u -ztextlabel = mkTextLabel black wumpus_default_font NoLink +kernEscInt :: u -> Int -> KerningChar u +kernEscInt u i = (u, CharEscInt i) +-- | Construct a Char by its character name along with its +-- displacement from the left-baseline of the previous Char. +-- +kernEscName :: u -> String -> KerningChar u +kernEscName u s = (u, CharEscName s) -------------------------------------------------------------------------------- -mkEllipse :: Num u - => EllipseProps -> XLink -> u -> u -> Point2 u -> Primitive u -mkEllipse props xlink hw hh pt = - PEllipse props xlink (PrimEllipse pt hw hh identityCTM) - -ellipseDefault :: EllipseProps -ellipseDefault = EFill black - - --- | Create an ellipse, the ellipse will be filled unless the --- supplied attributes /imply/ a stroked ellipse, e.g.: --- --- > ellipse (LineWidth 4) zeroPt 40 40 +-- | Create a stroked ellipse. -- -- Note - within Wumpus, ellipses are considered an unfortunate -- but useful /optimization/. Drawing good cicles with Beziers -- needs at least eight curves, but drawing them with --- PostScript\'s @arc@ command is a single operation. For +-- PostScript\'s @arc@ command needs a single operation. For -- drawings with many dots (e.g. scatter plots) it seems sensible --- to employ this optimaztion. +-- to employ this optimization. -- -- A deficiency of Wumpus\'s ellipse is that (non-uniformly) -- scaling a stroked ellipse also (non-uniformly) scales the pen -- it is drawn with. Where the ellipse is wider, the pen stroke -- will be wider too. -- -class Ellipse t where - ellipse :: Fractional u => t -> u -> u -> Point2 u -> Primitive u +-- Avoid non-uniform scaling stroked ellipses! +-- +strokeEllipse :: Num u + => RGBi -> StrokeAttr -> u -> u -> Point2 u -> Primitive u +strokeEllipse rgb sa = xstrokeEllipse rgb sa NoLink -instance Ellipse () where ellipse () = zellipse +-- | Create a filled ellipse. +-- +fillEllipse :: Num u + => RGBi -> u -> u -> Point2 u -> Primitive u +fillEllipse rgb = xfillEllipse rgb NoLink -instance Ellipse RGBi where - ellipse rgb = mkEllipse (EFill rgb) NoLink +-- | Create a stroked ellipse with a hyperlink. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xstrokeEllipse :: Num u + => RGBi -> StrokeAttr -> XLink -> u -> u -> Point2 u -> Primitive u +xstrokeEllipse rgb sa xlink hw hh pt = + PEllipse (EStroke sa rgb) xlink (PrimEllipse pt hw hh identityCTM) -instance Ellipse StrokeAttr where - ellipse x = mkEllipse (EStroke [x] black) NoLink +-- | Create a filled ellipse. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xfillEllipse :: Num u + => RGBi -> XLink -> u -> u -> Point2 u -> Primitive u +xfillEllipse rgb xlink hw hh pt = + PEllipse (EFill rgb) xlink (PrimEllipse pt hw hh identityCTM) -instance Ellipse [StrokeAttr] where - ellipse xs = mkEllipse (EStroke xs black) NoLink -instance Ellipse XLink where - ellipse xlink = mkEllipse (EFill black) xlink +-- | Create a black, filled ellipse. +zellipse :: Num u => u -> u -> Point2 u -> Primitive u +zellipse hw hh pt = xfillEllipse black NoLink hw hh pt -instance Ellipse (RGBi,StrokeAttr) where - ellipse (rgb,x) = mkEllipse (EStroke [x] rgb) NoLink -instance Ellipse (RGBi,[StrokeAttr]) where - ellipse (rgb,xs) = mkEllipse (EStroke xs rgb) NoLink +-- | Create a bordered (i.e. filled and stroked) ellipse. +-- +borderedEllipse :: Num u + => RGBi -> StrokeAttr -> RGBi -> u -> u -> Point2 u + -> Primitive u +borderedEllipse frgb sa srgb = xborderedEllipse frgb sa srgb NoLink -instance Ellipse (RGBi,XLink) where - ellipse (rgb,xlink) = mkEllipse (EFill rgb) xlink +-- | Create a bordered (i.e. filled and stroked) ellipse with a +-- hyperlink. +-- +-- Note - hyperlinks are only rendered in SVG output. +-- +xborderedEllipse :: Num u + => RGBi -> StrokeAttr -> RGBi -> XLink -> u -> u -> Point2 u + -> Primitive u +xborderedEllipse frgb sa srgb xlink hw hh pt = + PEllipse (EFillStroke frgb sa srgb) xlink (PrimEllipse pt hw hh identityCTM) -instance Ellipse (StrokeAttr,XLink) where - ellipse (x,xlink) = mkEllipse (EStroke [x] black) xlink -instance Ellipse ([StrokeAttr],XLink) where - ellipse (xs,xlink) = mkEllipse (EStroke xs black) xlink -instance Ellipse (RGBi,[StrokeAttr],XLink) where - ellipse (rgb,xs,xlink) = mkEllipse (EStroke xs rgb) xlink - --- | Create a black, filled ellipse. -zellipse :: Num u => u -> u -> Point2 u -> Primitive u -zellipse hw hh pt = mkEllipse ellipseDefault NoLink hw hh pt - -------------------------------------------------------------------------------- -- Operations @@ -505,11 +630,12 @@ boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ] where (bl,br,tr,tl) = boundaryCorners $ boundary a - bbox_rect = cstroke (rgb, line_attr) $ vertexPath [bl,br,tr,tl] - bl_to_tr = ostroke (rgb, line_attr) $ vertexPath [bl,tr] - br_to_tl = ostroke (rgb, line_attr) $ vertexPath [br,tl] + bbox_rect = cstroke rgb line_attr $ vertexPath [bl,br,tr,tl] + bl_to_tr = ostroke rgb line_attr $ vertexPath [bl,tr] + br_to_tl = ostroke rgb line_attr $ vertexPath [br,tl] - line_attr = [LineCap $ CapRound, DashPattern $ Dash 0 [(1,2)]] + line_attr = default_stroke_attr { line_cap = CapRound + , dash_pattern = Dash 0 [(1,2)] } -- | Generate the control points illustrating the Bezier @@ -546,7 +672,8 @@ step _ (PLineTo e:xs) = step e xs step s (PCurveTo c1 c2 e:xs) = mkLine s c1 : mkLine c2 e : step e xs - mkLine s e = ostroke rgb (PrimPath s [lineTo e]) + mkLine s e = let pp = (PrimPath s [lineTo e]) in + ostroke rgb default_stroke_attr pp -- Generate lines illustrating the control points of an @@ -570,7 +697,7 @@ rest s (c1:c2:e:xs) = mkLine s c1 : mkLine c2 e : rest e xs rest _ _ = [] - mkLine s e = ostroke rgb (PrimPath s [lineTo e]) + mkLine s e = ostroke rgb default_stroke_attr (PrimPath s [lineTo e]) 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 @@ -23,7 +23,7 @@ , DPicture , Locale , AffineTrafo(..) - , GSUpdate(..) + , FontCtx(..) , Primitive(..) , DPrimitive @@ -37,6 +37,10 @@ , PrimLabel(..) , DPrimLabel , LabelProps(..) + , LabelBody(..) + , DLabelBody + , KerningChar + , DKerningChar , PrimEllipse(..) , EllipseProps(..) , PrimCTM(..) @@ -124,21 +128,19 @@ data Picture u = Leaf (Locale u) (OneList (Primitive u)) | Picture (Locale u) (OneList (Picture u)) | Clip (Locale u) (PrimPath u) (Picture u) - | Group (Locale u) GSUpdate (Picture u) + | Group (Locale u) FontCtx (Picture u) deriving (Show) --- | Update the graphics state for SVG rendering. +-- | Set the font /delta/ for SVG rendering. -- --- Note - this does not change how any of the Primitives are --- drawn, nor does it change the default colour or font style. +-- Note - this does not change the default colour or font style. -- It is solely a backdoor into the SVG renderer to potential -- allow some code size reductions. -- -newtype GSUpdate = GSUpdate { getGSU :: GraphicsState -> GraphicsState } +newtype FontCtx = FontCtx { getFontCtx :: FontAttr } + deriving (Eq,Show) -instance Show GSUpdate where - show _ = "*function*" -- | Locale = (bounding box * current translation matrix) -- @@ -232,9 +234,9 @@ -- of the line (stroke width). -- data PathProps = CFill RGBi - | CStroke [StrokeAttr] RGBi - | OStroke [StrokeAttr] RGBi - | CFillStroke RGBi [StrokeAttr] RGBi + | CStroke StrokeAttr RGBi + | OStroke StrokeAttr RGBi + | CFillStroke RGBi StrokeAttr RGBi deriving (Eq,Show) @@ -242,13 +244,15 @@ -- data PrimLabel u = PrimLabel { label_baseline_left :: Point2 u - , label_text :: EncodedText + , label_body :: LabelBody u , label_ctm :: PrimCTM u } deriving (Eq,Show) type DPrimLabel = PrimLabel Double +-- | Font rendering properties for a PrimLabel. +-- data LabelProps = LabelProps { label_colour :: RGBi , label_font :: FontAttr @@ -256,6 +260,33 @@ deriving (Eq,Ord,Show) +-- | Label can be draw with 3 layouts. +-- +-- The standard layout uses @show@ for PostScript and a single +-- initial point for SVG. +-- +-- Kerned horizontal layout - each character is encoded with the +-- rightwards horizontal distance from the last charcaters left +-- base-line. +-- +-- Kerned vertical layout - each character is encoded with the +-- upwards distance from the last charcaters left base-line. +-- +data LabelBody u = StdLayout EncodedText + | KernTextH [KerningChar u] + | KernTextV [KerningChar u] + deriving (Eq,Show) + +type DLabelBody = LabelBody Double + + +-- | A Char (possibly escaped) paired with is displacement from +-- the previous KerningChar. +-- +type KerningChar u = (u,EncodedChar) + +type DKerningChar = KerningChar Double + -- Ellipse represented by center and half_width * half_height -- data PrimEllipse u = PrimEllipse @@ -270,9 +301,9 @@ -- | Ellipses and circles are always closed. -- data EllipseProps = EFill RGBi - | EStroke [StrokeAttr] RGBi + | EStroke StrokeAttr RGBi -- Note - first colour fill, second colour stroke. - | EFillStroke RGBi [StrokeAttr] RGBi + | EFillStroke RGBi StrokeAttr RGBi deriving (Eq,Show) @@ -361,6 +392,12 @@ <+> text "ctm=" <> format ctm ] +instance PSUnit u => Format (LabelBody u) where + format (StdLayout enctext) = format enctext + format (KernTextH xs) = text "(KernH)" <+> hcat (map (format .snd) xs) + format (KernTextV xs) = text "(KernV)" <+> hcat (map (format .snd) xs) + + instance PSUnit u => Format (PrimEllipse u) where format (PrimEllipse ctr hw hh ctm) = text "center=" <> format ctr <+> text "hw=" <> dtruncFmt hw @@ -434,14 +471,55 @@ labelBoundary :: (Floating u, Real u, FromPtSize u) => FontAttr -> PrimLabel u -> BoundingBox u -labelBoundary attr (PrimLabel (P2 x y) xs ctm) = +labelBoundary attr (PrimLabel (P2 x y) body ctm) = retraceBoundary (disp . (m33 *#)) untraf_bbox where disp = (.+^ V2 x y) m33 = matrixRepCTM ctm - untraf_bbox = textBounds (font_size attr) zeroPt char_count - char_count = textLength xs + untraf_bbox = labelBodyBoundary (font_size attr) body +labelBodyBoundary :: (Num u, Ord u, FromPtSize u) + => FontSize -> LabelBody u -> BoundingBox u +labelBodyBoundary sz (StdLayout etxt) = stdLayoutBB sz (textLength etxt) +labelBodyBoundary sz (KernTextH xs) = hKerningBB sz xs +labelBodyBoundary sz (KernTextV xs) = vKerningBB sz xs + + +stdLayoutBB :: (Num u, Ord u, FromPtSize u) + => FontSize -> CharCount -> BoundingBox u +stdLayoutBB sz len = textBounds sz zeroPt len + +-- Note - this assumes positive deltas (and a nonempty list)... +-- +-- Kern deltas are relative to the left basepoint, so they are +-- irrespective of the actual charater width. Thus to calculate +-- the bounding box Wumpus calculates the bounds of one character +-- then expands the right edge with the sum of the (rightwards) +-- displacements. +-- +hKerningBB :: (Num u, Ord u, FromPtSize u) + => FontSize -> [(u,EncodedChar)] -> BoundingBox u +hKerningBB sz xs = rightGrow (sumDiffs xs) $ textBounds sz zeroPt 1 + where + sumDiffs = foldr (\(u,_) i -> i+u) 0 + rightGrow u (BBox ll (P2 x1 y1)) = BBox ll (P2 (x1+u) y1) + + +-- Note - likewise same assumptions as horizontal version. +-- (A postive distance represents a move downwards)... +-- +-- The kern delta is the distance between baselines of successive +-- characters, so character height is irrespective when summing +-- the deltas. +-- +-- Also note, that the Label /grows/ downwards... +-- +vKerningBB :: (Num u, Ord u, FromPtSize u) + => FontSize -> [(u,EncodedChar)] -> BoundingBox u +vKerningBB sz xs = downGrow (sumDiffs xs) $ textBounds sz zeroPt 1 + where + sumDiffs = foldr (\(u,_) i -> i+u) 0 + downGrow u (BBox (P2 x0 y0) (P2 x1 y1)) = BBox (P2 x0 (y0-u)) (P2 x1 y1) -- | Ellipse bbox is the bounding rectangle, rotated as necessary diff --git a/src/Wumpus/Core/PostScriptDoc.hs b/src/Wumpus/Core/PostScriptDoc.hs --- a/src/Wumpus/Core/PostScriptDoc.hs +++ b/src/Wumpus/Core/PostScriptDoc.hs @@ -18,6 +18,7 @@ ( escapeSpecial + , escapeSpecialChar , psHeader , epsHeader @@ -88,6 +89,11 @@ where f c ss | c `elem` ps_special = '\\' : c : ss | otherwise = c : ss + +-- Note - this has to promote the Char to a String... +escapeSpecialChar :: Char -> String +escapeSpecialChar c | c `elem` ps_special = ['\\', c] + | otherwise = [c] ps_special :: [Char] ps_special = "\\()<>[]{}/%" 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 @@ -34,7 +34,9 @@ , attr_id , attr_x + , attr_xs , attr_y + , attr_ys , attr_r , attr_rx , attr_ry @@ -199,10 +201,28 @@ attr_x :: PSUnit u => u -> Doc attr_x = svgAttr "x" . dtruncFmt + +-- | @ x=\"... ... ...\" @ +-- +-- /List/ version of attr_x +-- +attr_xs :: PSUnit u => [u] -> Doc +attr_xs = svgAttr "x" . hsep . map dtruncFmt + + -- | @ y=\"...\" @ -- attr_y :: PSUnit u => u -> Doc attr_y = svgAttr "y" . dtruncFmt + + +-- | @ y=\"... ... ...\" @ +-- +-- /List/ version of attr_y +-- +attr_ys :: PSUnit u => [u] -> Doc +attr_ys = svgAttr "y" . hsep . map dtruncFmt + -- | @ r=\"...\" @ -- diff --git a/src/Wumpus/Core/TextEncoder.hs b/src/Wumpus/Core/TextEncoder.hs --- a/src/Wumpus/Core/TextEncoder.hs +++ b/src/Wumpus/Core/TextEncoder.hs @@ -17,20 +17,22 @@ -- -- > "regular ascii text &#egrave; more ascii text" -- --- i.e. character names and codes are delimited by @&#@ on the +-- i.e. character names and codes are delimited by @&\#@ on the -- left and @;@ on the right. -- --- In Wumpus strings both character names and character codes can --- be embedded - it seems conventional for PostScript to use --- names e.g.: +-- In Wumpus both character names and character codes can +-- be embedded in strings - (e.g. @ &\#egrave; or &\#232; @). -- +-- In the generated PostScript, Wumpus uses the character name, +-- e.g.: +-- -- > (myst) show /egrave glyphshow (re) show -- --- ... and SVG to use codes, e.g.: +-- The generated SVG uses the numeric code, e.g.: -- -- > mystère -- --- To accommodate both Wumpus defines a TextEncoder record which +-- To accommodate both, Wumpus defines a TextEncoder record which -- provides a two-way mapping between character codes and glyph -- names for a character set. -- 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 @@ -19,6 +19,7 @@ EncodedText(..) , TextChunk(..) + , EncodedChar(..) , textLength , lookupByCharCode @@ -36,10 +37,20 @@ newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] } deriving (Eq,Show) +-- | Wumpus supports both escaped names e.g. @egrave@ and escaped +-- (numeric decimal) character codes in the input string for a +-- TextLabel. +-- +data TextChunk = TextSpan String + | TextEscInt Int + | TextEscName GlyphName + deriving (Eq,Show) -data TextChunk = SText String - | EscInt Int - | EscStr GlyphName +-- | For KernLabels Wumpus needs a Char version of TextChunk. +-- +data EncodedChar = CharLiteral Char + | CharEscInt Int + | CharEscName GlyphName deriving (Eq,Show) @@ -49,16 +60,22 @@ format = hcat . map format . getEncodedText instance Format TextChunk where - format (SText s) = text s - format (EscInt i) = text "&#" <> int i <> semicolon - format (EscStr s) = text "&#" <> text s <> semicolon + format (TextSpan s) = text s + format (TextEscInt i) = text "&#" <> int i <> semicolon + format (TextEscName s) = text "&#" <> text s <> semicolon +instance Format EncodedChar where + format (CharLiteral c) = char c + format (CharEscInt i) = text "&#" <> int i <> semicolon + format (CharEscName s) = text "&#" <> text s <> semicolon + + -------------------------------------------------------------------------------- textLength :: EncodedText -> Int textLength = foldr add 0 . getEncodedText where - add (SText s) n = n + length s - add _ n = n + 1 + add (TextSpan s) n = n + length s + add _ n = n + 1 lookupByCharCode :: CharCode -> TextEncoder -> Maybe GlyphName @@ -68,17 +85,27 @@ lookupByGlyphName i enc = (svg_lookup enc) i --- | Output to PostScript as @ /egrave glyphshow @ - --- Output to SVG as an escaped decimal, e.g. @ è @ +-- | 'lexLabel' input is regular text and escaped glyph names or +-- decimal character codes. Escaping follows the SVG convention, +-- start with @&#@ (ampersand hash) end with @;@ (semicolon). -- +-- Special chars are output to PostScript as: +-- +-- > /egrave glyphshow +-- +-- Special chars are output to SVG as an escaped decimal, e.g.: +-- +-- > è +-- -- Note, HTML entity names do not seem to be supported in SVG, -- @ è @ does not work in FireFox or Chrome. - - +-- lexLabel :: String -> EncodedText lexLabel = EncodedText . lexer +-- Note - the lexer reads number spans with isDigit, so reads +-- decimals only. +-- lexer :: String -> [TextChunk] lexer [] = [] @@ -87,14 +114,14 @@ esc (c:cs) | isDigit c = let (s,cs') = span isDigit cs in intval (c:s) cs' | otherwise = let (s,cs') = span isAlpha cs - in EscStr (c:s) : optsemi cs' + in TextEscName (c:s) : optsemi cs' esc [] = [] optsemi (';':cs) = lexer cs -- let ill-formed go through optsemi cs = lexer cs intval [] rest = optsemi rest - intval cs rest = EscInt (read cs) : optsemi rest + intval cs rest = TextEscInt (read cs) : optsemi rest lexer (x:xs) = let (s,xs') = span (/= '&') xs - in SText (x:s) : lexer xs' + in TextSpan (x:s) : lexer xs' 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,30,0) +-- > (0,31,0) -- wumpus_core_version :: (Int,Int,Int) -wumpus_core_version = (0,30,0) +wumpus_core_version = (0,31,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 @@ -28,15 +28,18 @@ -- * Picture types Picture , DPicture - , GSUpdate + , FontCtx , Primitive , DPrimitive + , XLink , PrimPath , DPrimPath , PrimPathSegment , DPrimPathSegment , PrimLabel , DPrimLabel + , KerningChar + , DKerningChar -- * Drawing styles , PathProps 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.30.0 +version: 0.31.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -9,8 +9,6 @@ synopsis: Pure Haskell PostScript and SVG generation. description: . - Wumpus - (W)riter (M)onad (P)ost (S)cript. - . Wumpus is a kernel library for generating 2D vector pictures, its salient feature is portability due to no FFI dependencies. It can generate PostScript (EPS) files and SVG files. The @@ -21,7 +19,7 @@ Pictures in Wumpus are made from /paths/ and text /labels/. Paths themselves are made from points. The usual affine transformations (rotations, scaling, translations) can be - applied to geometric objects. Unlike PostScript there is no + applied to Pictures. Unlike PostScript there is no notion of a current point, Wumpus builds pictures in a coordinate-free style. . @@ -37,12 +35,8 @@ sophisticated (e.g. how attributes like colour are handled, and how the bounding boxes of text labels are calculated), so Wumpus might be limited compared to other systems. However, - the design permits a fairly simple implementation - which is - a priority. Text encoding an exception - I\'m not sure how - reasonable the design is. The current implementation - appears okay for Latin 1 but may be inadequate for other - character sets, so I may have to revise it significantly. - . + the design permits a fairly simple implementation, which is a + priority. . \[1\] Because the output is simple, straight-line PostScript code, it is possible to use GraphicsMagick or a similar tool @@ -51,6 +45,39 @@ . Changelog: . + 0.30.0 to 0.31.0: + . + * Extended the label type to optionally handle horizontal + or vertical \"kerning\". This can be efficiently implemented + in SVG. + . + * Major API change - the Primitive constructors defined in + @Core.PictureLanguage@ are no longer overloaded (@cstroke@, + @ostroke@, @fill@, @textlabel@, @ellipse@). The respective + classes (@Stroke@, @TextLabel@, @Ellipse@) have been removed + and the constructors now have monomorphic types. This is + because Wumpus-Core now only has one colour type and stroke + attributes are now a single type, so polymorphism became + less useful (and the simplicity of monomorphic types became + more favourable). @ellipse@ is no longer a constructor + instead there variants @fillEllipse@ and @strokeEllipse@. + . + * Added support for /bordered/ closed paths - i.e. paths that + are both stroked and filled. These can be efficiently drawn + in SVG with a single @path@ element. + . + * Changed StrokeAttr representation to be a regular data type + rather than a list of /deltas/ - i.e. differences to the + graphics state. + . + * Added SVG font attribute /delta optimizations/ to help reduce + SVG code size - via the @fontDeltaContext@ function in + @Core.Picture@. This functionality was partially inplemented + in the last release using the @GSUpdate@ datatype - this + datatype it is now called @FontCtx@. + . + * Some internal work documenting text encoding. + . 0.23.0 to 0.30.0: . * Substantial changes - the output machinery has been heavily @@ -92,29 +119,8 @@ now @boundaryCorners@, @within@ is now @withinBoundary@ and @union@ is now @boundaryUnion@. . - 0.22.0 TO 0.23.0: - . - * @Basic.GraphicsState@ - extracted the font face fields from - @FontAttr@ datatype into a separate datatype @FontFace@. - . - * Added @PtSize@ a numeric type wrapping Double. This is - specifically for text size calculations, vis the - @Core.FontSize@ module. . - * Changed all functions in @Core.FontSize@ to return @PtSize@ - instead of a polymorphic type @u@ (where @u@ is an instance - of Fractional). To get to another unit type rather than - FontSize use an explicit conversion that scales the value - accordingly. . - * Added FromPtSize class constraints to various functions in - @Core.Picture@. - . - * Added @charWidth@ to @Core.FontSize@. - . - * Added @vlength@ to @Core.Geometry@ - . - . build-type: Simple stability: unstable cabal-version: >= 1.2 @@ -126,8 +132,11 @@ demo/AffineTest02.hs, demo/AffineTest03.hs, demo/AffineTestBase.hs, - demo/FontMetrics.hs + demo/DeltaPic.hs, + demo/FontMetrics.hs, + demo/KernPic.hs, demo/LabelPic.hs, + demo/Latin1Pic.hs, demo/MultiPic.hs, demo/Rotated.hs, demo/Scaled.hs,