diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,110 @@ +0.52.0 to 0.52.1: + + * Removed internal @(<>)@ format combinator that caused + problems for GHC 7.4. + +0.51.0 to 0.52.0: + + * Added limited support for adding SVG ids to text and + Primitives. + + * Fixed types of @d2r@ and @r2d@ to Double for degrees, rather + than a parametric (Real a, Floating a) type. Although this is + less general, it removes the burden of type annotating the + common case. + + * Added the vector functions @orthoVec@, @vsum@ and @vdiff@ to + @Core.Geometry@. + + * Re-named @clip@ to @clipPrimitive@ + +0.50.0 to 0.51.0: + + * Added special cases to handle continuity to the function + @lineDirection@ in @Core.Geometry@. + + * Added @zeroVec@ to @Core.Geometry@. + + * Extended some Haddock documentation. + +0.43.0 to 0.50.0: + + * Major change hence the version number jump - the notion of + parametric unit has been removed from the @Picture@ objects + (it for remains the @Geometric@ objects @Point2@, @Vec2@ etc.). + Certain useful units, e.g. @em@ and @en@, are contextual on + the \"current point size\", and having a parametric unit here + was actually a hinderance to supporting units properly in + higher-level layers. Now all Picture objects (those defined + or exported from @Core.Picture@) are fixed to use Double + - representing PostScript points. Higher level layers that + intend to support alternative units must translate drawing + objects to PostScript point measurements /before/ calling the + Picture API. Geometric objects - objects defined in + @Core.Geometry@, e.g. @Point2@, @Vec2@ - are still polymorphic + on unit. + + * Picture API change - Various function names changed. + @lineTo@ becomes @absLineTo@ and @curveTo@ becomes + @absCurveTo@. The path builders are qualified with /Prim/, + @vertexPath@ becomes @vertexPrimPath@, @vectorPath@ becomes + @vectorPrimPath@, @emptyPath@ becomes @emptyPrimPath@ and + @curvedPath@ becomes @curvedPrimPath@. @xlink@ becomes + @xlinkPrim@. + + * API change - @PtSize@ data type replaced by @AfmUnit@ for font + measurements. + + * API and representation change - clipping paths are represented + as @Primitive@ constructor rather than a @Picture@ constructor. + This should make them more useful. The type of the function + @clip@ in @Core.Picture@ has likewise changed. + + * Picture API change - changed @primPath@ to @absPrimPath@, added + the functions @relPrimPath@, @relLineTo@, @relCurveTo@. + + * Added the class @Tolerance@ to @Core.Geometry@ and made the Eq + instances of @Point2@, @Vec2@ and @BoundingBox@ tolerant. + Tolerance accounts for a fairly lax equality on floating point + numbers - it is suitable for Wumpus (printing) where high + accuracy is needed. + +0.42.1 to 0.43.0: + + * API change - the function @bezierCircle@ in @Core.Geometry@ + has changed. It now implements a better method of drawing + circles with Bezier curves and no longer needs the + subvision factor. The old circle drawing function has been + retained as @subdivisionCircle@ as it is useful for + corroborating @bezierCircle@, but the general use of + @subdivisionCircle@ should be avoided. + + * Added a function @bezierEllipse@ to @Core.Geometry@. + +0.42.0 to 0.42.1: + + * Fixed bug in the @curvedPath@ function in @Core.Picture@ + where the wrong relative point was being calculated for the + second control point. + + * Changed internals of the @EscapedText@ type so it supports + efficient concatenation, and now has a Monoid instance. + +0.41.0 to 0.42.0: + + * Removed the function @oboundingBox@ from @Core.BoundingBox@. + It was unused in Wumpus-Core and had unwise error handling + baked-in. + + * Renamed @direction@ in @Wumpus.Core.Geometry@, it is now + @vdirection@. + + * Fixed internal Foldable instances for JoinList. The left and + right folds worked in the wrong direction. + + * Some improvements to the Haddock documentation. + 0.40.0 to 0.41.0: * Changed PostScript output to use pre-defined procedures for diff --git a/demo/AffineTest01.hs b/demo/AffineTest01.hs --- a/demo/AffineTest01.hs +++ b/demo/AffineTest01.hs @@ -17,10 +17,10 @@ [ circle_cpa, ellipse_cpa, path_cpa ] -rot30 :: (Rotate t, Fractional u, u ~ DUnit t) => t -> t +rot30 :: Rotate t => t -> t rot30 = rotate30 -rot30P :: (Real u, Floating u) => Primitive u -> Primitive u +rot30P :: Primitive -> Primitive rot30P = rotate30 -- Primitive - Text diff --git a/demo/AffineTest02.hs b/demo/AffineTest02.hs --- a/demo/AffineTest02.hs +++ b/demo/AffineTest02.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -16,11 +15,11 @@ [ circle_cpa, ellipse_cpa, path_cpa ] -scale_onehalf_x_two :: (Scale t, Fractional u, u ~ DUnit t) => t -> t +scale_onehalf_x_two :: Scale t => t -> t scale_onehalf_x_two = scale 1.5 2.0 -scale_onehalf_x_twoP :: Fractional u => Primitive u -> Primitive u +scale_onehalf_x_twoP :: Primitive -> Primitive scale_onehalf_x_twoP = scale 1.5 2.0 -- Primitive - Text diff --git a/demo/AffineTest03.hs b/demo/AffineTest03.hs --- a/demo/AffineTest03.hs +++ b/demo/AffineTest03.hs @@ -16,10 +16,10 @@ [ circle_cpa, ellipse_cpa, path_cpa ] -translate_20x40 :: (Translate t, Fractional u, u ~ DUnit t) => t -> t +translate_20x40 :: (Fractional u, Translate t, u ~ DUnit t) => t -> t translate_20x40 = translate 20.0 40.0 -translate_20x40P :: Fractional u => Primitive u -> Primitive u +translate_20x40P :: Primitive -> Primitive translate_20x40P = translate 20.0 40.0 -- Primitive - Text diff --git a/demo/AffineTestBase.hs b/demo/AffineTestBase.hs --- a/demo/AffineTestBase.hs +++ b/demo/AffineTestBase.hs @@ -39,9 +39,9 @@ { ata_console_msg :: String , ata_eps_file :: FilePath , ata_svg_file :: FilePath - , ata_prim_constructor :: RGBi -> DPrimitive - , ata_pic_transformer :: DPicture -> DPicture - , ata_prim_transformer :: DPrimitive -> DPrimitive + , ata_prim_constructor :: RGBi -> Primitive + , ata_pic_transformer :: Picture -> Picture + , ata_prim_transformer :: Primitive -> Primitive } runATA :: AffineTrafoAlg -> IO () @@ -56,23 +56,23 @@ (ata_prim_transformer ata) -buildPictureATA :: (RGBi -> DPrimitive) - -> (DPicture -> DPicture) - -> (DPrimitive -> DPrimitive) - -> DPicture +buildPictureATA :: (RGBi -> Primitive) + -> (Picture -> Picture) + -> (Primitive -> Primitive) + -> Picture buildPictureATA mk picF primF = picture1 `picBeside` picture2 `picBeside` picture3 where - picture1 :: DPicture + picture1 :: Picture picture1 = illustrateBounds light_blue $ frame [mk black] - picture2 :: DPicture + picture2 :: Picture picture2 = illustrateBounds light_blue $ picF $ frame [mk blue] - picture3 :: DPicture + picture3 :: Picture picture3 = illustrateBoundsPrim light_blue prim where - prim :: DPrimitive + prim :: Primitive prim = primF $ mk red @@ -85,8 +85,8 @@ { cpa_console_msg :: String , cpa_eps_file :: FilePath , cpa_svg_file :: FilePath - , cpa_prim_constructor :: RGBi -> DPrimitive - , cpa_prim_transformer :: DPrimitive -> DPrimitive + , cpa_prim_constructor :: RGBi -> Primitive + , cpa_prim_transformer :: Primitive -> Primitive } runCPA :: ControlPointAlg -> IO () @@ -98,41 +98,42 @@ where pic = cpPicture (cpa_prim_constructor cpa) (cpa_prim_transformer cpa) -cpPicture :: (RGBi -> DPrimitive) -> (DPrimitive -> DPrimitive) -> DPicture +cpPicture :: (RGBi -> Primitive) -> (Primitive -> Primitive) -> Picture cpPicture constr trafo = illustrateBounds light_blue $ illustrateControlPoints black $ transformed_prim where - transformed_prim :: DPrimitive + transformed_prim :: Primitive transformed_prim = trafo $ constr red -------------------------------------------------------------------------------- -rgbLabel :: RGBi -> DPrimitive +rgbLabel :: RGBi -> Primitive rgbLabel rgb = textlabel rgb wumpus_default_font "Wumpus!" zeroPt -rgbCircle :: RGBi -> DPrimitive +rgbCircle :: RGBi -> Primitive rgbCircle rgb = fillEllipse rgb 60 60 zeroPt -rgbEllipse :: RGBi -> DPrimitive +rgbEllipse :: RGBi -> Primitive rgbEllipse rgb = fillEllipse rgb 60 30 zeroPt -rgbPath :: RGBi -> DPrimitive +rgbPath :: RGBi -> Primitive rgbPath rgb = ostroke rgb default_stroke_attr $ dog_kennel -------------------------------------------------------------------------------- -- Demo - draw a dog kennel... -dog_kennel :: DPrimPath -dog_kennel = primPath zeroPt [ lineTo (P2 0 60) - , lineTo (P2 40 100) - , lineTo (P2 80 60) - , lineTo (P2 80 0) - , lineTo (P2 60 0) - , lineTo (P2 60 30) - , curveTo (P2 60 50) (P2 50 60) (P2 40 60) - , curveTo (P2 30 60) (P2 20 50) (P2 20 30) - , lineTo (P2 20 0) - ] +dog_kennel :: PrimPath +dog_kennel = absPrimPath zeroPt $ + [ absLineTo (P2 0 60) + , absLineTo (P2 40 100) + , absLineTo (P2 80 60) + , absLineTo (P2 80 0) + , absLineTo (P2 60 0) + , absLineTo (P2 60 30) + , absCurveTo (P2 60 50) (P2 50 60) (P2 40 60) + , absCurveTo (P2 30 60) (P2 20 50) (P2 20 30) + , absLineTo (P2 20 0) + ] diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs new file mode 100644 --- /dev/null +++ b/demo/ClipPic.hs @@ -0,0 +1,49 @@ +{-# OPTIONS -Wall #-} + +module ClipPic where + +import Wumpus.Core +import Wumpus.Core.Colour + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out" + writeEPS "./out/clip_path01.eps" pic1 + writeSVG "./out/clip_path01.svg" pic1 + + + + + +pic1 :: Picture +pic1 = frame [ body ] + where + body = clipPrim dog_house $ + primGroup [ red_circle, green_circle, blue_circle ] + +red_circle :: Primitive +red_circle = fillEllipse red 60 60 $ P2 (-20) 0 + +green_circle :: Primitive +green_circle = fillEllipse green 60 60 $ P2 30 80 + +blue_circle :: Primitive +blue_circle = fillEllipse blue 60 60 $ P2 80 0 + + +dog_house :: PrimPath +dog_house = absPrimPath zeroPt $ + [ absLineTo (P2 0 60) + , absLineTo (P2 40 100) + , absLineTo (P2 80 60) + , absLineTo (P2 80 0) + , absLineTo (P2 60 0) + , absLineTo (P2 60 30) + , absCurveTo (P2 60 50) (P2 50 60) (P2 40 60) + , absCurveTo (P2 30 60) (P2 20 50) (P2 20 30) + , absLineTo (P2 20 0) + ] + + diff --git a/demo/DeltaPic.hs b/demo/DeltaPic.hs --- a/demo/DeltaPic.hs +++ b/demo/DeltaPic.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -- SVG ouptut has some ability to minimization font change code. @@ -19,7 +18,6 @@ - main :: IO () main = do createDirectoryIfMissing True "./out/" @@ -27,7 +25,7 @@ writeSVG "./out/delta_pic01.svg" pic1 -pic1 :: DPicture +pic1 :: Picture pic1 = frame1 $ fontDeltaContext delta_ctx $ primGroup [ helveticaLabel 18 "Optimized - size and face" (P2 0 60) , helveticaLabel 14 "Optimized - face only" (P2 0 40) @@ -44,10 +42,10 @@ -- Note - each label is fully attributed with the font style. -- There really is not attribute inheritance. -- -helveticaLabel :: Int -> String -> DPoint2 -> DPrimitive +helveticaLabel :: Int -> String -> DPoint2 -> Primitive helveticaLabel sz ss pt = textlabel peru attrs ss pt where attrs = FontAttr sz common_ff -courierLabel :: String -> DPoint2 -> DPrimitive +courierLabel :: String -> DPoint2 -> Primitive courierLabel ss pt = textlabel black wumpus_default_font ss pt diff --git a/demo/EllipsePic.hs b/demo/EllipsePic.hs new file mode 100644 --- /dev/null +++ b/demo/EllipsePic.hs @@ -0,0 +1,38 @@ +{-# OPTIONS -Wall #-} + +module EllipsePic where + +import Wumpus.Core +import Wumpus.Core.Colour + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out" + writeEPS "./out/ellipse01.eps" pic1 + writeSVG "./out/ellipse01.svg" pic1 + + +pic1 :: Picture +pic1 = frame [ ellipse01 $ P2 50 50 + , ellipse02 $ P2 100 50 + , ellipse03 $ P2 150 50 + ] + + +ellipse01 :: DPoint2 -> Primitive +ellipse01 pt = cstroke black default_stroke_attr $ + curvedPrimPath $ bezierEllipse 20 30 pt + + +ellipse02 :: DPoint2 -> Primitive +ellipse02 pt = cstroke red default_stroke_attr $ + curvedPrimPath $ rbezierEllipse 20 30 0 pt + + + +ellipse03 :: DPoint2 -> Primitive +ellipse03 pt = cstroke red default_stroke_attr $ + curvedPrimPath $ rbezierEllipse 20 30 (negate $ d2r 10) pt + diff --git a/demo/FontMetrics.hs b/demo/FontMetrics.hs --- a/demo/FontMetrics.hs +++ b/demo/FontMetrics.hs @@ -32,10 +32,10 @@ courier_attr = FontAttr 48 (FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding) -metrics_pic :: DPicture +metrics_pic :: Picture metrics_pic = char_pic `picOver` lines_pic -lines_pic :: DPicture +lines_pic :: Picture lines_pic = frame $ [ ascender_line, cap_line, xheight_line, baseline, descender_line ] where @@ -47,20 +47,20 @@ -char_pic :: Picture Double +char_pic :: Picture char_pic = frame $ zipWith ($) chars (iterate (.+^ hvec 32) zeroPt) where chars = map letter "ABXabdgjxy12" -letter :: Char -> DPoint2 -> DPrimitive +letter :: Char -> DPoint2 -> Primitive letter ch pt = textlabel black courier_attr [ch] pt -haxis :: RGBi -> PtSize -> DPrimitive +haxis :: RGBi -> Double -> Primitive haxis rgb ypos = - ostroke rgb dash_attr $ vertexPath [ pt, pt .+^ hvec 440 ] + ostroke rgb dash_attr $ vertexPrimPath [ pt, pt .+^ hvec 440 ] where dash_attr = default_stroke_attr { dash_pattern = Dash 0 [(2,2)] } - pt = P2 0 (fromPtSize ypos) + pt = P2 0 ypos diff --git a/demo/Hyperlink.hs b/demo/Hyperlink.hs --- a/demo/Hyperlink.hs +++ b/demo/Hyperlink.hs @@ -11,11 +11,13 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - writeEPS "./out/svg_link01.eps" link_pic - writeSVG "./out/svg_link01.svg" link_pic + writeEPS "./out/hyperlink01.eps" link_pic + writeSVG "./out/hyperlink01.svg" link_pic -link_pic :: DPicture -link_pic = frame [ xlink xref $ ztextlabel "www.haskell.org" zeroPt ] +link_pic :: Picture +link_pic = frame [ xlinkPrim xref $ ztextlabel "www.haskell.org" zeroPt ] where xref = xlinkhref "http://www.haskell.org" + + diff --git a/demo/KernPic.hs b/demo/KernPic.hs --- a/demo/KernPic.hs +++ b/demo/KernPic.hs @@ -21,25 +21,26 @@ , "recommended for SVG." ] -kern_pic :: DPicture +kern_pic :: Picture kern_pic = pic1 `picOver` pic2 `picOver` pic3 -pic1 :: DPicture +pic1 :: Picture pic1 = frame [ helveticaLabelH universal (P2 0 50) , helveticaLabelH universal (P2 0 25) ] -pic2 :: DPicture +pic2 :: Picture pic2 = illustrateBoundsPrim blue_violet $ helveticaLabelV universal (P2 200 180) -pic3 :: DPicture +pic3 :: Picture pic3 = frame [ symbolLabelH uUpsilon (P2 0 0) ] + -- Some attention is paid to kerning - note that the kern between -- @i@ and @v@ is smaller than the norm. -- -universal ::[DKerningChar] +universal ::[KerningChar] universal = [ kernchar 0 'u' , kernchar 15 'n' , kernchar 15 'i' @@ -57,16 +58,16 @@ -- -- 0o241 is upper-case upsilon in the Symbol encoding vector. -- -uUpsilon :: [ DKerningChar ] +uUpsilon :: [KerningChar] uUpsilon = [ kernEscInt 6 0o241, kernchar 12 'a', kernchar 12 'b' ] -helveticaLabelH :: [KerningChar Double] -> DPoint2 -> DPrimitive +helveticaLabelH :: [KerningChar] -> DPoint2 -> Primitive helveticaLabelH xs pt = hkernlabel black helvetica18 xs pt -helveticaLabelV :: [KerningChar Double] -> DPoint2 -> DPrimitive +helveticaLabelV :: [KerningChar] -> DPoint2 -> Primitive helveticaLabelV xs pt = vkernlabel black helvetica18 xs pt -symbolLabelH :: [KerningChar Double] -> DPoint2 -> DPrimitive +symbolLabelH :: [KerningChar] -> DPoint2 -> Primitive symbolLabelH xs pt = hkernlabel black symbol18 xs pt diff --git a/demo/LabelPic.hs b/demo/LabelPic.hs --- a/demo/LabelPic.hs +++ b/demo/LabelPic.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} module LabelPic where @@ -55,13 +54,13 @@ -bigA, bigB, bigT :: Picture Double +bigA, bigB, bigT :: Picture bigA = bigLetter black 'A' bigB = bigLetter peru 'B' bigT = bigLetter plum 'T' -bigLetter :: RGBi -> Char -> Picture Double -bigLetter rgb ch = uniformScale 5 $ frame [textlabel rgb attrs [ch] zeroPt] +bigLetter :: RGBi -> Char -> Picture +bigLetter rgb ch = scale 5 5 $ frame [textlabel rgb attrs [ch] zeroPt] where attrs = FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding) @@ -73,7 +72,7 @@ writeEPS "./out/label05.eps" p1 writeSVG "./out/label05.svg" p1 where - p1 = uniformScale 10 $ bigA `picOver` bigB `picOver` bigT + p1 = scale 10 10 $ bigA `picOver` bigB `picOver` bigT @@ -85,7 +84,7 @@ p1 = pA `picBeside` pB `picBeside` pC `picBeside` pA pA = drawBounds bigA - pB = drawBounds $ uniformScale 2 bigB + pB = drawBounds $ scale 2 2 bigB pC = drawBounds $ picMoveBy `flip` (vec 0 10) $ bigLetter peru 'C' @@ -97,7 +96,7 @@ p1 = pA `picBeside` pB `picBeside` pC pA = drawBounds bigA - pB = drawBounds $ uniformScale 2 bigB + pB = drawBounds $ scale 2 2 bigB pC = drawBounds $ picMoveBy `flip` (vec 0 10) $ bigLetter peru 'C' @@ -107,15 +106,15 @@ -drawBounds :: (Floating u, Real u, FromPtSize u) => Picture u -> Picture u +drawBounds :: Picture -> Picture drawBounds p = p `picOver` (frame [zcstroke ph]) where - ph = vertexPath $ [bl,br,tr,tl] + ph = vertexPrimPath $ [bl,br,tr,tl] (bl,br,tr,tl) = boundaryCorners $ boundary p -- | The center of a picture. -center :: (Boundary a, Fractional u, DUnit a ~ u) => a -> Point2 u +center :: Picture -> DPoint2 center a = P2 hcenter vcenter where BBox (P2 x0 y0) (P2 x1 y1) = boundary a @@ -135,7 +134,7 @@ -lbl1 :: Picture Double +lbl1 :: Picture lbl1 = line1 `picBeside` line2 where line1 = frame [textlabel peru attrs "Hello" zeroPt] line2 = frame [textlabel peru attrs "World" zeroPt] diff --git a/demo/Latin1Pic.hs b/demo/Latin1Pic.hs --- a/demo/Latin1Pic.hs +++ b/demo/Latin1Pic.hs @@ -43,7 +43,7 @@ -- -- Note - 0xE8 corresponds to Lslash in the standard encoding. -- -pic1 :: DPicture +pic1 :: Picture pic1 = frame [ helveticaLabel "mystère" (P2 0 60) , helveticaLabel "mystère" (P2 0 40) -- no HASH! , helveticaLabel "myst�o350;re" (P2 0 20) @@ -53,7 +53,7 @@ -helveticaLabel :: String -> DPoint2 -> DPrimitive +helveticaLabel :: String -> DPoint2 -> Primitive helveticaLabel ss pt = textlabel black helvetica18 ss pt helvetica18 :: FontAttr diff --git a/demo/MultiPic.hs b/demo/MultiPic.hs --- a/demo/MultiPic.hs +++ b/demo/MultiPic.hs @@ -17,17 +17,17 @@ -pic1 :: DPicture -pic1 = uniformScale 2 $ frame $ - [ fillEllipse blue 10 10 zeroPt - , fillEllipse red 10 10 (P2 40 40) - , ztextlabel "Wumpus!" (P2 40 20) - , square red 5 (P2 50 10) +pic1 :: Picture +pic1 = scale 2 2 $ frame $ + [ fillEllipse blue 10 10 zeroPt + , fillEllipse red 10 10 (P2 40 40) + , ztextlabel "Wumpus!" (P2 40 20) + , square red 5 (P2 50 10) ] -square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> Primitive u -square rgb sidelen bl = fill rgb $ vertexPath $ +square :: RGBi -> Double -> DPoint2 -> Primitive +square rgb sidelen bl = fill rgb $ vertexPrimPath $ [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen] -- The PostScript generated from this is pretty good. diff --git a/demo/TextBBox.hs b/demo/TextBBox.hs --- a/demo/TextBBox.hs +++ b/demo/TextBBox.hs @@ -31,7 +31,7 @@ SVG_REGULAR standard_encoding) -words_pic :: DPicture +words_pic :: Picture words_pic = frame $ [ line1, line2, line3, char1, char2 ] where @@ -42,16 +42,15 @@ char2 = boundedCourier "2" (P2 29 0) -boundedCourier :: String -> DPoint2 -> DPrimitive +boundedCourier :: String -> DPoint2 -> Primitive boundedCourier = boundedText courier -boundedText :: (Num u, Ord u, FromPtSize u) - => FontAttr -> String -> Point2 u -> Primitive u +boundedText :: FontAttr -> String -> DPoint2 -> Primitive boundedText fa@(FontAttr sz _) ss pt = primCat bbox text where - esc_text = escapeString ss - bbox_path = vertexPath $ boundaryCornerList $ textBoundsEsc sz pt esc_text - bbox = cstroke peru default_stroke_attr bbox_path - text = escapedlabel black fa esc_text pt + esc_txt = escapeString ss + bb_path = vertexPrimPath $ boundaryCornerList $ textBoundsEsc sz pt esc_txt + bbox = cstroke peru default_stroke_attr bb_path + text = escapedlabel black fa esc_txt pt diff --git a/demo/TransformEllipse.hs b/demo/TransformEllipse.hs --- a/demo/TransformEllipse.hs +++ b/demo/TransformEllipse.hs @@ -28,7 +28,7 @@ gray :: RGBi gray = RGBi 127 127 127 -pic1 :: Picture Double +pic1 :: Picture pic1 = cb `picOver` ell `picOver` xy_frame "no transform" where ell = mkRedEllipse id 20 10 pt @@ -36,32 +36,32 @@ pt = P2 70 10 -pic2 :: Picture Double +pic2 :: Picture pic2 = cb `picOver` ell `picOver` xy_frame "rotate 30deg" where ell = mkRedEllipse (rotate ang) 20 10 pt cb = rotate ang $ crossbar 20 10 pt pt = P2 70 10 - ang = d2r (30::Double) + ang = d2r 30 -pic3 :: Picture Double +pic3 :: Picture pic3 = cb `picOver` ell `picOver` xy_frame "rotateAbout (60,0) 30deg" where ell = mkRedEllipse (rotateAbout ang pto) 20 10 pt cb = rotateAbout ang pto $ crossbar 20 10 pt pt = P2 70 10 - pto = P2 60 0 - ang = d2r (30::Double) + pto = P2 60 0 `asTypeOf` dpt + ang = d2r 30 -pic4 :: Picture Double +pic4 :: Picture pic4 = cb `picOver` ell `picOver` xy_frame "scale 1 2" where ell = mkRedEllipse (scale 1 2) 20 10 pt cb = scale 1 2 $ crossbar 20 10 pt pt = P2 70 10 -pic5 :: Picture Double +pic5 :: Picture pic5 = cb `picOver` ell `picOver` xy_frame "translate -70 -10" where ell = mkRedEllipse (translate (-70) (-10)) 20 10 pt @@ -69,25 +69,23 @@ pt = P2 70 10 -mkRedEllipse :: (Real u, Floating u, FromPtSize u) - => (Primitive u -> Primitive u) - -> u -> u -> Point2 u -> Picture u +mkRedEllipse ::(Primitive -> Primitive) + -> Double -> Double -> DPoint2 -> Picture mkRedEllipse trafo rx ry pt = illustrateControlPoints gray $ trafo $ fillEllipse red rx ry pt -crossbar :: (Real u, Floating u, FromPtSize u) - => u -> u -> Point2 u -> Picture u +crossbar :: Double -> Double -> DPoint2 -> Picture crossbar rx ry ctr = - frame [ostroke black default_stroke_attr $ primPath west ps] + frame [ostroke black default_stroke_attr $ absPrimPath west ps] where - ps = [ lineTo east, lineTo ctr, lineTo north, lineTo south ] + ps = [ absLineTo east, absLineTo ctr, absLineTo north, absLineTo south ] north = ctr .+^ vvec ry south = ctr .-^ vvec ry east = ctr .+^ hvec rx west = ctr .-^ hvec rx -xy_frame :: (Real u, Floating u, FromPtSize u) => String -> Picture u +xy_frame :: String -> Picture xy_frame ss = frame [ mkline (P2 (-4) 0) (P2 150 0) , mkline (P2 0 (-4)) (P2 0 150) @@ -95,4 +93,8 @@ ] where - mkline p1 p2 = ostroke black default_stroke_attr $ primPath p1 [lineTo p2] + mkline p1 p2 = ostroke black default_stroke_attr $ + absPrimPath p1 [absLineTo p2] + +dpt :: DPoint2 +dpt = zeroPt diff --git a/demo/TransformPath.hs b/demo/TransformPath.hs --- a/demo/TransformPath.hs +++ b/demo/TransformPath.hs @@ -26,7 +26,7 @@ -pic1 :: Picture Double +pic1 :: Picture pic1 = pth `picOver` ch `picOver` xy_frame "no transform" where pth = mkBlackPath id pt @@ -34,33 +34,33 @@ pt = P2 70 10 -pic2 :: Picture Double +pic2 :: Picture pic2 = pth `picOver` ch `picOver` xy_frame "rotate 30deg" where pth = mkBlackPath (rotate ang) pt ch = rotate ang $ zcrosshair pt pt = P2 70 10 - ang = d2r (30::Double) + ang = d2r 30 -pic3 :: Picture Double +pic3 :: Picture pic3 = pth `picOver` ch `picOver` xy_frame "rotateAbout (60,0) 30deg" where pth = mkBlackPath (rotateAbout ang pto) pt ch = rotateAbout ang pto $ zcrosshair pt pt = P2 70 10 - pto = P2 60 0 - ang = d2r (30::Double) + pto = P2 60 0 `asTypeOf` dpt + ang = d2r 30 -pic4 :: Picture Double +pic4 :: Picture pic4 = pth `picOver` ch `picOver` xy_frame "scale 1 2" where pth = mkBlackPath (scale 1 2) pt ch = scale 1 2 $ zcrosshair pt pt = P2 70 10 -pic5 :: Picture Double +pic5 :: Picture pic5 = pth `picOver` ch `picOver` xy_frame "translate -70 -10" where pth = mkBlackPath (translate (-70) (-10)) pt @@ -68,13 +68,11 @@ pt = P2 70 10 -mkBlackPath :: (Real u, Floating u, FromPtSize u) - => (Primitive u -> Primitive u) - -> Point2 u -> Picture u +mkBlackPath :: (Primitive -> Primitive) -> DPoint2 -> Picture mkBlackPath trafo bl = - frame [ trafo $ ostroke black custom_stroke_attr $ primPath bl ps] + frame [ trafo $ ostroke black custom_stroke_attr $ absPrimPath bl ps] where - ps = [lineTo p1, lineTo p2, lineTo p3] + ps = [absLineTo p1, absLineTo p2, absLineTo p3] p1 = bl .+^ vec 25 12 p2 = p1 .+^ vec 6 (-12) p3 = p2 .+^ vec 25 12 @@ -84,15 +82,14 @@ custom_stroke_attr :: StrokeAttr custom_stroke_attr = default_stroke_attr { line_width = 2 } -zcrosshair :: (Real u, Floating u, FromPtSize u) => Point2 u -> Picture u +zcrosshair :: DPoint2 -> Picture zcrosshair = crosshair 56 12 -crosshair :: (Real u, Floating u, FromPtSize u) - => u -> u -> Point2 u -> Picture u +crosshair :: Double -> Double -> DPoint2 -> Picture crosshair w h bl = - frame [ostroke burlywood default_stroke_attr $ primPath bl ps] + frame [ostroke burlywood default_stroke_attr $ absPrimPath bl ps] where - ps = [ lineTo tr, lineTo br, lineTo tl, lineTo bl ] + ps = [ absLineTo tr, absLineTo br, absLineTo tl, absLineTo bl ] tl = bl .+^ vvec h tr = bl .+^ vec w h br = bl .+^ hvec w @@ -100,7 +97,7 @@ burlywood :: RGBi burlywood = RGBi 222 184 135 -xy_frame :: (Real u, Floating u, FromPtSize u) => String -> Picture u +xy_frame :: String -> Picture xy_frame ss = frame [ mkline (P2 (-4) 0) (P2 150 0) , mkline (P2 0 (-4)) (P2 0 150) @@ -108,4 +105,9 @@ ] where - mkline p1 p2 = ostroke black default_stroke_attr $ primPath p1 [lineTo p2] + mkline p1 p2 = ostroke black default_stroke_attr $ + absPrimPath p1 [absLineTo p2] + + +dpt :: DPoint2 +dpt = zeroPt diff --git a/demo/TransformTextlabel.hs b/demo/TransformTextlabel.hs --- a/demo/TransformTextlabel.hs +++ b/demo/TransformTextlabel.hs @@ -26,63 +26,60 @@ -pic1 :: Picture Double +pic1 :: Picture pic1 = txt `picOver` ch `picOver` xy_frame "no transform" where - txt = mkBlackTextlabel id pt - ch = zcrosshair pt - pt = P2 70 10 + txt = mkBlackTextlabel id pt + ch = zcrosshair pt + pt = P2 70 10 -pic2 :: Picture Double +pic2 :: Picture pic2 = txt `picOver` ch `picOver` xy_frame "rotate 30deg" where - txt = mkBlackTextlabel (rotate ang) pt - ch = rotate ang $ zcrosshair pt - pt = P2 70 10 - ang = d2r (30::Double) + txt = mkBlackTextlabel (rotate ang) pt + ch = rotate ang $ zcrosshair pt + pt = P2 70 10 + ang = d2r 30 -pic3 :: Picture Double +pic3 :: Picture pic3 = txt `picOver` ch `picOver` xy_frame "rotateAbout (60,0) 30deg" where - txt = mkBlackTextlabel (rotateAbout ang pto) pt - ch = rotateAbout ang pto $ zcrosshair pt - pt = P2 70 10 - pto = P2 60 0 - ang = d2r (30::Double) + txt = mkBlackTextlabel (rotateAbout ang pto) pt + ch = rotateAbout ang pto $ zcrosshair pt + pt = P2 70 10 + pto = P2 60 0 `asTypeOf` dpt + ang = d2r 30 -pic4 :: Picture Double +pic4 :: Picture pic4 = txt `picOver` ch `picOver` xy_frame "scale 1 2" where - txt = mkBlackTextlabel (scale 1 2) pt - ch = scale 1 2 $ zcrosshair pt - pt = P2 70 10 + txt = mkBlackTextlabel (scale 1 2) pt + ch = scale 1 2 $ zcrosshair pt + pt = P2 70 10 -pic5 :: Picture Double +pic5 :: Picture pic5 = txt `picOver` ch `picOver` xy_frame "translate -70 -10" where - txt = mkBlackTextlabel (translate (-70) (-10)) pt - ch = translate (-70) (-10) $ zcrosshair pt - pt = P2 70 10 + txt = mkBlackTextlabel (translate (-70) (-10)) pt + ch = translate (-70) (-10) $ zcrosshair pt + pt = P2 70 10 -mkBlackTextlabel :: (Real u, Floating u, FromPtSize u) - => (Primitive u -> Primitive u) - -> Point2 u -> Picture u +mkBlackTextlabel :: (Primitive -> Primitive) -> DPoint2 -> Picture mkBlackTextlabel trafo bl = frame [ trafo $ textlabel black wumpus_default_font "rhubarb" bl ] -zcrosshair :: (Real u, Floating u, FromPtSize u) => Point2 u -> Picture u +zcrosshair :: DPoint2 -> Picture zcrosshair = crosshair 56 12 -crosshair :: (Real u, Floating u, FromPtSize u) - => u -> u -> Point2 u -> Picture u +crosshair :: Double -> Double -> DPoint2 -> Picture crosshair w h bl = - frame [ostroke burlywood default_stroke_attr $ primPath bl ps] + frame [ostroke burlywood default_stroke_attr $ absPrimPath bl ps] where - ps = [ lineTo tr, lineTo br, lineTo tl, lineTo bl ] + ps = [ absLineTo tr, absLineTo br, absLineTo tl, absLineTo bl ] tl = bl .+^ vvec h tr = bl .+^ vec w h br = bl .+^ hvec w @@ -90,7 +87,7 @@ burlywood :: RGBi burlywood = RGBi 222 184 135 -xy_frame :: (Real u, Floating u, FromPtSize u) => String -> Picture u +xy_frame :: String -> Picture xy_frame ss = frame [ mkline (P2 (-4) 0) (P2 150 0) , mkline (P2 0 (-4)) (P2 0 150) @@ -98,4 +95,8 @@ ] where - mkline p1 p2 = ostroke black default_stroke_attr $ primPath p1 [lineTo p2] + mkline p1 p2 = ostroke black default_stroke_attr $ + absPrimPath p1 [absLineTo p2] + +dpt :: DPoint2 +dpt = zeroPt diff --git a/demo/ZOrderPic.hs b/demo/ZOrderPic.hs --- a/demo/ZOrderPic.hs +++ b/demo/ZOrderPic.hs @@ -29,16 +29,16 @@ , "" ] -combined_pic :: DPicture +combined_pic :: Picture combined_pic = multi [pic1,pic2] -pic1 :: DPicture +pic1 :: Picture pic1 = frame $ prim_list zeroPt -pic2 :: DPicture +pic2 :: Picture pic2 = multi $ map (\a -> frame [a]) $ prim_list (P2 200 0) -prim_list :: DPoint2 -> [DPrimitive] +prim_list :: DPoint2 -> [Primitive] 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 @@ -23,19 +23,20 @@ \section{About \wumpuscore} %----------------------------------------------------------------- -This guide was last updated for \wumpuscore version 0.41.0. +This guide was last updated for \wumpuscore version 0.50.0. -\wumpuscore is a Haskell library for generating 2D vector -pictures. It was written with portability as a priority, so it has +\wumpuscore is a Haskell library for generating static 2D vector +pictures. It is written with portability as a priority, so it has no dependencies on foreign C libraries. Output to PostScript and SVG (Scalable Vector Graphics) is supported. \wumpuscore is rather primitive, the basic drawing objects are paths and text labels. A two additional libraries -\texttt{wumpus-basic} and \texttt{wumpus-drawing} contain code for -higher level drawing but they are experimental and the APIs they -present are a long way from stable (they should probably be -considered a \emph{technology preview}). +\texttt{wumpus-basic} and \texttt{wumpus-drawing} build on +\wumpuscore adding significant capabilities but they are +experimental and the APIs they present are unfortunately a long +way from stable - currently they should be considered a +\emph{technology preview} not ready for general use. Although \wumpuscore is heavily inspired by PostScript it avoids PostScript's notion of an (implicit) current point and the @@ -55,7 +56,7 @@ Some internal data types are also exported as opaque signatures - the implementation is hidden, but the type name is exposed so it can be used in the type signatures of \emph{userland} functions. -Typically, where these data types need to be \emph{instantiated} +Typically, where these data types need to be \emph{instantiated}, smart constructors are provided. \item[\texttt{Wumpus.Core.AffineTrans.}] @@ -76,22 +77,22 @@ is (255, 255, 255). Some named colours are defined, although they are hidden by the top level shim module to avoid name clashes with libraries providing more extensive lists of colours. -\texttt{Wumpus.Core.Colour} can be imported directly if a simple -list of named colours is required. +\texttt{Wumpus.Core.Colour} can be imported directly if its +elementary set of named colours is required. \item[\texttt{Wumpus.Core.FontSize.}] -Various calculations for font size metrics. \wumpuscore has only -approximate handling of font / character size as it does not -interpret the metrics within font files (doing so is a -substantially task attempted by \texttt{Wumpus.Basic} but -currently only for the simple and out-dated \texttt{AFM} font -format). Instead, \wumpuscore makes do with operations based on -measurements derived from the Courier mono-spaced font. Generally -using metrics from a mono-spaced font over-estimates for -proportional fonts, though in practice this is tolerable. +Various calculations for font size measurements. \wumpuscore has +only approximate handling of font / character size as it does not +interpret the metrics within font files (doing so is a substantial +task handled by \texttt{Wumpus.Basic} for the simple \texttt{AFM} +font format). Instead, \wumpuscore makes do with operations based +on measurements derived from the Courier fixed width font. +Generally using metrics from a fixed width font over-estimates +sizes for proportional fonts, in practice this is fine as +\wumpuscore has limited needs. \item[\texttt{Wumpus.Core.Geometry.}] -The usual types an operations from affine geometry - points, +The usual types and operations from affine geometry - points, vectors and 3x3 matrices, also the \texttt{DUnit} type family. Essentially this type family is a trick used heavily within \wumpuscore to avoid annotating class declarations with @@ -105,11 +106,12 @@ Data types modelling the attributes of PostScript's graphics state (stroke style, dash pattern, etc.). Note that \wumpuscore labels all primitives - paths, text labels - with -their rendering style, unlike PostScript there is no +their drawing attributes, unlike PostScript there is no \emph{inheritance} of a Graphics State in \wumpuscore. \item[\texttt{Wumpus.Core.OutputPostScript.}] -Functions to write PostScript or encapsulated PostScript files. +Functions to write PostScript and Encapsulated PostScript (EPS) +files. \item[\texttt{Wumpus.Core.OutputSVG.}] Functions to write SVG files. @@ -122,29 +124,24 @@ \texttt{PictureInternal} are exported with opaque signatures by \texttt{Wumpus.Core.WumpusTypes}. -\item[\texttt{Wumpus.Core.PtSize.}] -Text size calculations in \texttt{Core.FontSize} use -\emph{printer's points} (i.e. 1/72 of an inch). The -\texttt{PtSize} module is a numeric type to represent them. - \item[\texttt{Wumpus.Core.Text.Base.}] -Types for handling escaped \emph{special} charcters within input +Types for handling escaped \emph{special} characters within input text. Wumpus mostly follows SVG conventions for escaping strings, although glyph names should \emph{always} correspond to PostScript names and never XML / SVG ones, e.g. for \texttt{\&} use \texttt{\#ampersand;} not \texttt{\#amp;}. Also note, unless only SVG output is being generated, glyph -names should be used rather than char codes. For PostScript the -resolution of char codes is dependent on the encoding of the font -used to render it. As the core PostScript fonts use their own -encoding rather than the common Latin1 encoding, using using -numeric char codes (intending to be Latin1) can produce unexpected -results. +names should be used rather than character codes. With PostScript, +the resolution of character codes is dependent on the encoding of +the font used to render it. As the core PostScript fonts use their +own encoding rather than the common Latin1 encoding, using using +numeric character codes (expected to be Latin1) can produce +unanticipated results. Unfortunately, even core fonts are often missing glyphs that familiarity with Unicode and Web publishing might expect them -support. Generally, a PostScript renderer cannot do anything about +support. Generally, a PostScript renderer can do nothing about missing glyphs - it might print a space or an open, tall rectangle. As \wumpuscore is oblivious to the contents of fonts, it cannot issue a warning if a glyph is not present when it generates a @@ -152,15 +149,16 @@ glyphs are used. \item[\texttt{Wumpus.Core.Text.GlyphIndices.}] -An map of PostScript glyph names to Unicode code points. +An map of PostScript glyph names to Unicode code points. \item[\texttt{Wumpus.Core.Text.GlyphNames.}] An map of Unicode code points to PostScript glyph names. Unfortunately this table is \emph{lossy} - some code points have more than one name, and as this file is auto-generated the -resolution of which glyph name matches a code point is arbtirary. -\wumpuscore uses this table only as a fallback if PostScript glyph -name resolution cannot be solved through an encoding vector. +resolution of which overlapping glyph name matches a code point is +arbitrary. \wumpuscore uses this table only as a fallback if +PostScript glyph name resolution cannot be solved through a font's +encoding vector. \item[\texttt{Wumpus.Core.Text.Latin1Encoding.}] An encoding vector for the Latin 1 character set. @@ -191,24 +189,26 @@ \section{Drawing model} %----------------------------------------------------------------- -\wumpuscore has two main drawable primitives \emph{paths} -and text \emph{labels}, ellipses are also a primitive although -this is a concession to efficiency when drawing dots (which would -otherwise require 4 to 8 Bezier arcs to describe). Paths are made +\wumpuscore has two main drawing primitives \emph{paths} +and text \emph{labels}. Ellipses are also a primitive although +this is a concession to efficiency for drawing dots, which would +otherwise require four Bezier arcs to describe. Paths are made from straight sections or Bezier curves, they can be open and \emph{stroked} to produce a line; or closed and \emph{stroked}, \emph{filled} or \emph{clipped}. Labels represent a single horizontal line of text - multiple lines must be composed from -multiple labels. +multiple labels and white-space other than the \texttt{space} +character should not be used. Primitives are attributed with drawing styles - font name and -size for labels; line width, colour, etc. for paths. Primitives -can be grouped to support support hyperlinks in SVG output (so -Primitives are not strictly \emph{primitive}). The function -\texttt{frame} assembles a list of primitives into a -\texttt{Picture} with the standard affine frame where the origin - is at (0,0) and the X and Y axes have the unit bases (i.e. they -have a \emph{scaling} value of 1). +point size for labels; line width, colour, etc. for paths. +Primitives can be grouped to support support hyperlinks in SVG +output (thus Primitives are not strictly \emph{primitive} as they +are implemented with some nesting). The function \texttt{frame} +assembles a list of primitives into a \texttt{Picture} with the +standard affine frame where the origin is at (0,0) and the X +and Y axes have the unit bases (i.e. they have a +\emph{scaling value} of 1). \begin{figure} \centering @@ -217,13 +217,13 @@ \end{figure} \wumpuscore uses the same picture frame as PostScript where -the origin at the bottom left, see Figure 1. This contrasts to SVG -where the origin is at the top-left. When \wumpuscore generates -SVG, the whole picture is generated within a matrix transformation -[ 1.0, 0.0, 0.0, -1.0, 0.0, 0.0 ] that changes the picture to use -PostScript coordinates. This has the side-effect that text is -otherwise drawn upside down, so \wumpuscore adds a rectifying -transform to each text element. +the origin at is the bottom left, see Figure 1. This contrasts to +SVG where the origin is at the top-left. When \wumpuscore +generates SVG, the whole picture is generated within a matrix +transformation [ 1.0, 0.0, 0.0, -1.0, 0.0, 0.0 ] that changes the +picture to use PostScript coordinates. This has the side-effect +that text is otherwise drawn upside down, so \wumpuscore adds a +rectifying transformation to each text element. Once labels and paths are assembled as a \emph{Picture} they are transformable with the usual affine transformations (scaling, @@ -235,9 +235,9 @@ In some ways this is a limitation - for instance, the \texttt{Diagrams} library appears to support some notion of attribute overriding; however avoiding mutable attributes does -keep this part of \wumpuscore conceptually simple. To make -a blue or red arrow with \wumpuscore, one would make drawing -colour a parameter of the arrow constructor function. +keep this part of \wumpuscore conceptually simple. To make a +blue or red triangle with \wumpuscore, one would make the drawing +colour a parameter of the triangle constructor function. %----------------------------------------------------------------- \section{Affine transformations} @@ -245,7 +245,7 @@ For affine transformations Wumpus uses the \texttt{Matrix3'3} data type to represent 3x3 matrices in row-major form. The constructor - \texttt{(M3'3 a b c d e f g h i)} builds this matrix: +\texttt{(M3'3 a b c d e f g h i)} builds this matrix: \begin{displaymath} \begin{array}{ccc} @@ -256,10 +256,9 @@ \end{displaymath} Note, in practice the elements \emph{g} and \emph{h} are -superflous. They are included in the data type to make it match -the typical representation from geometry texts. Also, typically -matrices will implicitly created with functions from the -\texttt{Core.Geometry} and \texttt{Core.AffineTrans} modules. +largely superflous, but they are included in the data type so +the matrix operations available (e.g. \texttt{invert} and +\texttt{transpose}) have simple, regular definitions. For example a translation matrix moving 10 units in the X-axis and 20 in the Y-axis will be encoded as @@ -277,9 +276,9 @@ as \texttt{concat} commands. For Pictures, \wumpuscore performs no transformations itself, delegating all the work to PostScript or SVG. Internally \wumpuscore transforms the bounding boxes of -Pictures - it needs to do this to maintain their size metrics -allowing transformed pictures to be composed with picture -composition operators like the \texttt{picBeside} combinator. +Pictures - the bounding box of a pictured is cached so that +pictures can be composed with \emph{picture composition} operators +like the \texttt{picBeside} combinator. PostScript uses column-major form and uses a six element matrix rather than a nine element one. The translation matrix above @@ -306,10 +305,10 @@ points before the output is generated. For labels and ellipses the \emph{start point} of the primitive (baseline-left for label, center for ellipse) is transformed by \wumpuscore and matrix -operations are transmitted to PostScript and SVG to transform the -actual drawing (\wumpuscore has no access to the paths that -describe character glyphs so it cannot precompute transformations -on them). +operations are transmitted in the generated PostScript and SVG to +transform the actual drawing (\wumpuscore has no access to the +paths that describe character glyphs so it cannot precompute +transformations on them). One consequence of transformations operating on the control points of primitives is that scalings do not scale the tip of the diff --git a/doc-src/WorldFrame.hs b/doc-src/WorldFrame.hs --- a/doc-src/WorldFrame.hs +++ b/doc-src/WorldFrame.hs @@ -7,10 +7,11 @@ import Wumpus.Core.Text.StandardEncoding main :: IO () -main = writeEPS "WorldFrame.eps" world_frame +main = writeEPS "./out/WorldFrame.eps" world_frame >> + writeSVG "./out/WorldFrame.svg" world_frame -world_frame :: DPicture -world_frame = uniformScale 0.75 $ +world_frame :: Picture +world_frame = scale 0.75 0.75 $ frame [ ogin, btm_right, top_left, top_right , x_axis, y_axis, line1 ] @@ -26,13 +27,14 @@ -makeLabelPrim :: String -> DPoint2 -> DPrimitive +makeLabelPrim :: String -> DPoint2 -> Primitive makeLabelPrim = textlabel black attrs where attrs = FontAttr 10 (FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding) -makeLinePrim :: Double -> DPoint2 -> DPoint2 -> DPrimitive -makeLinePrim lw a b = ostroke black attrs $ primPath a [lineTo b] +makeLinePrim :: Double -> DPoint2 -> DPoint2 -> Primitive +makeLinePrim lw a b = ostroke black attrs $ absPrimPath a [absLineTo b] where - attrs = default_stroke_attr {line_width=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.hs b/src/Wumpus/Core.hs --- a/src/Wumpus/Core.hs +++ b/src/Wumpus/Core.hs @@ -3,10 +3,10 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 -- --- Maintainer : Stephen Tetley +-- Maintainer : stephen.tetley@gmail.com -- Stability : unstable -- Portability : GHC -- @@ -44,12 +44,10 @@ , module Wumpus.Core.OutputPostScript , module Wumpus.Core.OutputSVG , module Wumpus.Core.Picture - , module Wumpus.Core.PtSize , module Wumpus.Core.Text.Base , module Wumpus.Core.VersionNumber , module Wumpus.Core.WumpusTypes - ) where import Wumpus.Core.AffineTrans @@ -66,7 +64,6 @@ import Wumpus.Core.OutputPostScript import Wumpus.Core.OutputSVG import Wumpus.Core.Picture -import Wumpus.Core.PtSize import Wumpus.Core.Text.Base import Wumpus.Core.VersionNumber import Wumpus.Core.WumpusTypes 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 @@ -1,14 +1,12 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} {-# LANGUAGE UndecidableInstances #-} - ------------------------------------------------------------------------------ -- | -- Module : Wumpus.Core.AffineTrans --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -20,7 +18,6 @@ -- The common affine transformations represented as type classes - -- scaling, rotation, translation. -- --- -- 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 @@ -49,6 +46,24 @@ -- representations of the affine transformations being invertible. -- Do not scale elements by zero! -- +-- +-- Design note - the formulation of the affine classes is not +-- ideal as dealing with units is avoided and the instances for +-- Point2 and Vec2 are only applicable to @DPoint2@ and @DVec2@. +-- Dealing with units is avoided as some useful units +-- (particulary Em and En) have contextual interterpretations - +-- i.e. their size is dependent on the current font size - and so +-- they cannot be accommodated without some monadic context. +-- +-- For this reason, the naming scheme for the affine classes was +-- changed at revision 0.50.0 to the current \"d\"-prefixed names. +-- This allows higher-level frameworks to define their own +-- functions or class-methods using the obvious good names +-- (@rotate@, @scale@ etc.). The derived operations (@rotate30@, +-- @uniformScale, etc.) have been removed as a higher-level +-- implementation is expected to re-implement them accounting for +-- polymorphic units as necessary. +-- -------------------------------------------------------------------------------- module Wumpus.Core.AffineTrans @@ -93,20 +108,35 @@ -------------------------------------------------------------------------------- -- Affine transformations +-- +-- Design Note +-- +-- Perhaps the Transform class is not generally useful in the +-- presence of units. +-- + + -- | Apply a matrix transformation directly. -- class Transform t where transform :: u ~ DUnit t => Matrix3'3 u -> t -> t -instance Transform (UNil u) where - transform _ = id +instance Transform a => Transform (Maybe a) where + transform = fmap . transform + +instance (u ~ DUnit a, u ~ DUnit b, Transform a, Transform b) => + Transform (a,b) where + transform mtrx (a,b) = (transform mtrx a, transform mtrx b) + + instance Num u => Transform (Point2 u) where transform ctm = (ctm *#) instance Num u => Transform (Vec2 u) where transform ctm = (ctm *#) + -------------------------------------------------------------------------------- -- | Type class for rotation. @@ -114,47 +144,68 @@ class Rotate t where rotate :: Radian -> t -> t -instance Rotate (UNil u) where - rotate _ = id instance Rotate a => Rotate (Maybe a) where rotate = fmap . rotate -instance (Rotate a, Rotate b, u ~ DUnit a, u ~ DUnit b) => Rotate (a,b) where + +instance (Rotate a, Rotate b) => Rotate (a,b) where rotate ang (a,b) = (rotate ang a, rotate ang b) -instance (Floating u, Real u) => Rotate (Point2 u) where - rotate ang = ((rotationMatrix ang) *#) +instance (Real u, Floating u) => Rotate (Point2 u) where + rotate ang pt = P2 x y + where + v = pvec zeroPt pt + (V2 x y) = avec (ang + vdirection v) $ vlength v -instance (Floating u, Real u) => Rotate (Vec2 u) where - rotate ang = ((rotationMatrix ang) *#) +instance (Real u, Floating u) => Rotate (Vec2 u) where + rotate ang v = avec (ang + vdirection v) $ vlength v +-- +-- + -- | Type class for rotation about a point. -- +-- Note - the point is a @DPoint2@ - i.e. it has PostScript points +-- for x and y-units. +-- class RotateAbout t where - rotateAbout :: u ~ DUnit t => Radian -> Point2 u -> t -> t + rotateAbout :: u ~ DUnit t => Radian -> Point2 u -> t -> t -instance RotateAbout (UNil u) where - rotateAbout _ _ = id +-- +-- Note - it seems GHC 7.0.2 at least, would let us define a +-- RotateAbout instance for @()@, even though it has no valid +-- DUnit instance. +-- +-- Still it seems safer to define a nil type with a phantom unit: +-- +-- > data UNil u = UNil +-- +-- This data type is provided by Wumpus-Basic. +-- + instance RotateAbout a => RotateAbout (Maybe a) where rotateAbout ang pt = fmap (rotateAbout ang pt) -instance (RotateAbout a, RotateAbout b, u ~ DUnit a, u ~ DUnit b) => + +instance (u ~ DUnit a, u ~ DUnit b, RotateAbout a, RotateAbout b) => RotateAbout (a,b) where rotateAbout ang pt (a,b) = (rotateAbout ang pt a, rotateAbout ang pt b) +instance (Real u, Floating u) => RotateAbout (Point2 u) where + rotateAbout ang (P2 ox oy) = + translate ox oy . rotate ang . translate (-ox) (-oy) -instance (Floating u, Real u) => RotateAbout (Point2 u) where - rotateAbout ang pt = ((originatedRotationMatrix ang pt) *#) +instance (Real u, Floating u) => RotateAbout (Vec2 u) where + rotateAbout ang (P2 ox oy) = + translate ox oy . rotate ang . translate (-ox) (-oy) -instance (Floating u, Real u) => RotateAbout (Vec2 u) where - rotateAbout ang pt = ((originatedRotationMatrix ang pt) *#) -------------------------------------------------------------------------------- -- Scale @@ -162,22 +213,20 @@ -- | Type class for scaling. -- class Scale t where - scale :: u ~ DUnit t => u -> u -> t -> t + scale :: Double -> Double -> t -> t -instance Scale (UNil u) where - scale _ _ = id instance Scale a => Scale (Maybe a) where scale sx sy = fmap (scale sx sy) -instance (Scale a, Scale b, u ~ DUnit a, u ~ DUnit b) => Scale (a,b) where +instance (Scale a, Scale b) => Scale (a,b) where scale sx sy (a,b) = (scale sx sy a, scale sx sy b) -instance Num u => Scale (Point2 u) where - scale sx sy = ((scalingMatrix sx sy) *#) +instance Fractional u => Scale (Point2 u) where + scale sx sy (P2 x y) = P2 (x * realToFrac sx) (y * realToFrac sy) -instance Num u => Scale (Vec2 u) where - scale sx sy = ((scalingMatrix sx sy) *#) +instance Fractional u => Scale (Vec2 u) where + scale sx sy (V2 x y) = V2 (x * realToFrac sx) (y * realToFrac sy) -------------------------------------------------------------------------------- -- Translate @@ -187,30 +236,27 @@ class Translate t where translate :: u ~ DUnit t => u -> u -> t -> t - -instance Translate (UNil u) where - translate _ _ = id +instance Translate a => Translate (Maybe a) where + translate dx dy = fmap (translate dx dy) -instance (Translate a, Translate b, u ~ DUnit a, u ~ DUnit b) => +instance (u ~ DUnit a, u ~ DUnit b, Translate a, Translate b) => Translate (a,b) where translate dx dy (a,b) = (translate dx dy a, translate dx dy b) - -instance Translate a => Translate (Maybe a) where - translate dx dy = fmap (translate dx dy) - instance Num u => Translate (Point2 u) where - translate dx dy (P2 x y) = P2 (x+dx) (y+dy) + translate dx dy (P2 x y) = P2 (x + dx) (y + dy) -instance Num u => Translate (Vec2 u) where - translate dx dy (V2 x y) = V2 (x+dx) (y+dy) +-- | Vectors do not respond to translation. +-- +instance Translate (Vec2 u) where + translate _ _ v0 = v0 + -------------------------------------------------------------------------------- -- Common rotations - -- | Rotate by 30 degrees about the origin. -- rotate30 :: Rotate t => t -> t @@ -268,17 +314,17 @@ -- | Scale both x and y dimensions by the same amount. -- -uniformScale :: (Scale t, DUnit t ~ u) => u -> t -> t +uniformScale :: Scale t => Double -> t -> t uniformScale a = scale a a -- | Reflect in the X-plane about the origin. -- -reflectX :: (Num u, Scale t, DUnit t ~ u) => t -> t +reflectX :: Scale t => t -> t reflectX = scale (-1) 1 -- | Reflect in the Y-plane about the origin. -- -reflectY :: (Num u, Scale t, DUnit t ~ u) => t -> t +reflectY :: Scale t => t -> t reflectY = scale 1 (-1) -------------------------------------------------------------------------------- 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 @@ -1,10 +1,11 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.BoundingBox --- Copyright : (c) Stephen Tetley 2009-2011 +-- Copyright : (c) Stephen Tetley 2009-2012 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -54,7 +55,6 @@ import Wumpus.Core.AffineTrans import Wumpus.Core.Geometry -import Wumpus.Core.Utils.Common ( PSUnit(..) ) import Wumpus.Core.Utils.FormatCombinators @@ -73,50 +73,55 @@ { ll_corner :: Point2 u , ur_corner :: Point2 u } - deriving (Eq,Show) + deriving (Show) type DBoundingBox = BoundingBox Double - +type instance DUnit (BoundingBox u) = u -------------------------------------------------------------------------------- -- instances +instance (Tolerance u, Ord u) => Eq (BoundingBox u) where + BBox ll0 ur0 == BBox ll1 ur1 = ll0 == ll1 && ur0 == ur1 +instance Functor BoundingBox where + fmap f (BBox p0 p1) = BBox (fmap f p0) (fmap f p1) -instance PSUnit u => Format (BoundingBox u) where - format (BBox p0 p1) = parens (text "BBox" <+> text "ll=" <> format p0 - <+> text "ur=" <> format p1) +instance Format u => Format (BoundingBox u) where + format (BBox p0 p1) = parens (text "BBox" <+> text "ll=" >< format p0 + <+> text "ur=" >< format p1) -------------------------------------------------------------------------------- --- - -type instance DUnit (BoundingBox u) = u +-- Transform... -pointTransform :: (Num u , Ord u) +-- | Helper for transformation. +-- +pointTransform :: (Num u, Ord u) => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u -pointTransform fn bb = traceBoundary $ map fn $ [bl,br,tr,tl] - where - (bl,br,tr,tl) = boundaryCorners bb +pointTransform fn bb = + traceBoundary $ map fn $ [bl,br,tr,tl] + where + (bl,br,tr,tl) = boundaryCorners bb + instance (Num u, Ord u) => Transform (BoundingBox u) where transform mtrx = pointTransform (mtrx *#) -instance (Real u, Floating u) => Rotate (BoundingBox u) where +instance (Real u, Floating u, Ord u) => Rotate (BoundingBox u) where rotate theta = pointTransform (rotate theta) -instance (Real u, Floating u) => RotateAbout (BoundingBox u) where +instance (Real u, Floating u, Ord u) => RotateAbout (BoundingBox u) where rotateAbout theta pt = pointTransform (rotateAbout theta pt) -instance (Num u, Ord u) => Scale (BoundingBox u) where +instance (Fractional u, Ord u) => Scale (BoundingBox u) where scale sx sy = pointTransform (scale sx sy) instance (Num u, Ord u) => Translate (BoundingBox u) where translate dx dy = pointTransform (translate dx dy) - -------------------------------------------------------------------------------- -- Boundary class @@ -127,6 +132,9 @@ boundary :: u ~ DUnit t => t -> BoundingBox u +instance Boundary (BoundingBox u) where + boundary = id + -------------------------------------------------------------------------------- -- | 'boundingBox' : @lower_left_corner * upper_right_corner -> BoundingBox@ @@ -237,7 +245,7 @@ -- -- Within test - is the supplied point within the bounding box? -- -withinBoundary :: Ord u => Point2 u -> BoundingBox u -> Bool +withinBoundary :: (Tolerance u, Ord u) => Point2 u -> BoundingBox u -> Bool withinBoundary p (BBox ll ur) = (minPt p ll) == ll && (maxPt p ur) == ur 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 @@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.Colour --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2012 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Colour represented as RGB with each component in the range @@ -63,8 +63,8 @@ instance Format RGBi where format (RGBi 0 0 0) = text "*black*" format (RGBi 255 255 255) = text "*white*" - format (RGBi r g b) = integral r <> comma <> integral g - <> comma <> integral b + format (RGBi r g b) = integral r >< comma >< integral g + >< comma >< integral b -------------------------------------------------------------------------------- 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 @@ -36,8 +36,9 @@ -- * Type synonyms FontSize , CharCount - , PtScale - , ptSizeScale + , AfmUnit + , afmUnit + , afmValue -- * Scaling values derived from Courier , mono_width @@ -66,11 +67,9 @@ import Wumpus.Core.BoundingBox import Wumpus.Core.Geometry -import Wumpus.Core.PtSize import Wumpus.Core.Text.Base - type CharCount = Int type FontSize = Int @@ -79,22 +78,39 @@ -- (Point size) of a font. AFM files encode all measurements -- as these units. -- -newtype PtScale = PtScale { getPtScale :: Double } +newtype AfmUnit = AfmUnit { getAfmUnit :: Double } deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) -instance Show PtScale where - showsPrec p d = showsPrec p (getPtScale d) +instance Show AfmUnit where + showsPrec p d = showsPrec p (getAfmUnit d) +instance Tolerance AfmUnit where + eq_tolerance = 0.001 + length_tolerance = 0.1 --- | 'ptSizeScale' : @ scale_factor -> pt_size -> PTSize @ + +-- | Flipped version of 'afmValue'. -- --- Scale the point size by the scale factor. +afmValueSZ :: AfmUnit -> FontSize -> Double +afmValueSZ = flip afmValue + + +-- | Compute the size of a measurement in PostScript points +-- scaling the Afm unit size by the point size of the font. -- -ptSizeScale :: PtScale -> PtSize -> PtSize -ptSizeScale sc sz = sz * realToFrac sc +afmValue :: FontSize -> AfmUnit -> Double +afmValue sz u = realToFrac u * (fromIntegral sz) / 1000 +-- | Compute the size of a measurement in Afm units scaled by the +-- point size of the font. +-- +afmUnit :: FontSize -> Double -> AfmUnit +afmUnit sz u = 1000.0 * (realToFrac u) / (fromIntegral sz) + + + -- NOTE - I\'ve largely tried to follow the terminoloy from -- Edward Tufte\'s /Visual Explantions/, page 99. -- @@ -102,17 +118,17 @@ -- | The ratio of width to point size of a letter in Courier. -- --- > mono_width = 0.6 +-- > mono_width = 600 -- -mono_width :: PtScale -mono_width = 0.600 +mono_width :: AfmUnit +mono_width = 600 -- | The ratio of cap height to point size of a letter in Courier. -- --- > mono_cap_height = 0.562 +-- > mono_cap_height = 562 -- -mono_cap_height :: PtScale -mono_cap_height = 0.562 +mono_cap_height :: AfmUnit +mono_cap_height = 562 @@ -121,70 +137,70 @@ -- -- This is also known as the \"body height\". -- --- > mono_x_height = 0.426 +-- > mono_x_height = 426 -- -mono_x_height :: PtScale -mono_x_height = 0.426 +mono_x_height :: AfmUnit +mono_x_height = 426 -- | The ratio of descender depth to point size of a letter in -- Courier. -- --- > mono_descender = -0.157 +-- > mono_descender = -157 -- -mono_descender :: PtScale -mono_descender = (-0.157) +mono_descender :: AfmUnit +mono_descender = (-157) -- | The ratio of ascender to point size of a letter in Courier. -- --- > mono_ascender = 0.629 +-- > mono_ascender = 629 -- -mono_ascender :: PtScale -mono_ascender = 0.629 +mono_ascender :: AfmUnit +mono_ascender = 629 -- | The distance from baseline to max height as a ratio to point -- size for Courier. -- --- > mono_max_height = 0.805 +-- > mono_max_height = 805 -- -mono_max_height :: PtScale -mono_max_height = 0.805 +mono_max_height :: AfmUnit +mono_max_height = 805 -- | The distance from baseline to max depth as a ratio to point -- size for Courier. -- --- > max_depth = -0.250 +-- > max_depth = -250 -- -mono_max_depth :: PtScale -mono_max_depth = (-0.250) +mono_max_depth :: AfmUnit +mono_max_depth = (-250) -- | The left margin for the bounding box of printed text as a -- ratio to point size for Courier. -- --- > mono_left_margin = -0.046 +-- > mono_left_margin = -46 -- -mono_left_margin :: PtScale -mono_left_margin = (-0.046) +mono_left_margin :: AfmUnit +mono_left_margin = (-46) -- | The right margin for the bounding box of printed text as a -- ratio to point size for Courier. -- --- > mono_right_margin = 0.050 +-- > mono_right_margin = 50 -- -mono_right_margin :: PtScale -mono_right_margin = 0.050 +mono_right_margin :: AfmUnit +mono_right_margin = 50 -- | Approximate the width of a monospace character using -- metrics derived from the Courier font. -- -charWidth :: FontSize -> PtSize -charWidth = ptSizeScale mono_width . fromIntegral +charWidth :: FontSize -> Double +charWidth = afmValueSZ mono_width @@ -196,7 +212,7 @@ -- NOTE - this does not account for any left and right margins -- around the printed text. -- -textWidth :: FontSize -> CharCount -> PtSize +textWidth :: FontSize -> CharCount -> Double textWidth _ n | n <= 0 = 0 textWidth sz n = fromIntegral n * charWidth sz @@ -204,37 +220,37 @@ -- | Height of capitals e.g. \'A\' using metrics derived -- the Courier monospaced font. -- -capHeight :: FontSize -> PtSize +capHeight :: FontSize -> Double capHeight = fromIntegral -- | Height of the lower-case char \'x\' using metrics derived -- the Courier monospaced font. -- -xcharHeight :: FontSize -> PtSize -xcharHeight = ptSizeScale mono_x_height . fromIntegral +xcharHeight :: FontSize -> Double +xcharHeight = afmValueSZ mono_x_height -- | The total height span of the glyph bounding box for the -- Courier monospaced font. -- -totalCharHeight :: FontSize -> PtSize -totalCharHeight sz = let sz' = fromIntegral sz in - ptSizeScale mono_max_height sz' + negate (ptSizeScale mono_max_depth sz') +totalCharHeight :: FontSize -> Double +totalCharHeight sz = + afmValueSZ mono_max_height sz + negate (afmValueSZ mono_max_depth sz) -- | Ascender height for font size @sz@ using metrics from the -- Courier monospaced font. -- -ascenderHeight :: FontSize -> PtSize -ascenderHeight = ptSizeScale mono_ascender . fromIntegral +ascenderHeight :: FontSize -> Double +ascenderHeight = afmValueSZ mono_ascender -- | Descender depth for font size @sz@ using metrics from the -- Courier monospaced font. -- -descenderDepth :: FontSize -> PtSize -descenderDepth = ptSizeScale mono_descender . fromIntegral +descenderDepth :: FontSize -> Double +descenderDepth = afmValueSZ mono_descender -- | 'textBounds' : @ font_size * baseline_left * text -> BBox @ @@ -250,8 +266,7 @@ -- For proportional fonts the calculated bounding box will -- usually be too long. -- -textBounds :: (Num u, Ord u, FromPtSize u) - => FontSize -> Point2 u -> String -> BoundingBox u +textBounds :: FontSize -> DPoint2 -> String -> BoundingBox Double textBounds sz pt ss = textBoundsBody sz pt (charCount ss) @@ -259,21 +274,18 @@ -- -- Version of textBounds for already escaped text. -- -textBoundsEsc :: (Num u, Ord u, FromPtSize u) - => FontSize -> Point2 u -> EscapedText -> BoundingBox u +textBoundsEsc :: FontSize -> DPoint2 -> EscapedText -> BoundingBox Double textBoundsEsc sz pt esc = textBoundsBody sz pt (textLength esc) -textBoundsBody :: (Num u, Ord u, FromPtSize u) - => FontSize -> Point2 u -> Int -> BoundingBox u +textBoundsBody :: FontSize -> DPoint2 -> Int -> BoundingBox Double textBoundsBody sz (P2 x y) len = boundingBox ll ur where - pt_sz = fromIntegral sz - w = fromPtSize $ textWidth sz len - left_m = fromPtSize $ ptSizeScale mono_left_margin pt_sz - right_m = fromPtSize $ ptSizeScale mono_right_margin pt_sz - max_depth = fromPtSize $ ptSizeScale mono_max_depth pt_sz - max_height = fromPtSize $ ptSizeScale mono_max_height pt_sz + w = textWidth sz len + left_m = afmValueSZ mono_left_margin sz + right_m = afmValueSZ mono_right_margin sz + max_depth = afmValueSZ mono_max_depth sz + max_height = afmValueSZ mono_max_height sz ll = P2 (x + left_m) (y + max_depth) ur = P2 (x + w + right_m) (y + max_height) diff --git a/src/Wumpus/Core/Geometry.hs b/src/Wumpus/Core/Geometry.hs --- a/src/Wumpus/Core/Geometry.hs +++ b/src/Wumpus/Core/Geometry.hs @@ -7,11 +7,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.Geometry --- Copyright : (c) Stephen Tetley 2009-2011 +-- Copyright : (c) Stephen Tetley 2009-2012 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Objects and operations for 2D geometry. @@ -26,12 +26,13 @@ module Wumpus.Core.Geometry ( - -- * Type family + -- * Type family DUnit - , GuardEq - + + , Tolerance(..) + + -- * Data types - , UNil , Vec2(..) , DVec2 , Point2(..) @@ -43,19 +44,29 @@ , MatrixMult(..) - -- * UNil operations - , uNil + -- * Tolerance helpers + , tEQ + , tGT + , tLT + , tGTE + , tLTE + , tCompare + -- * Vector operations + , zeroVec , vec , hvec , vvec , avec , pvec + , orthoVec , vreverse , vdirection , vlength , vangle + , vsum + , vdiff -- * Point operations , zeroPt @@ -70,7 +81,7 @@ , rotationMatrix , originatedRotationMatrix - -- * matrix operations + -- * Matrix operations , invert , determinant , transpose @@ -83,29 +94,30 @@ , circularModulo -- * Bezier curves - , bezierArc , bezierCircle + , bezierEllipse + , rbezierEllipse + , bezierArc + , subdivisionCircle + ) where -import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators import Data.AffineSpace -- package: vector-space import Data.VectorSpace -import Data.Monoid - -------------------------------------------------------------------------------- --- | Some unit of dimension usually double. +-- | Some unit of dimension usually Double. -- -- This very useful for reducing the kind of type classes to *. -- --- Doing this then allows constraints on the Unit type on the +-- Then constraints on the Unit type can be declared on the -- instances rather than in the class declaration. -- type family DUnit a :: * @@ -118,33 +130,53 @@ --------------------------------------------------------------------------------- --- Datatypes - --- | Phantom @()@. +-- | Class for tolerance on floating point numbers. -- --- This newtype is Haskell\'s @()@ with unit of dimension @u@ as --- a phantom type. +-- Two tolerances are required tolerance for equality - commonly +-- used for testing if two points are equal - and tolerance for +-- path length measurement. -- --- This type has no direct use in Wumpus-Core, but it is useful --- for higher-level software a - it has instances of the affine --- classes which cannot be written for @()@ (Wumpus-Basic --- uses it for the @Graphic@ type.) +-- Path length measurement in Wumpus does not have a strong +-- need to be exact (precision is computational costly) - by +-- default it is 100x the equality tolerance. -- -newtype UNil u = UNil () - deriving (Bounded,Enum,Eq,Ord) +-- Bezier path lengths are calculated by iteration, so greater +-- accuracy requires more compution. As it is hard to visually +-- differentiate measures of less than a point the tolerance +-- for Points is quite high quite high (0.1). +-- +-- The situation is more complicated for contextual units +-- (Em and En) as they are really scaling factors. The bigger +-- the point size the less accurate the measure is. +-- +class Num u => Tolerance u where + eq_tolerance :: u + length_tolerance :: u + length_tolerance = 100 * eq_tolerance +instance Tolerance Double where + eq_tolerance = 0.001 + length_tolerance = 0.1 + + + +-- Datatypes + + -- | 2D Vector - both components are strict. -- +-- Note - equality is defined with 'Tolerance' and tolerance is +-- quite high for the usual units. See the note for 'Point2'. +-- data Vec2 u = V2 { vector_x :: !u , vector_y :: !u } - deriving (Eq,Show) + deriving (Show) type DVec2 = Vec2 Double @@ -152,14 +184,19 @@ -- | 2D Point - both components are strict. -- --- Note - Point2 derives Ord so it can be used as a key in --- Data.Map etc. +-- Note - equality is defined with 'Tolerance' and tolerance is +-- quite high for the usual units. +-- +-- This is useful for drawing, *but* unacceptable data centric +-- work. If more accurate equality is needed define a newtype +-- wrapper over the unit type and make a @Tolerance@ instance with +-- much greater accuracy. -- data Point2 u = P2 { point_x :: !u , point_y :: !u } - deriving (Eq,Ord,Show) + deriving (Show) type DPoint2 = Point2 Double @@ -211,10 +248,10 @@ newtype Radian = Radian { getRadian :: Double } deriving (Num,Real,Fractional,Floating,RealFrac,RealFloat) + -------------------------------------------------------------------------------- -- Family instances -type instance DUnit (UNil u) = u type instance DUnit (Point2 u) = u type instance DUnit (Vec2 u) = u type instance DUnit (Matrix3'3 u) = u @@ -239,12 +276,32 @@ -------------------------------------------------------------------------------- -- instances +-- Eq (with tolerance) -instance Monoid (UNil u) where - mempty = UNil () - _ `mappend` _ = UNil () +instance (Tolerance u, Ord u) => Eq (Vec2 u) where + V2 x0 y0 == V2 x1 y1 = x0 `tEQ` x1 && y0 `tEQ` y1 +instance (Tolerance u, Ord u) => Eq (Point2 u) where + P2 x0 y0 == P2 x1 y1 = x0 `tEQ` x1 && y0 `tEQ` y1 + + +-- Ord (with Tolerance) + +instance (Tolerance u, Ord u) => Ord (Vec2 u) where + V2 x0 y0 `compare` V2 x1 y1 = case tCompare x0 x1 of + EQ -> tCompare y0 y1 + ans -> ans + + +instance (Tolerance u, Ord u) => Ord (Point2 u) where + P2 x0 y0 `compare` P2 x1 y1 = case tCompare x0 x1 of + EQ -> tCompare y0 y1 + ans -> ans + + + + -- Functor instance Functor Vec2 where @@ -262,9 +319,6 @@ -- Show -instance Show (UNil u) where - show _ = "UNil" - instance Show u => Show (Matrix3'3 u) where show (M3'3 a b c d e f g h i) = "(M3'3 " ++ body ++ ")" where body = show [[a,b,c],[d,e,f],[g,h,i]] @@ -304,23 +358,23 @@ -------------------------------------------------------------------------------- -- Pretty printing -instance PSUnit u => Format (Vec2 u) where - format (V2 a b) = parens (text "Vec" <+> dtruncFmt a <+> dtruncFmt b) +instance Format u => Format (Vec2 u) where + format (V2 a b) = parens (text "Vec" <+> format a <+> format b) -instance PSUnit u => Format (Point2 u) where - format (P2 a b) = parens (dtruncFmt a <> comma <+> dtruncFmt b) +instance Format u => Format (Point2 u) where + format (P2 a b) = parens (format a >< comma <+> format b) -instance PSUnit u => Format (Matrix3'3 u) where +instance Format u => Format (Matrix3'3 u) where format (M3'3 a b c d e f g h i) = vcat [matline a b c, matline d e f, matline g h i] where matline x y z = char '|' - <+> (hcat $ map (fill 12 . dtruncFmt) [x,y,z]) + <+> (hcat $ map (fill 12 . format) [x,y,z]) <+> char '|' instance Format Radian where - format (Radian d) = double d <> text ":rad" + format (Radian d) = double d >< text ":rad" -------------------------------------------------------------------------------- -- Vector space instances @@ -374,29 +428,90 @@ -- represented as homogeneous coordinates. -- class MatrixMult t where - (*#) :: DUnit t ~ u => Matrix3'3 u -> t -> t + (*#) :: Num u => Matrix3'3 u -> t u -> t u -instance Num u => MatrixMult (Vec2 u) where - (M3'3 a b c d e f _ _ _) *# (V2 m n) = V2 (a*m+b*n+c*0) (d*m+e*n+f*0) +instance MatrixMult Vec2 where + (M3'3 a b c d e f _ _ _) *# (V2 m n) = V2 (a*m + b*n + c*0) + (d*m + e*n + f*0) -instance Num u => MatrixMult (Point2 u) where - (M3'3 a b c d e f _ _ _) *# (P2 m n) = P2 (a*m+b*n+c*1) (d*m+e*n+f*1) +instance MatrixMult Point2 where + (M3'3 a b c d e f _ _ _) *# (P2 m n) = P2 (a*m + b*n + c*1) + (d*m + e*n + f*1) -------------------------------------------------------------------------------- --- UNil --- | Construct a UNil. +infix 4 `tEQ`, `tLT`, `tGT` + +-- | Tolerant equality - helper function for defining Eq instances +-- that use tolerance. -- -uNil :: UNil u -uNil = UNil () +-- Note - the definition actually needs Ord which is +-- unfortunate (as Ord is /inaccurate/). +-- +tEQ :: (Tolerance u, Ord u) => u -> u -> Bool +tEQ a b = (abs (a-b)) < eq_tolerance +-- | Tolerant less than. +-- +-- Note - the definition actually needs Ord which is +-- unfortunate (as Ord is /inaccurate/). +-- +tLT :: (Tolerance u, Ord u) => u -> u -> Bool +tLT a b = a < b && (b - a) > eq_tolerance + + +-- | Tolerant greater than. +-- +-- Note - the definition actually needs Ord which is +-- unfortunate (as Ord is /inaccurate/). +-- +tGT :: (Tolerance u, Ord u) => u -> u -> Bool +tGT a b = a > b && (a - b) > eq_tolerance + + + +-- | Tolerant less than or equal. +-- +-- Note - the definition actually needs Ord which is +-- unfortunate (as Ord is /inaccurate/). +-- +tLTE :: (Tolerance u, Ord u) => u -> u -> Bool +tLTE a b = tEQ a b || tLT a b + + +-- | Tolerant greater than or equal. +-- +-- Note - the definition actually needs Ord which is +-- unfortunate (as Ord is /inaccurate/). +-- +tGTE :: (Tolerance u, Ord u) => u -> u -> Bool +tGTE a b = tEQ a b || tGT a b + + +-- | Tolerant @compare@. +-- +tCompare :: (Tolerance u, Ord u) => u -> u -> Ordering +tCompare a b | a `tEQ` b = EQ + | otherwise = compare a b + + -------------------------------------------------------------------------------- -- Vectors +-- | Construct a the empty vector (0,0). +-- +-- Note - this is equivalent to @zeroV@ in @Data.AdditiveGroup@. +-- It is provided here for convenience as it may save an extra +-- module import in client code. +-- +zeroVec :: Num u => Vec2 u +zeroVec = V2 0 0 + + -- | 'vec' : @ x_component * y_component -> Vec2 @ -- -- A synonym for the constructor 'V2' with a Num constraint on @@ -437,7 +552,7 @@ avec :: Floating u => Radian -> u -> Vec2 u avec theta d = V2 x y where - ang = fromRadian theta + ang = fromRadian $ circularModulo theta x = d * cos ang y = d * sin ang @@ -452,6 +567,15 @@ pvec = flip (.-.) + +-- | Build a vector form its parallel and perpendicular components +-- and inclination. +-- +orthoVec :: Floating u => u -> u -> Radian -> Vec2 u +orthoVec pall perp ang = avec ang pall ^+^ avec (ang + half_pi) perp + where + half_pi = 0.5 * pi + -- | 'vreverse' : @ vec -> Vec2 @ -- -- Reverse a vector. @@ -486,6 +610,26 @@ vangle u v = realToFrac $ acos $ (u <.> v) / (magnitude u * magnitude v) +-- | Sum a list of Vectors. +-- +vsum :: Num u => [Vec2 u] -> Vec2 u +vsum [] = V2 0 0 +vsum (v:vs) = go v vs + where + go a [] = a + go a (b:bs) = go (a ^+^ b) bs + + +-- | Find the /difference/ between two vectors - i.e. flipped +-- vector subtraction: +-- +-- > vdiff = flip (^-^) +-- +vdiff :: Num u => Vec2 u -> Vec2 u -> Vec2 u +vdiff = flip (^-^) + + + -------------------------------------------------------------------------------- -- Points @@ -530,6 +674,16 @@ lineDirection :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian lineDirection (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1) where + -- Special cases for continuity - the equality test should + -- catch both 0.0 and (-0.0). + -- Note - there is undoubtedly a better way of doing this. + + step x y | x == 0 && y == 0 = 0 + + step x y | x == 0 = if y >=0 then 0.5*pi else 1.5*pi + + step x y | y == 0 = if x >=0 then 0 else pi + -- north-east quadrant step x y | pve x && pve y = toRadian $ atan (y/x) @@ -601,7 +755,8 @@ -- > sin(a) cos(a) 0 -- > 0 0 1 ) -- -rotationMatrix :: (Floating u, Real u) => Radian -> Matrix3'3 u +rotationMatrix :: (Floating u, Real u) + => Radian -> Matrix3'3 u rotationMatrix a = M3'3 (cos ang) (negate $ sin ang) 0 (sin ang) (cos ang) 0 0 0 1 @@ -633,7 +788,8 @@ mTinv = M3'3 1 0 (-x) 0 1 (-y) - 0 0 1 + 0 0 1 + @@ -725,12 +881,18 @@ -- | Degrees to radians. -- -d2r :: (Floating a, Real a) => a -> Radian +-- Degree type fixed to @Double@, compose @d2r@ with @realToFrac@ +-- for @Float@ etc. +-- +d2r :: Double -> Radian d2r = Radian . realToFrac . (*) (pi/180) -- | Radians to degrees. -- -r2d :: (Floating a, Real a) => Radian -> a +-- Degree type fixed to @Double@, compose @r2d@ with @realToFrac@ +-- for @Float@ etc. +-- +r2d :: Radian -> Double r2d = (*) (180/pi) . fromRadian @@ -749,6 +911,109 @@ -------------------------------------------------------------------------------- -- Bezier curves + + +kappa :: Floating u => u +kappa = 4 * ((sqrt 2 - 1) / 3) + + +-- | 'bezierCircle' : @ radius * center -> [Point] @ +-- +-- Make a circle from four Bezier curves. Although this function +-- produces an approximation of a circle, the approximation seems +-- fine in practice. +-- +bezierCircle :: (Fractional u, Floating u) + => u -> Point2 u -> [Point2 u] +bezierCircle radius (P2 x y) = + [ p00,c01,c02, p03,c04,c05, p06,c07,c08, p09,c10,c11, p00 ] + where + rl = radius * kappa + p00 = P2 (x + radius) y + c01 = p00 .+^ vvec rl + c02 = p03 .+^ hvec rl + + p03 = P2 x (y + radius) + c04 = p03 .+^ hvec (-rl) + c05 = p06 .+^ vvec rl + + p06 = P2 (x - radius) y + c07 = p06 .+^ vvec (-rl) + c08 = p09 .+^ hvec (-rl) + + p09 = P2 x (y - radius) + c10 = p09 .+^ hvec rl + c11 = p00 .+^ vvec (-rl) + + +-- | 'bezierEllipse' : @ x_radius * y_radius * center -> [Point] @ +-- +-- Make an ellipse from four Bezier curves. Although this function +-- produces an approximation of a ellipse, the approximation seems +-- fine in practice. +-- +bezierEllipse :: (Fractional u, Floating u) + => u -> u -> Point2 u -> [Point2 u] +bezierEllipse rx ry (P2 x y) = + [ p00,c01,c02, p03,c04,c05, p06,c07,c08, p09,c10,c11, p00 ] + where + lrx = rx * kappa + lry = ry * kappa + p00 = P2 (x + rx) y + c01 = p00 .+^ vvec lry + c02 = p03 .+^ hvec lrx + + p03 = P2 x (y + ry) + c04 = p03 .+^ hvec (-lrx) + c05 = p06 .+^ vvec lry + + p06 = P2 (x - rx) y + c07 = p06 .+^ vvec (-lry) + c08 = p09 .+^ hvec (-lrx) + + p09 = P2 x (y - ry) + c10 = p09 .+^ hvec lrx + c11 = p00 .+^ vvec (-lry) + +-- | 'rbezierEllipse' : @ x_radius * y_radius * center * angle -> [Point] @ +-- +-- Make an rotated ellipse from four Bezier curves. +-- +-- Although this function produces an approximation of a ellipse, +-- the approximation seems fine in practice. +-- +rbezierEllipse :: (Real u, Floating u) + => u -> u -> Radian -> Point2 u -> [Point2 u] +rbezierEllipse rx ry theta pt@(P2 x y) = + [ p00,c01,c02, p03,c04,c05, p06,c07,c08, p09,c10,c11, p00 ] + where + lrx = rx * kappa + lry = ry * kappa + rotM = originatedRotationMatrix theta pt + + -- hvec becomes para + para = \d -> avec theta d + -- vvec becomes perp + perp = \d -> avec (circularModulo $ theta + pi*0.5) d + mkPt = \p1 -> rotM *# p1 + + p00 = mkPt $ P2 (x + rx) y + c01 = p00 .+^ perp lry + c02 = p03 .+^ para lrx + + p03 = mkPt $ P2 x (y + ry) + c04 = p03 .+^ para (-lrx) + c05 = p06 .+^ perp lry + + p06 = mkPt $ P2 (x - rx) y + c07 = p06 .+^ perp (-lry) + c08 = p09 .+^ para (-lrx) + + p09 = mkPt $ P2 x (y - ry) + c10 = p09 .+^ para lrx + c11 = p00 .+^ perp (-lry) + + -- | 'bezierArc' : @ radius * ang1 * ang2 * center -> -- (start_point, control_point1, control_point2, end_point) @ -- @@ -764,23 +1029,29 @@ bezierArc r ang1 ang2 pt = (p0,p1,p2,p3) where theta = ang2 - ang1 - e = r * fromRadian ((2 * sin (theta/2)) / (1+ 2* cos (theta/2))) + e = r * fromRadian ((2 * sin (theta/2)) / (1+ 2 * cos (theta/2))) p0 = pt .+^ avec ang1 r p1 = p0 .+^ avec (ang1 + pi/2) e p2 = p3 .+^ avec (ang2 - pi/2) e p3 = pt .+^ avec ang2 r --- | 'bezierCircle' : @ subdivisions * radius * center -> [Point] @ +-- | 'subvisionCircle' : @ subdivisions * radius * center -> [Point] @ -- -- Make a circle from Bezier curves - the number of subdivsions -- controls the accuracy or the curve, more subdivisions produce -- better curves, but less subdivisions are better for rendering -- (producing more efficient PostScript). -- -bezierCircle :: (Fractional u, Floating u) - => Int -> u -> Point2 u -> [Point2 u] -bezierCircle n radius pt = start $ subdivisions (n*4) (2*pi) +-- Before revision 0.43.0, this was the only method in Wumpus to +-- draw Bezier circles in Wumpus. However the kappa method seems +-- to draw equally good circles and is more efficient both in the +-- Haskell implementation and the generated PostScript code. This +-- function is retained for completeness and testing. +-- +subdivisionCircle :: (Fractional u, Floating u) + => Int -> u -> Point2 u -> [Point2 u] +subdivisionCircle n radius pt = start $ subdivisions (n*4) (2*pi) where start (a:b:xs) = s : cp1 : cp2 : e : rest (b:xs) where (s,cp1,cp2,e) = bezierArc radius a b pt diff --git a/src/Wumpus/Core/GraphicProps.hs b/src/Wumpus/Core/GraphicProps.hs --- a/src/Wumpus/Core/GraphicProps.hs +++ b/src/Wumpus/Core/GraphicProps.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.GraphicProps --- Copyright : (c) Stephen Tetley 2009-2011 +-- Copyright : (c) Stephen Tetley 2009-2012 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -72,17 +72,63 @@ -- | Line cap - default in output is butt. -- +-- > Cap Butt: +-- +-- > .-------. +-- > |=======| +-- > '-------' +-- +-- > Cap Round: +-- +-- > .-------. +-- > ( ======= ) +-- > '-------' +-- +-- > Cap Square: +-- +-- > .---------. +-- > | ======= | +-- > '---------' +-- data LineCap = CapButt | CapRound | CapSquare deriving (Enum,Eq,Show) -- | Line join - default in output is miter. -- +-- > Join Miter: +-- +-- > /\ +-- > /..\ +-- > /./\.\ +-- > /./ \.\ +-- > /./ \.\ +-- +-- > Join Round: +-- +-- > \.\ +-- > \.\ +-- > ,.) +-- > /./ +-- > /./ +-- +-- > Join Bevel: +-- +-- > __ +-- > /..\ +-- > /./\.\ +-- > /./ \.\ +-- > /./ \.\ +-- data LineJoin = JoinMiter | JoinRound | JoinBevel deriving (Enum,Eq,Show) -- | Dash pattern - either a solid line or a list of on-off pairs -- together with an /offset/ into the dashes. +-- +-- > Solid -- +-- > Dash offset [(on,off )..] +-- data DashPattern = Solid | Dash Int [(Int,Int)] deriving (Eq,Show) @@ -92,8 +138,7 @@ -- font style (e.g. @Times-BoldItalic@) whereas an SVG font has -- a name (the @font-family@ attribute) and a style. -- --- For PostScript, the following fonts are expected to exist on --- most platforms: +-- For PostScript, the following fonts are expected to exist: -- -- > Times-Roman Times-Italic Times-Bold Times-BoldOtalic -- > Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique @@ -108,8 +153,26 @@ } deriving (Eq,Ord,Show) --- | 'FontFace' : @ postscript_name * svg_font_family * svg_font_style @ +-- | 'FontFace' : @ postscript_name * svg_font_family * svg_font_style +-- * encoding_vector @ -- +-- For the writing fonts in the Core 14 set the definitions are: +-- +-- > "Times-Roman" "Times New Roman" SVG_REGULAR standard_encoding +-- > "Times-Italic" "Times New Roman" SVG_ITALIC standard_encoding +-- > "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding +-- > "Times-BoldItalic" "Times New Roman" SVG_BOLD_ITALIC standard_encoding +-- > +-- > "Helvetica" "Helvetica" SVG_REGULAR standard_encoding +-- > "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding +-- > "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding +-- > "Helvetica-Bold-Oblique" "Helvetica" SVG_BOLD_OBLIQUE standard_encoding +-- > +-- > "Courier" "Courier New" SVG_REGULAR standard_encoding +-- > "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding +-- > "Courier-Bold" "Courier New" SVG_BOLD standard_encoding +-- > "Courier-Bold-Oblique" "Courier New" SVG_BOLD_OBLIQUE standard_encoding +-- data FontFace = FontFace { ps_font_name :: String , svg_font_family :: String @@ -139,6 +202,15 @@ -- of the shape. The actual size depends on the thickness -- of the line (stroke width). -- +-- > CFill - closed path filled with the colour. +-- +-- > CStroke - closed path, stroked with the colour. +-- +-- > OStroke - open path, stroked with the colour. +-- +-- > CFillStroke - closed path, filled with the first colour, +-- > stroked with the stroke attributes and second colour. +-- data PathProps = CFill RGBi | CStroke StrokeAttr RGBi | OStroke StrokeAttr RGBi @@ -159,6 +231,13 @@ -- | Ellipses and circles are always closed. -- +-- > EFill - filled ellipse. +-- +-- > EStroke - stroked ellipse. +-- +-- > EFillStroke - ellipse filled with the first colour and stroked +-- > with the stroke attributes and second colour. +-- data EllipseProps = EFill RGBi | EStroke StrokeAttr RGBi -- Note - first colour fill, second colour stroke. @@ -174,7 +253,7 @@ format (CFill rgb) = format rgb <+> text "Fill" format (CStroke _ rgb) = format rgb <+> text "Closed-stroke" format (OStroke _ rgb) = format rgb <+> text "Open-stroke" - format (CFillStroke f _ s) = format f <+> text "Fill" <> char '/' + format (CFillStroke f _ s) = format f <+> text "Fill" >< char '/' <+> format s <+> text "Stroke" @@ -186,13 +265,19 @@ instance Format EllipseProps where format (EFill rgb) = format rgb <+> text "Fill" format (EStroke _ rgb) = format rgb <+> text "Stroke" - format (EFillStroke f _ s) = format f <+> text "Fill" <> char '/' + format (EFillStroke f _ s) = format f <+> text "Fill" >< char '/' <+> format s <+> text "Stroke" -------------------------------------------------------------------------------- -- Defaults -- | Default stroke attributes. +-- +-- > line_width = 1 +-- > miter_limit = 1 +-- > line_cap = CapButt +-- > line_join = JoinMiter +-- > dash_pattern = Solid -- default_stroke_attr :: StrokeAttr default_stroke_attr = StrokeAttr { line_width = 1 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 @@ -4,11 +4,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.PostScript --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Output PostScript - either PostScript (PS) files or @@ -36,7 +36,6 @@ import Wumpus.Core.Text.Base import Wumpus.Core.Text.GlyphNames import Wumpus.Core.TrafoInternal -import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.JoinList hiding ( cons ) import Wumpus.Core.Utils.FormatCombinators @@ -164,8 +163,7 @@ -- | Output a series of pictures to a Postscript file. Each -- picture will be printed on a separate page. -- -writePS :: (Real u, Floating u, PSUnit u) - => FilePath -> [Picture u] -> IO () +writePS :: FilePath -> [Picture] -> IO () writePS filepath pics = getZonedTime >>= \ztim -> writeFile filepath (show $ psDraw ztim pics) @@ -173,8 +171,7 @@ -- The .eps file can then be imported or embedded in another -- document. -- -writeEPS :: (Real u, Floating u, PSUnit u) - => FilePath -> Picture u -> IO () +writeEPS :: FilePath -> Picture -> IO () writeEPS filepath pic = getZonedTime >>= \ztim -> writeFile filepath (show $ epsDraw ztim pic) @@ -193,8 +190,7 @@ -- will need translating. -- -psDraw :: (Real u, Floating u, PSUnit u) - => ZonedTime -> [Picture u] -> Doc +psDraw :: ZonedTime -> [Picture] -> Doc psDraw timestamp pics = let body = vcat $ runPsMonad $ zipWithM psDrawPage pages pics in vcat [ psHeader (length pics) timestamp @@ -208,10 +204,8 @@ -- | Note the bounding box may /below the origin/ - if it is, it -- will need translating. -- -psDrawPage :: (Real u, Floating u, PSUnit u) - => (String,Int) -> Picture u -> PsMonad Doc +psDrawPage :: (String,Int) -> Picture -> PsMonad Doc psDrawPage (lbl,ordinal) pic = - let (_,cmdtrans) = imageTranslation pic in (\doc -> vcat [ dsc_Page lbl ordinal , ps_gsave , cmdtrans @@ -220,27 +214,28 @@ , ps_showpage ]) <$> picture pic - + where + (_,cmdtrans) = imageTranslation pic -- | Note the bounding box may /below the origin/ - if it is, it -- will need translating. -- -epsDraw :: (Real u, Floating u, PSUnit u) - => ZonedTime -> Picture u -> Doc +epsDraw :: ZonedTime -> Picture -> Doc epsDraw timestamp pic = - let (bb,cmdtrans) = imageTranslation pic - body = runPsMonad (picture pic) - in vcat [ epsHeader bb timestamp - , ps_wumpus_prolog - , ps_gsave - , cmdtrans - , body - , ps_grestore - , epsFooter - ] + vcat [ epsHeader bb timestamp + , ps_wumpus_prolog + , ps_gsave + , cmdtrans + , body + , ps_grestore + , epsFooter + ] + where + (bb,cmdtrans) = imageTranslation pic + body = runPsMonad (picture pic) -imageTranslation :: (Ord u, PSUnit u) => Picture u -> (BoundingBox u, Doc) +imageTranslation :: Picture -> (DBoundingBox, Doc) imageTranslation pic = case repositionDeltas pic of (bb, Nothing) -> (bb, empty) (bb, Just v) -> (bb, ps_translate v) @@ -288,20 +283,9 @@ -------------------------------------------------------------------------------- --- 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 :: Picture -> PsMonad Doc picture (Leaf (_,xs) ones) = bracketTrafos xs $ oneConcat primitive ones picture (Picture (_,xs) ones) = bracketTrafos xs $ oneConcat picture ones -picture (Clip (_,xs) cp pic) = bracketTrafos xs $ - (\d1 d2 -> vcat [ps_gsave,d1,d2,ps_grestore]) - <$> clipPath cp <*> picture pic <* resetGS @@ -318,8 +302,16 @@ -- No action is taken for hyperlinks or font context changes in -- PostScript. -- +-- PostScript ignores 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. +-- -primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> PsMonad Doc +primitive :: Primitive -> PsMonad Doc primitive (PPath props pp) | isEmptyPath pp = pure empty | otherwise = primPath props pp @@ -336,9 +328,12 @@ primitive (PGroup ones) = oneConcat primitive ones +primitive (PClip cp chi) = + (\d1 d2 -> vcat [ps_gsave,d1,d2,ps_grestore]) + <$> clipPath cp <*> primitive chi <* resetGS -primPath :: PSUnit u - => PathProps -> PrimPath u -> PsMonad Doc + +primPath :: PathProps -> PrimPath -> PsMonad Doc primPath (CFill rgb) p = (\rgbd -> vcat [rgbd, pathBody p, ps_closepath, ps_fill]) <$> deltaDrawColour rgb @@ -357,13 +352,14 @@ <$> primPath (CFill fc) p <*> primPath (CStroke attrs sc) p -clipPath :: PSUnit u => PrimPath u -> PsMonad Doc +clipPath :: PrimPath -> PsMonad Doc clipPath p = pure $ vcat [pathBody p , ps_closepath, ps_clip] -pathBody :: PSUnit u => PrimPath u -> Doc -pathBody (PrimPath start xs) = - vcat $ ps_newpath : ps_moveto start : (snd $ mapAccumL step start xs) +pathBody :: PrimPath -> Doc +pathBody ppath = + let (start,xs) = extractRelPath ppath + in vcat $ ps_newpath : ps_moveto start : (snd $ mapAccumL step start xs) where step pt (RelLineTo v) = let p1 = pt .+^ v in (p1, ps_lineto p1) step pt (RelCurveTo v1 v2 v3) = let p1 = pt .+^ v1 @@ -384,8 +380,7 @@ -- For good stroked ellipses, Bezier curves constructed from -- PrimPaths should be used. -- -primEllipse :: (Real u, Floating u, PSUnit u) - => EllipseProps -> PrimEllipse u -> PsMonad Doc +primEllipse :: EllipseProps -> PrimEllipse -> PsMonad Doc primEllipse props (PrimEllipse hw hh ctm) | hw == hh = bracketPrimCTM ctm (drawC props) | otherwise = bracketPrimCTM ctm (drawE props) @@ -404,13 +399,12 @@ -- This will need to become monadic to handle /colour delta/. -- -fillEllipse :: PSUnit u => RGBi -> u -> u -> Point2 u -> PsMonad Doc +fillEllipse :: RGBi -> Double -> Double -> DPoint2 -> PsMonad Doc fillEllipse rgb rx ry pt = (\rgbd -> rgbd `vconcat` ps_wumpus_FELL pt rx ry) <$> deltaDrawColour rgb -strokeEllipse :: PSUnit u - => RGBi -> StrokeAttr -> u -> u -> Point2 u -> PsMonad Doc +strokeEllipse :: RGBi -> StrokeAttr -> Double -> Double -> DPoint2 -> PsMonad Doc strokeEllipse rgb sa rx ry pt = (\rgbd attrd -> vcat [ rgbd , attrd @@ -420,13 +414,12 @@ -- This will need to become monadic to handle /colour delta/. -- -fillCircle :: PSUnit u => RGBi -> u -> Point2 u -> PsMonad Doc +fillCircle :: RGBi -> Double -> DPoint2 -> PsMonad Doc fillCircle rgb r pt = (\rgbd -> rgbd `vconcat` ps_wumpus_FCIRC pt r) <$> deltaDrawColour rgb -strokeCircle :: PSUnit u - => RGBi -> StrokeAttr -> u -> Point2 u -> PsMonad Doc +strokeCircle :: RGBi -> StrokeAttr -> Double -> DPoint2 -> PsMonad Doc strokeCircle rgb sa r pt = (\rgbd attrd -> vcat [ rgbd , attrd @@ -437,9 +430,8 @@ -- Note - for the otherwise case, the x-and-y coordinates are -- encoded in the matrix, hence the @ 0 0 moveto @. -- -primLabel :: (Real u, Floating u, PSUnit u) - => LabelProps -> PrimLabel u -> PsMonad Doc -primLabel (LabelProps rgb attrs) (PrimLabel body ctm) = bracketPrimCTM ctm mf +primLabel :: LabelProps -> PrimLabel -> PsMonad Doc +primLabel (LabelProps rgb attrs) (PrimLabel body _ ctm) = bracketPrimCTM ctm mf where ev = font_enc_vector $ font_face attrs mf pt = (\rgbd fontd -> vcat [ rgbd, fontd, labelBody ev pt body ]) @@ -466,15 +458,13 @@ -- -labelBody :: PSUnit u - => EncodingVector -> Point2 u -> LabelBody u -> Doc +labelBody :: EncodingVector -> DPoint2 -> LabelBody -> Doc labelBody ev pt (StdLayout txt) = ps_moveto pt `vconcat` psText ev txt labelBody ev pt (KernTextH xs) = kernTextH ev pt xs labelBody ev pt (KernTextV xs) = kernTextV ev pt xs -- -kernTextH :: PSUnit u - => EncodingVector -> Point2 u -> [KerningChar u] -> Doc +kernTextH :: EncodingVector -> DPoint2 -> [KerningChar] -> Doc kernTextH ev pt0 xs = snd $ F.foldl' fn (pt0,empty) xs where fn (P2 x y,acc) (dx,ch) = let doc1 = psChar ev ch @@ -484,8 +474,7 @@ -- Note - vertical labels grow downwards... -- -kernTextV :: PSUnit u - => EncodingVector -> Point2 u -> [KerningChar u] -> Doc +kernTextV :: EncodingVector -> DPoint2 -> [KerningChar] -> Doc kernTextV ev pt0 xs = snd $ F.foldl' fn (pt0,empty) xs where fn (P2 x y,acc) (dy,ch) = let doc1 = psChar ev ch @@ -568,12 +557,10 @@ -------------------------------------------------------------------------------- -- Bracket matrix and PrimCTM trafos -bracketTrafos :: (Real u, Floating u, PSUnit u) - => [AffineTrafo u] -> PsMonad Doc -> PsMonad Doc +bracketTrafos :: [AffineTrafo] -> PsMonad Doc -> PsMonad Doc bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma -bracketMatrix :: (Fractional u, PSUnit u) - => Matrix3'3 u -> PsMonad Doc -> PsMonad Doc +bracketMatrix :: Matrix3'3 Double -> PsMonad Doc -> PsMonad Doc bracketMatrix mtrx ma | mtrx == identityMatrix = ma | otherwise = (\doc -> vcat [inn, doc, out]) <$> ma @@ -582,16 +569,15 @@ out = ps_concat $ invert mtrx -bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u) - => PrimCTM u - -> (Point2 u -> PsMonad Doc) -> PsMonad Doc +bracketPrimCTM :: PrimCTM -> (DPoint2 -> PsMonad Doc) -> PsMonad Doc bracketPrimCTM ctm0 mf = step $ unCTM ctm0 where - step (pt,ctm) - | ctm == identityCTM = mf pt + step (p0,ctm) + | ctm == identityCTM = mf p0 | otherwise = let mtrx = matrixRepCTM ctm0 -- originalCTM inn = ps_concat $ mtrx out = ps_concat $ invert mtrx in (\doc -> vcat [inn, doc, out]) <$> mf zeroPt + 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 @@ -4,26 +4,24 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.OutputSVG --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2012 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Output SVG. -- --- This is complicated by two differences with PostScript. +-- Note - the coordinate systems of Wumpus and SVG are different. -- --- 1. The coordinate space of SVG is /origin top-left/, for --- PostScript it is /origin bottom-left/. --- --- 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)\"@. +-- > Wumpus - (0,0) is bottom-left. -- +-- > SVG - (0,0) is top-left. -- +-- To accommodate this, Wumpus adds rectifying matrix +-- transformations to the generated SVG code. +-- -------------------------------------------------------------------------------- module Wumpus.Core.OutputSVG @@ -47,7 +45,6 @@ import Wumpus.Core.TrafoInternal import Wumpus.Core.Text.Base import Wumpus.Core.Text.GlyphIndices -import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators import Wumpus.Core.Utils.JoinList @@ -59,6 +56,21 @@ import qualified Data.Map as Map import Data.Maybe + +-- DESIGN NOTE +-- +-- SVG output is complicated by two differences with PostScript. +-- +-- 1. The coordinate space of SVG is /origin top-left/, for +-- PostScript it is /origin bottom-left/. +-- +-- 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)\"@. +-- + + -- SvgMonad is two Readers plus Int state for clip paths... -- @@ -109,9 +121,9 @@ asksGraphicsState :: (GraphicsState -> a) -> SvgMonad a asksGraphicsState fn = fmap fn askGraphicsState -askFontAttr :: SvgMonad FontAttr -askFontAttr = asksGraphicsState $ \r -> - FontAttr (gs_font_size r) (gs_font_face r) +askFontAttr :: SvgMonad FontAttr +askFontAttr = asksGraphicsState $ \r -> + FontAttr (gs_font_size r) (gs_font_face r) askLineWidth :: SvgMonad Double askLineWidth = asksGraphicsState (line_width . gs_stroke_attr) @@ -143,26 +155,28 @@ -- | Output a picture to a SVG file. -- -writeSVG :: (Real u, Floating u, PSUnit u) - => FilePath -> Picture u -> IO () +writeSVG :: FilePath -> Picture -> IO () writeSVG filepath pic = writeFile filepath $ show $ svgDraw Nothing pic + + -- | 'writeSVG_defs' : @ file_name -> defs -> picture -> IO () @ -- -- Output a picture to a SVG file the supplied /defs/ are -- written into the defs section of SVG file verbatim. -- -writeSVG_defs :: (Real u, Floating u, PSUnit u) - => FilePath -> String -> Picture u -> IO () +-- This is considered an experimental feature, use 'writeSVG' +-- instead. +-- +writeSVG_defs :: FilePath -> String -> Picture -> IO () writeSVG_defs filepath ss pic = writeFile filepath $ show $ svgDraw (Just ss) pic -svgDraw :: (Real u, Floating u, PSUnit u) - => Maybe String -> Picture u -> Doc +svgDraw :: Maybe String -> Picture -> Doc svgDraw mb_defs original_pic = - let pic = trivialTranslation original_pic + let pic = svgPageTranslation original_pic (_,imgTrafo) = imageTranslation pic body = runSvgMonad $ picture pic mkSvg = maybe elem_svg elem_svg_defs mb_defs @@ -170,8 +184,7 @@ -imageTranslation :: (Ord u, PSUnit u) - => Picture u -> (BoundingBox u, Doc -> Doc) +imageTranslation :: Picture -> (DBoundingBox, Doc -> Doc) imageTranslation pic = case repositionDeltas pic of (bb, Nothing) -> (bb, id) (bb, Just v) -> let attr = attr_transform (val_translate v) @@ -179,20 +192,13 @@ -------------------------------------------------------------------------------- +-- Note - might be simpler to only print a @Picture Double@ -picture :: (Real u, Floating u, PSUnit u) => Picture u -> SvgMonad Doc +picture :: Picture -> SvgMonad Doc picture (Leaf (_,xs) ones) = bracketTrafos xs $ oneConcat primitive ones picture (Picture (_,xs) ones) = bracketTrafos xs $ oneConcat picture ones -picture (Clip (_,xs) cp pic) = - bracketTrafos xs $ do { lbl <- newClipLabel - ; let d1 = clipPath lbl cp - ; d2 <- picture pic - ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2)) - } - - oneConcat :: (a -> SvgMonad Doc) -> JoinList a -> SvgMonad Doc oneConcat fn ones = outstep (viewl ones) where @@ -203,7 +209,7 @@ instep ac (e :< rest) = fn e >>= \a -> instep (ac `vconcat` a) (viewl rest) -primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc +primitive :: Primitive -> SvgMonad Doc primitive (PPath props pp) | isEmptyPath pp = pure empty | otherwise = primPath props pp @@ -219,12 +225,22 @@ primitive (PSVG anno chi) = svgAnnoPrim anno <$> primitive chi primitive (PGroup ones) = oneConcat primitive ones + +primitive (PClip cp chi) = do + { lbl <- newClipLabel + ; let d1 = clipPath lbl cp + ; d2 <- primitive chi + ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2)) + } + + svgAnnoPrim :: SvgAnno -> Doc -> Doc svgAnnoPrim (ALink hypl) d = drawXLink hypl d svgAnnoPrim (GAnno xs) d = drawGProps xs d svgAnnoPrim (SvgAG hypl xs) d = drawXLink hypl $ drawGProps xs d +svgAnnoPrim (SvgId ss) d = drawGProps [SvgAttr "id" ss] d drawXLink :: XLink -> Doc -> Doc @@ -239,12 +255,12 @@ svgAttribute :: SvgAttr -> Doc svgAttribute (SvgAttr n v) = svgAttr n $ text v -clipPath :: PSUnit u => String -> PrimPath u -> Doc +clipPath :: String -> PrimPath -> Doc clipPath clip_id pp = elem_clipPath (attr_id clip_id) (elem_path_no_attrs $ path pp) -primPath :: PSUnit u => PathProps -> PrimPath u -> SvgMonad Doc +primPath :: PathProps -> PrimPath -> SvgMonad Doc primPath props pp = (\(a,f) -> elem_path a (f $ path pp)) <$> pathProps props -- @@ -259,9 +275,10 @@ -- an encouragement to change when it moved to relative ones. -- -path :: PSUnit u => PrimPath u -> Doc -path (PrimPath start xs) = - path_m start <+> hsep (snd $ mapAccumL step start xs) +path :: PrimPath -> Doc +path ppath = + let (start,xs) = extractRelPath ppath + in path_m start <+> hsep (snd $ mapAccumL step start xs) where step pt (RelLineTo v) = let p1 = pt .+^ v in (p1, path_l p1) step pt (RelCurveTo v1 v2 v3) = let p1 = pt .+^ v1 @@ -296,18 +313,17 @@ -- Note - if hw==hh then draw the ellipse as a circle. -- -primEllipse :: (Real u, Floating u, PSUnit u) - => EllipseProps -> PrimEllipse u -> SvgMonad Doc +primEllipse :: EllipseProps -> PrimEllipse -> SvgMonad Doc primEllipse props (PrimEllipse hw hh ctm) | hw == hh = (\a b -> elem_circle (a <+> circle_radius <+> b)) <$> bracketEllipseCTM ctm mkCXCY <*> ellipseProps props | otherwise = (\a b -> elem_ellipse (a <+> ellipse_radius <+> b)) <$> bracketEllipseCTM ctm mkCXCY <*> ellipseProps props where - mkCXCY (P2 x y) = pure $ attr_cx x <+> attr_cy y + mkCXCY (P2 x y) = pure $ attr_cx x <+> attr_cy y - circle_radius = attr_r hw - ellipse_radius = attr_rx hw <+> attr_ry hh + circle_radius = attr_r hw + ellipse_radius = attr_rx hw <+> attr_ry hh @@ -323,29 +339,28 @@ --- Note - Rendering coloured text seemed convoluted --- (mandating the tspan element). +-- Note - SVG rendering coloured text seemed convoluted +-- mandating the tspan element in the output. -- -- TO CHECK - is this really the case? -- -- -primLabel :: (Real u, Floating u, PSUnit u) - => LabelProps -> PrimLabel u -> SvgMonad Doc -primLabel (LabelProps rgb attrs) (PrimLabel body ctm) = - (\fa ca -> elem_text (fa <+> ca) (makeTspan rgb dtext)) +primLabel :: LabelProps -> PrimLabel -> SvgMonad Doc +primLabel (LabelProps rgb attrs) (PrimLabel body opt_id ctm) = + (\fa ca -> elem_text (id_f $ fa <+> ca) (makeTspan rgb dtext)) <$> deltaFontAttrs attrs <*> bracketTextCTM ctm coordf - where coordf = \p0 -> pure $ labelBodyCoords body p0 dtext = labelBodyText body + id_f = maybe id (\xid -> (svgAttr "id" (text xid) <+>)) $ opt_id -labelBodyCoords :: PSUnit u => LabelBody u -> Point2 u -> Doc +labelBodyCoords :: LabelBody -> DPoint2 -> Doc labelBodyCoords (StdLayout _) pt = makeXY pt labelBodyCoords (KernTextH xs) pt = makeXsY pt xs labelBodyCoords (KernTextV xs) pt = makeXYs pt xs -labelBodyText :: LabelBody u -> Doc +labelBodyText :: LabelBody -> Doc labelBodyText (StdLayout enctext) = encodedText enctext labelBodyText (KernTextH xs) = kerningText xs labelBodyText (KernTextV xs) = kerningText xs @@ -354,7 +369,7 @@ encodedText :: EscapedText -> Doc encodedText enctext = hcat $ destrEscapedText (map svgChar) enctext -kerningText :: [KerningChar u] -> Doc +kerningText :: [KerningChar] -> Doc kerningText xs = hcat $ map (\(_,c) -> svgChar c) xs @@ -362,7 +377,7 @@ makeTspan :: RGBi -> Doc -> Doc makeTspan rgb body = elem_tspan (attr_fill rgb) body -makeXY :: PSUnit u => Point2 u -> Doc +makeXY :: DPoint2 -> Doc makeXY (P2 x y) = attr_x x <+> attr_y y -- This is for horizontal kerning text, the output is of the @@ -370,7 +385,7 @@ -- -- > x="0 10 25 35" y="0" -- -makeXsY :: PSUnit u => Point2 u -> [KerningChar u] -> Doc +makeXsY :: DPoint2 -> [KerningChar] -> 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 @@ -385,7 +400,7 @@ -- 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 :: DPoint2 -> [KerningChar] -> Doc makeXYs (P2 x y) ks = attr_xs xcoords <+> attr_ys (step y ks) where xcoords = replicate (length ks) x @@ -457,21 +472,21 @@ makeFontAttrs :: FontAttr -> Doc makeFontAttrs (FontAttr sz face) = attr_font_family (svg_font_family face) <+> attr_font_size sz - <> suffix (svg_font_style face) + >< suffix (svg_font_style face) where suffix SVG_REGULAR = empty - suffix SVG_BOLD = space <> attr_font_weight "bold" + suffix SVG_BOLD = space >< attr_font_weight "bold" - suffix SVG_ITALIC = space <> attr_font_style "italic" + suffix SVG_ITALIC = space >< attr_font_style "italic" suffix SVG_BOLD_ITALIC = - space <> attr_font_weight "bold" <+> attr_font_style "italic" + space >< attr_font_weight "bold" <+> attr_font_style "italic" - suffix SVG_OBLIQUE = space <> attr_font_style "oblique" + suffix SVG_OBLIQUE = space >< attr_font_style "oblique" suffix SVG_BOLD_OBLIQUE = - space <> attr_font_weight "bold" <+> attr_font_style "oblique" + space >< attr_font_weight "bold" <+> attr_font_style "oblique" @@ -496,15 +511,13 @@ -------------------------------------------------------------------------------- -- Bracket matrix and PrimCTM trafos -bracketTrafos :: (Real u, Floating u, PSUnit u) - => [AffineTrafo u] -> SvgMonad Doc -> SvgMonad Doc +bracketTrafos :: [AffineTrafo] -> SvgMonad Doc -> SvgMonad Doc bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma -bracketMatrix :: (Fractional u, PSUnit u) - => Matrix3'3 u -> SvgMonad Doc -> SvgMonad Doc +bracketMatrix :: Matrix3'3 Double -> SvgMonad Doc -> SvgMonad Doc bracketMatrix mtrx ma - | mtrx == identityMatrix = (\doc -> elem_g_no_attrs doc) <$> ma - | otherwise = (\doc -> elem_g trafo doc) <$> ma + | mtrx == identityMatrix = (\doc -> elem_g_no_attrs doc) <$> ma + | otherwise = (\doc -> elem_g trafo doc) <$> ma where trafo = attr_transform $ val_matrix mtrx @@ -520,33 +533,33 @@ -- rectifying flip transformation /if/ the ellipse or circle has -- not been scaled or rotated. -- -bracketTextCTM :: forall u. (Real u, Floating u, PSUnit u) - => PrimCTM u - -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc +bracketTextCTM :: PrimCTM -> (DPoint2 -> SvgMonad Doc) -> SvgMonad Doc bracketTextCTM ctm0 pf = (\xy -> xy <+> mtrx) <$> pf zeroPt where mtrx = attr_transform $ val_matrix $ matrixRepCTM ctm0 + -- Note - the otherwise step uses the original ctm (ctm0). -- -- Note v0.41.0 otherwise step always fires because the matrix -- has been transformed for SVG coordspace to [1,0,0,-1]. -- -bracketEllipseCTM :: forall u. (Real u, Floating u, PSUnit u) - => PrimCTM u - -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc +bracketEllipseCTM :: PrimCTM -> (DPoint2 -> SvgMonad Doc) -> SvgMonad Doc bracketEllipseCTM ctm0 pf = step $ unCTM ctm0 where - step (pt, ctm) - | ctm == flippedCTM = pf pt + step (p0, ctm) + | ctm == flippedCTM = pf p0 | otherwise = let mtrx = attr_transform $ val_matrix $ matrixRepCTM ctm0 in (\xy -> xy <+> mtrx) <$> pf zeroPt -flippedCTM :: Num u => PrimCTM u -flippedCTM = PrimCTM { ctm_transl_x = 0, ctm_transl_y = 0 - , ctm_scale_x = 1, ctm_scale_y = (-1) - , ctm_rotation = 0 } +flippedCTM :: PrimCTM +flippedCTM = PrimCTM { ctm_trans_x = 0 + , ctm_trans_y = 0 + , ctm_scale_x = 1 + , ctm_scale_y = (-1) + , ctm_rotation = 0 + } diff --git a/src/Wumpus/Core/PageTranslation.hs b/src/Wumpus/Core/PageTranslation.hs --- a/src/Wumpus/Core/PageTranslation.hs +++ b/src/Wumpus/Core/PageTranslation.hs @@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.PageTranslation --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Core page translation for SVG. @@ -22,8 +22,7 @@ module Wumpus.Core.PageTranslation ( - - trivialTranslation + svgPageTranslation ) where @@ -31,7 +30,6 @@ import Wumpus.Core.PictureInternal import Wumpus.Core.TrafoInternal - -------------------------------------------------------------------------------- -- trivial translation @@ -40,32 +38,42 @@ -- worry about scaling the BoundingBox -- -trivialTranslation :: (Num u, Ord u) => Picture u -> Picture u -trivialTranslation pic = scale 1 (-1) (trivPic pic) -trivPic :: Num u => Picture u -> Picture u -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 -trivPrim :: Num u => Primitive u -> Primitive u + +svgPageTranslation :: Picture -> Picture +svgPageTranslation pic = scale 1 (-1) (trivPic pic) + + + +trivPic :: Picture -> Picture +trivPic (Leaf lc ones) = Leaf lc (fmap trivPrim ones) +trivPic (Picture lc ones) = Picture lc (fmap trivPic ones) + + +-- | Path is unchanged because it is drawn directly in the output +-- and thus doesn\'t need a rectifying transformation. +-- +trivPrim :: Primitive -> Primitive trivPrim (PPath a pp) = PPath a pp trivPrim (PLabel a lbl) = PLabel a (trivLabel lbl) trivPrim (PEllipse a ell) = PEllipse a (trivEllipse ell) trivPrim (PContext a chi) = PContext a (trivPrim chi) trivPrim (PSVG a chi) = PSVG a (trivPrim chi) trivPrim (PGroup ones) = PGroup $ fmap trivPrim ones +trivPrim (PClip pp chi) = PClip pp (trivPrim chi) -trivLabel :: Num u => PrimLabel u -> PrimLabel u -trivLabel (PrimLabel txt ctm) = PrimLabel txt (trivPrimCTM ctm) -trivEllipse :: Num u => PrimEllipse u -> PrimEllipse u +trivLabel :: PrimLabel -> PrimLabel +trivLabel (PrimLabel txt opt_id ctm) = + PrimLabel txt opt_id (trivPrimCTM ctm) + +trivEllipse :: PrimEllipse -> PrimEllipse trivEllipse (PrimEllipse hw hh ctm) = PrimEllipse hw hh (trivPrimCTM ctm) --- Is the translation here just negating the angle with scaling --- left untouched? +-- Negate the y scaling to flip the image. -- -trivPrimCTM :: Num u => PrimCTM u -> PrimCTM u -trivPrimCTM (PrimCTM dx dy sx sy theta) = PrimCTM dx dy sx (-sy) theta +trivPrimCTM :: PrimCTM -> PrimCTM +trivPrimCTM (PrimCTM dx dy sx sy theta) = PrimCTM dx dy sx (negate sy) theta 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 @@ -1,5 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -8,8 +7,8 @@ -- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Construction of pictures, paths and text labels. @@ -39,15 +38,19 @@ frame , multi , fontDeltaContext - , primPath - , lineTo - , curveTo - , vertexPath - , vectorPath - , emptyPath - , curvedPath + , absPrimPath + , absLineTo + , absCurveTo + , relPrimPath + , relLineTo + , relCurveTo + , vertexPrimPath + , vectorPrimPath + , emptyPrimPath + , curvedPrimPath , xlinkhref - , xlink + , xlinkPrim + , xidPrim , svgattr , annotateGroup , annotateXLink @@ -66,7 +69,7 @@ , zfill , fillStroke - , clip + , clipPrim , textlabel , rtextlabel @@ -112,10 +115,9 @@ import Wumpus.Core.Geometry import Wumpus.Core.GraphicProps import Wumpus.Core.PictureInternal -import Wumpus.Core.PtSize import Wumpus.Core.Text.Base import Wumpus.Core.TrafoInternal -import Wumpus.Core.Utils.Common +-- import Wumpus.Core.Units import Wumpus.Core.Utils.FormatCombinators hiding ( fill ) import Wumpus.Core.Utils.HList import Wumpus.Core.Utils.JoinList @@ -133,13 +135,13 @@ -- -- The order of the list maps to the order of printing - the -- front of the list is drawn first in the file. This also means --- that the front of the list is drawn /at the back/ in the +-- that the front of the list is drawn /underneath/ in the -- Z-Order. -- -- \*\* WARNING \*\* - this function throws a runtime error when -- supplied the empty list. -- -frame :: (Real u, Floating u, FromPtSize u) => [Primitive u] -> Picture u +frame :: [Primitive] -> Picture frame [] = error "Wumpus.Core.Picture.frame - empty list" frame (p:ps) = let (bb,ones) = step p ps in Leaf (bb,[]) ones where @@ -154,7 +156,7 @@ -- \*\* WARNING \*\* - this function throws a runtime error when -- supplied the empty list. -- -multi :: (Fractional u, Ord u) => [Picture u] -> Picture u +multi :: [Picture] -> Picture multi [] = error "Wumpus.Core.Picture.multi - empty list" multi (p:ps) = let (bb,ones) = step p ps in Picture (bb,[]) ones where @@ -191,16 +193,17 @@ -- introducing nesting with @gsave@ and @grestore@ is not likely -- to improve the PostScript Wumpus generates. -- -fontDeltaContext :: FontAttr -> Primitive u -> Primitive u +fontDeltaContext :: FontAttr -> Primitive -> Primitive fontDeltaContext fa p = PContext (FontCtx fa) p --- | 'primPath' : @ start_point * [path_segment] -> PrimPath @ +-- | 'absPrimPath' : @ start_point * [abs_path_segment] -> PrimPath @ -- --- Create a Path from a start point and a list of PathSegments. +-- Create a 'PrimPath' from a start point and a list of /absolute/ +-- path segments. -- -primPath :: Num u => Point2 u -> [AbsPathSegment u] -> PrimPath u -primPath pt xs = PrimPath pt $ step pt xs +absPrimPath :: DPoint2 -> [AbsPathSegment] -> PrimPath +absPrimPath pt xs = PrimPath (step pt xs) (startPointCTM pt) where step p (AbsLineTo p1:rest) = RelLineTo (p1 .-. p) : step p1 rest step p (AbsCurveTo p1 p2 p3:rest) = @@ -209,42 +212,76 @@ step _ [] = [] + --- | 'lineTo' : @ end_point -> path_segment @ +-- | 'absLineTo' : @ end_point -> path_segment @ -- --- Create a straight-line PathSegment, the start point is +-- Create a straight-line 'AbsPathSegment', the start point is -- implicitly the previous point in a path. -- -lineTo :: Point2 u -> AbsPathSegment u -lineTo = AbsLineTo +absLineTo :: DPoint2 -> AbsPathSegment +absLineTo = AbsLineTo --- | 'curveTo' : @ control_point1 * control_point2 * end_point -> +-- | 'absCurveTo' : @ control_point1 * control_point2 * end_point -> -- path_segment @ -- --- Create a curved PathSegment, the start point is implicitly the --- previous point in a path. +-- Create a curved 'AbsPathSegment', the start point is implicitly +-- the previous point in a path. -- -- -curveTo :: Point2 u -> Point2 u -> Point2 u -> AbsPathSegment u -curveTo = AbsCurveTo +absCurveTo :: DPoint2 -> DPoint2 -> DPoint2 -> AbsPathSegment +absCurveTo = AbsCurveTo --- | 'vertexPath' : @ [point] -> PrimPath @ +-- | 'relPrimPath' : @ start_point * [rel_path_segment] -> PrimPath @ +-- +-- Create a 'PrimPath' from a start point and a list of /relative/ +-- path segments. +-- +-- Note - internally Wumpus works with relative paths so +-- constructing them directly with 'relPrimPath' is more efficient +-- than using 'absPrimPath'. +-- +relPrimPath :: DPoint2 -> [PrimPathSegment] -> PrimPath +relPrimPath pt xs = PrimPath xs (startPointCTM pt) + + + +-- | 'relLineTo' : @ vec_to_end -> path_segment @ -- +-- Create a straight-line 'PrimPathSegment', the vector is the +-- relative displacement. +-- +relLineTo :: DVec2 -> PrimPathSegment +relLineTo = RelLineTo + +-- | 'relCurveTo' : @ vec_to_cp1 * vec_to_cp2 * vec_to_end -> +-- path_segment @ +-- +-- Create a curved 'RelPathSegment'. +-- +-- +relCurveTo :: DVec2 -> DVec2 -> DVec2 -> PrimPathSegment +relCurveTo = RelCurveTo + + +-- | 'vertexPrimPath' : @ [point] -> PrimPath @ +-- -- Convert the list of vertices to a path of straight line -- segments. -- -- \*\* WARNING \*\* - this function throws a runtime error when -- supplied the empty list. -- -vertexPath :: Num u => [Point2 u] -> PrimPath u -vertexPath [] = error "Picture.vertexPath - empty point list" -vertexPath (x:xs) = PrimPath x $ snd $ mapAccumL step x xs +vertexPrimPath :: [DPoint2] -> PrimPath +vertexPrimPath [] = error "Picture.vertexPath - empty point list" +vertexPrimPath (x:xs) = + PrimPath (snd $ mapAccumL step x xs) (startPointCTM x) where step a b = let v = b .-. a in (b, RelLineTo v) --- | 'vectorPath' : @ start_point -> [next_vector] -> PrimPath @ +-- | 'vectorPrimPath' : @ start_point -> [next_vector] -> PrimPath @ -- -- Build a \"relative\" path from the start point, appending -- successive straight line segments formed from the list of @@ -253,22 +290,22 @@ -- This function can be supplied with an empty list - this -- simulates a null graphic. -- -vectorPath :: Num u => Point2 u -> [Vec2 u] -> PrimPath u -vectorPath pt xs = PrimPath pt $ map RelLineTo xs +vectorPrimPath :: DPoint2 -> [DVec2] -> PrimPath +vectorPrimPath pt xs = PrimPath (map RelLineTo xs) (startPointCTM pt) --- | 'emptyPath' : @ start_point -> PrimPath @ +-- | 'emptyPrimPath' : @ start_point -> PrimPath @ -- -- Build an empty path. The start point must be specified even -- though the path is not drawn - a start point is the minimum -- information needed to calculate a bounding box. -- -emptyPath :: Num u => Point2 u -> PrimPath u -emptyPath pt = PrimPath pt [] +emptyPrimPath :: DPoint2 -> PrimPath +emptyPrimPath pt = PrimPath [] (startPointCTM pt) --- | 'curvedPath' : @ points -> PrimPath @ +-- | 'curvedPrimPath' : @ points -> PrimPath @ -- -- Convert a list of vertices to a path of curve segments. -- The first point in the list makes the start point, each curve @@ -278,28 +315,47 @@ -- \*\* WARNING - this function throws an error when supplied the -- empty list. -- -curvedPath :: Num u => [Point2 u] -> PrimPath u -curvedPath [] = error "Picture.curvedPath - empty point list" -curvedPath (x:xs) = PrimPath x $ step x xs +curvedPrimPath :: [DPoint2] -> PrimPath +curvedPrimPath [] = error "Picture.curvedPath - empty point list" +curvedPrimPath (x:xs) = PrimPath (step x xs) (startPointCTM x) where step p (a:b:c:ys) = let v1 = a .-. p v2 = b .-. a - v3 = c .-. a + v3 = c .-. b in RelCurveTo v1 v2 v3 : step c ys step _ _ = [] + -- | Create a hyperlink for SVG output. -- +-- Note - hyperlinks are ignored in the PostScript output. +-- xlinkhref :: String -> XLink xlinkhref = XLink --- | Create a hyperlinked Primitive. +-- | Hyperlinked Primitive. -- -xlink :: XLink -> Primitive u -> Primitive u -xlink hypl p = PSVG (ALink hypl) p +-- This encloses the Primitive in an addition @\@ element. +-- +-- Note - hyperlinks are ignored in the PostScript output. +-- +xlinkPrim :: XLink -> Primitive -> Primitive +xlinkPrim hypl p = PSVG (ALink hypl) p +-- | Annotate a Primitive with an @id@. +-- +-- For text labels this annotates the label directly, for other +-- primitives the annotation adds extra nesting with a @\@ +-- element. +-- +-- Note - ids are ignored in the PostScript output. +-- +xidPrim :: String -> Primitive -> Primitive +xidPrim = pushXIdAnno + + -- | Create an attribute for SVG output. -- -- Attributes are expected to be /non-graphical/ e.g. @onclick@ @@ -324,7 +380,7 @@ -- The primitive will be printed in a @g@ (group) element -- labelled with the annotations. -- -annotateGroup :: [SvgAttr] -> Primitive u -> Primitive u +annotateGroup :: [SvgAttr] -> Primitive -> Primitive annotateGroup xs p = PSVG (GAnno xs) p @@ -333,7 +389,7 @@ -- The primitive will be printed in a @g@ (group) element, itself -- inside an @a@ link. -- -annotateXLink :: XLink -> [SvgAttr] -> Primitive u -> Primitive u +annotateXLink :: XLink -> [SvgAttr] -> Primitive -> Primitive annotateXLink hypl xs p = PSVG (SvgAG hypl xs) p @@ -343,7 +399,7 @@ -- \*\* WARNING \*\* - this function throws a runtime error when -- supplied the empty list. -- -primGroup :: [Primitive u] -> Primitive u +primGroup :: [Primitive] -> Primitive primGroup [] = error "Picture.primGroup - empty prims list" primGroup (x:xs) = PGroup (step x xs) where @@ -365,7 +421,7 @@ -- 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 :: Primitive -> Primitive -> Primitive 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 @@ -380,19 +436,17 @@ -- | 'ostroke' : @ rgb * stroke_attr * path -> Primitive @ -- --- Create a open, stroked path. +-- Create an open, stroked path from the 'PrimPath' specification. -- -ostroke :: Num u - => RGBi -> StrokeAttr -> PrimPath u -> Primitive u +ostroke :: RGBi -> StrokeAttr -> PrimPath -> Primitive ostroke rgb sa p = PPath (OStroke sa rgb) p -- | 'cstroke' : @ rgb * stroke_attr * path -> Primitive @ -- --- Create a closed, stroked path. +-- Create a closed, stroked path from the 'PrimPath' specfication. -- -cstroke :: Num u - => RGBi -> StrokeAttr -> PrimPath u -> Primitive u +cstroke :: RGBi -> StrokeAttr -> PrimPath -> Primitive cstroke rgb sa p = PPath (CStroke sa rgb) p @@ -401,7 +455,7 @@ -- Create an open, stroked path using the default stroke -- attributes and coloured black. -- -zostroke :: Num u => PrimPath u -> Primitive u +zostroke :: PrimPath -> Primitive zostroke = ostroke black default_stroke_attr -- | 'zcstroke' : @ path -> Primitive @ @@ -409,7 +463,7 @@ -- Create a closed stroked path using the default stroke -- attributes and coloured black. -- -zcstroke :: Num u => PrimPath u -> Primitive u +zcstroke :: PrimPath -> Primitive zcstroke = cstroke black default_stroke_attr -------------------------------------------------------------------------------- @@ -418,15 +472,16 @@ -- | 'fill' : @ rgb * path -> Primitive @ -- --- Create a filled path. +-- Create a filled path from the 'PrimPath' specification. -- -fill :: Num u => RGBi -> PrimPath u -> Primitive u +fill :: RGBi -> PrimPath -> Primitive fill rgb p = PPath (CFill rgb) p -- | 'zfill' : @ path -> Primitive @ -- --- Create a filled path coloured black. -zfill :: Num u => PrimPath u -> Primitive u +-- Draw a filled path coloured black. +-- +zfill :: PrimPath -> Primitive zfill = fill black @@ -439,8 +494,7 @@ -- Create a closed path that is both filled and stroked (the fill -- is below in the zorder). -- -fillStroke :: Num u - => RGBi -> StrokeAttr -> RGBi -> PrimPath u -> Primitive u +fillStroke :: RGBi -> StrokeAttr -> RGBi -> PrimPath -> Primitive fillStroke frgb sa srgb p = PPath (CFillStroke frgb sa srgb) p @@ -449,12 +503,12 @@ -------------------------------------------------------------------------------- -- Clipping --- | 'clip' : @ path * picture -> Picture @ +-- | 'clipPrim' : @ path * primitive -> Primitive @ -- --- Clip a picture with respect to the supplied path. +-- Clip a primitive to be inside the supplied path. -- -clip :: (Num u, Ord u) => PrimPath u -> Picture u -> Picture u -clip cp p = Clip (pathBoundary cp, []) cp p +clipPrim :: PrimPath -> Primitive -> Primitive +clipPrim cp p = PClip cp p -------------------------------------------------------------------------------- -- Labels to primitive @@ -469,11 +523,10 @@ -- -- The supplied point is the left baseline. -- -textlabel :: Num u - => RGBi -> FontAttr -> String -> Point2 u -> Primitive u +textlabel :: RGBi -> FontAttr -> String -> DPoint2 -> Primitive textlabel rgb attr txt pt = rtextlabel rgb attr txt 0 pt --- | 'rtextlabel' : @ rgb * font_attr * string * rotation * +-- | 'rtextlabel' : @ rgb * font_attr * string * theta * -- baseline_left -> Primitive @ -- -- Create a text label rotated by the supplied angle about the @@ -481,8 +534,7 @@ -- -- The supplied point is the left baseline. -- -rtextlabel :: Num u - => RGBi -> FontAttr -> String -> Radian -> Point2 u -> Primitive u +rtextlabel :: RGBi -> FontAttr -> String -> Radian -> DPoint2 -> Primitive rtextlabel rgb attr txt pt theta = rescapedlabel rgb attr (escapeString txt) pt theta @@ -492,7 +544,7 @@ -- 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 :: String -> DPoint2 -> Primitive ztextlabel = textlabel black wumpus_default_font @@ -505,11 +557,10 @@ -- -- The supplied point is the left baseline. -- -escapedlabel :: Num u - => RGBi -> FontAttr -> EscapedText -> Point2 u -> Primitive u +escapedlabel :: RGBi -> FontAttr -> EscapedText -> DPoint2 -> Primitive escapedlabel rgb attr txt pt = rescapedlabel rgb attr txt 0 pt --- | 'rescapedlabel' : @ rgb * font_attr * escaped_text * rotation * +-- | 'rescapedlabel' : @ rgb * font_attr * escaped_text * theta * -- baseline_left -> Primitive @ -- -- Version of 'rtextlabel' where the label text has already been @@ -517,12 +568,11 @@ -- -- The supplied point is the left baseline. -- -rescapedlabel :: Num u - => RGBi -> FontAttr -> EscapedText -> Radian -> Point2 u - -> Primitive u +rescapedlabel :: RGBi -> FontAttr -> EscapedText -> Radian -> DPoint2 + -> Primitive rescapedlabel rgb attr txt theta (P2 dx dy) = PLabel (LabelProps rgb attr) lbl where - lbl = PrimLabel (StdLayout txt) (makeThetaCTM dx dy theta) + lbl = PrimLabel (StdLayout txt) Nothing (makeThetaCTM dx dy theta) -- | 'zescapedlabel' : @ escaped_text * baseline_left -> Primitive @ @@ -530,7 +580,7 @@ -- Version of 'ztextlabel' where the label text has already been -- encoded. -- -zescapedlabel :: Num u => EscapedText -> Point2 u -> Primitive u +zescapedlabel :: EscapedText -> DPoint2 -> Primitive zescapedlabel = escapedlabel black wumpus_default_font @@ -567,12 +617,10 @@ -- PostScript analogue. While the same picture is generated in -- both cases, the PostScript code is not particularly inefficient. -- -hkernlabel :: Num u - => RGBi -> FontAttr -> [KerningChar u] -> Point2 u - -> Primitive u +hkernlabel :: RGBi -> FontAttr -> [KerningChar] -> DPoint2 -> Primitive hkernlabel rgb attr xs (P2 x y) = PLabel (LabelProps rgb attr) lbl where - lbl = PrimLabel (KernTextH xs) (makeTranslCTM x y) + lbl = PrimLabel (KernTextH xs) Nothing (makeTranslCTM x y) @@ -609,12 +657,10 @@ -- PostScript analogue. While the same picture is generated in -- both cases, the PostScript code is not particularly inefficient. -- -vkernlabel :: Num u - => RGBi -> FontAttr -> [KerningChar u] -> Point2 u - -> Primitive u +vkernlabel :: RGBi -> FontAttr -> [KerningChar] -> DPoint2 -> Primitive vkernlabel rgb attr xs (P2 x y) = PLabel (LabelProps rgb attr) lbl where - lbl = PrimLabel (KernTextV xs) (makeTranslCTM x y) + lbl = PrimLabel (KernTextV xs) Nothing (makeTranslCTM x y) @@ -623,7 +669,7 @@ -- 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 :: Double -> Char -> KerningChar kernchar u c = (u, CharLiteral c) @@ -632,7 +678,7 @@ -- Construct a Char by its character code along with its -- displacement from the left-baseline of the previous Char. -- -kernEscInt :: u -> Int -> KerningChar u +kernEscInt :: Double -> Int -> KerningChar kernEscInt u i = (u, CharEscInt i) @@ -641,7 +687,7 @@ -- 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 :: Double -> String -> KerningChar kernEscName u s = (u, CharEscName s) -------------------------------------------------------------------------------- @@ -653,52 +699,50 @@ -- -- 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 needs a single operation. For --- drawings with many dots (e.g. scatter plots) it seems sensible --- to employ this optimization. +-- needs four curves, but drawing them with PostScript\'s @arc@ +-- command uses a single operation. For drawings with many dots +-- (e.g. scatter plots) it seems sensible 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 +-- A deficiency of using PostScript\'s @arc@ command to draw +-- ellipses 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. -- -- Avoid non-uniform scaling stroked ellipses! -- -strokeEllipse :: Num u - => RGBi -> StrokeAttr -> u -> u -> Point2 u -> Primitive u +strokeEllipse :: RGBi -> StrokeAttr -> Double -> Double -> DPoint2 -> Primitive strokeEllipse rgb sa hw hh pt = rstrokeEllipse rgb sa hw hh 0 pt --- | 'rstrokeEllipse' : @ rgb * stroke_attr * rx * ry * rotation * +-- | 'rstrokeEllipse' : @ rgb * stroke_attr * rx * ry * theta * -- center -> Primtive @ -- --- Create a stroked ellipse rotated about the center by /theta/. +-- Create a stroked primitive ellipse rotated about the center by +-- /theta/. -- -rstrokeEllipse :: Num u - => RGBi -> StrokeAttr -> u -> u -> Radian -> Point2 u - -> Primitive u +rstrokeEllipse :: RGBi -> StrokeAttr -> Double -> Double -> Radian -> DPoint2 + -> Primitive rstrokeEllipse rgb sa rx ry theta pt = PEllipse (EStroke sa rgb) (mkPrimEllipse rx ry theta pt) --- | 'fillEllipse' : @ rgb * stroke_attr * rx * ry * center -> Primtive @ +-- | 'fillEllipse' : @ rgb * rx * ry * center -> Primtive @ -- --- Create a filled ellipse. +-- Create a filled primitive ellipse. -- -fillEllipse :: Num u - => RGBi -> u -> u -> Point2 u -> Primitive u +fillEllipse :: RGBi -> Double -> Double -> DPoint2 -> Primitive fillEllipse rgb rx ry pt = rfillEllipse rgb rx ry 0 pt --- | 'rfillEllipse' : @ colour * stroke_attr * rx * ry * --- rotation * center -> Primtive @ +-- | 'rfillEllipse' : @ rgb * rx * ry * theta * center -> Primitive @ -- --- Create a filled ellipse rotated about the center by /theta/. +-- Create a filled primitive ellipse rotated about the center by +-- /theta/. -- -rfillEllipse :: Num u - => RGBi -> u -> u -> Radian -> Point2 u -> Primitive u +rfillEllipse :: RGBi -> Double -> Double -> Radian -> DPoint2 -> Primitive rfillEllipse rgb rx ry theta pt = PEllipse (EFill rgb) (mkPrimEllipse rx ry theta pt) @@ -707,18 +751,18 @@ -- -- Create a black, filled ellipse. -- -zellipse :: Num u => u -> u -> Point2 u -> Primitive u +zellipse :: Double -> Double -> DPoint2 -> Primitive zellipse hw hh pt = rfillEllipse black hw hh 0 pt -- | 'fillStrokeEllipse' : @ fill_rgb * stroke_attr * stroke_rgb * rx * ry * -- center -> Primtive @ -- --- Create a bordered (i.e. filled and stroked) ellipse. +-- Create a bordered (i.e. filled and stroked) primitive ellipse. -- -fillStrokeEllipse :: Num u - => RGBi -> StrokeAttr -> RGBi -> u -> u -> Point2 u - -> Primitive u +fillStrokeEllipse :: RGBi -> StrokeAttr -> RGBi + -> Double -> Double -> DPoint2 + -> Primitive fillStrokeEllipse frgb sa srgb rx ry pt = rfillStrokeEllipse frgb sa srgb rx ry 0 pt @@ -730,14 +774,14 @@ -- Create a bordered (i.e. filled and stroked) ellipse rotated -- about the center by /theta/. -- -rfillStrokeEllipse :: Num u - => RGBi -> StrokeAttr -> RGBi -> u -> u -> Radian -> Point2 u - -> Primitive u +rfillStrokeEllipse :: RGBi -> StrokeAttr -> RGBi + -> Double -> Double -> Radian -> DPoint2 + -> Primitive rfillStrokeEllipse frgb sa srgb rx ry theta pt = PEllipse (EFillStroke frgb sa srgb) (mkPrimEllipse rx ry theta pt) -mkPrimEllipse :: Num u => u -> u -> Radian -> Point2 u -> PrimEllipse u +mkPrimEllipse :: Double -> Double -> Radian -> DPoint2 -> PrimEllipse mkPrimEllipse rx ry theta (P2 dx dy) = PrimEllipse rx ry (makeThetaCTM dx dy theta) @@ -752,8 +796,9 @@ -- both vertical directions by @y@. @x@ and @y@ must be positive -- This function cannot be used to shrink a boundary. -- -extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u -extendBoundary x y = mapLocale (\(bb,xs) -> (extBB (posve x) (posve y) bb, xs)) +extendBoundary :: Double -> Double -> Picture -> Picture +extendBoundary x y = + mapLocale (\(bb,xs) -> (extBB (posve x) (posve y) bb, xs)) where extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where pt1 = P2 (x0-x') (y0-y') @@ -772,7 +817,7 @@ -- Draw the first picture on top of the second picture - -- neither picture will be moved. -- -picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u +picOver :: Picture -> Picture -> Picture a `picOver` b = Picture (bb,[]) (join (one b) (one a)) where bb = boundary a `boundaryUnion` boundary b @@ -785,15 +830,15 @@ -- -- Move a picture by the supplied vector. -- -picMoveBy :: (Num u, Ord u) => Picture u -> Vec2 u -> Picture u -p `picMoveBy` (V2 dx dy) = translate dx dy p +picMoveBy :: Picture -> DVec2 -> Picture +p `picMoveBy` (V2 x y) = translate x y p -- | 'picBeside' : @ picture * picture -> Picture @ -- -- Move the second picture to sit at the right side of the -- first picture -- -picBeside :: (Num u, Ord u) => Picture u -> Picture u -> Picture u +picBeside :: Picture -> Picture -> Picture a `picBeside` b = a `picOver` (b `picMoveBy` v) where (P2 x1 _) = ur_corner $ boundary a @@ -805,7 +850,7 @@ -- | Print the syntax tree of a Picture to the console. -- -printPicture :: (Num u, PSUnit u) => Picture u -> IO () +printPicture :: Picture -> IO () printPicture pic = putStrLn (show $ format pic) >> putStrLn [] @@ -814,9 +859,9 @@ -- Draw the picture on top of an image of its bounding box. -- The bounding box image will be drawn in the supplied colour. -- -illustrateBounds :: (Real u, Floating u, FromPtSize u) - => RGBi -> Picture u -> Picture u -illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb p $ []) +illustrateBounds :: RGBi -> Picture -> Picture +illustrateBounds rgb p = + p `picOver` (frame $ boundsPrims rgb (boundary p) $ []) -- | 'illustrateBoundsPrim' : @ bbox_rgb * primitive -> Picture @ @@ -826,23 +871,22 @@ -- -- The result will be lifted from Primitive to Picture. -- -illustrateBoundsPrim :: (Real u, Floating u, FromPtSize u) - => RGBi -> Primitive u -> Picture u -illustrateBoundsPrim rgb p = frame $ boundsPrims rgb p $ [p] +illustrateBoundsPrim :: RGBi -> Primitive -> Picture +illustrateBoundsPrim rgb p = + frame $ boundsPrims rgb (boundary p) $ [p] -- | Draw a the rectangle of a bounding box, plus cross lines -- joining the corners. -- -boundsPrims :: (Num u, Ord u, Boundary t, u ~ DUnit t) - => RGBi -> t -> H (Primitive u) -boundsPrims rgb a = fromListH $ [ bbox_rect, bl_to_tr, br_to_tl ] +boundsPrims :: RGBi -> BoundingBox Double -> H Primitive +boundsPrims rgb bb = fromListH $ [ bbox_rect, bl_to_tr, br_to_tl ] where - (bl,br,tr,tl) = boundaryCorners $ boundary a - bbox_rect = cstroke rgb line_attr $ vertexPath [bl,br,tr,tl] - bl_to_tr = ostroke rgb line_attr $ vertexPath [bl,tr] - br_to_tl = ostroke rgb line_attr $ vertexPath [br,tl] + (bl,br,tr,tl) = boundaryCorners bb + bbox_rect = cstroke rgb line_attr $ vertexPrimPath [bl,br,tr,tl] + bl_to_tr = ostroke rgb line_attr $ vertexPrimPath [bl,tr] + br_to_tl = ostroke rgb line_attr $ vertexPrimPath [br,tl] line_attr = default_stroke_attr { line_cap = CapRound , dash_pattern = Dash 0 [(1,2)] } @@ -856,15 +900,14 @@ -- This has no effect on TextLabels. Nor does it draw Beziers of -- a hyperlinked object. -- -illustrateControlPoints :: (Real u, Floating u, FromPtSize u) - => RGBi -> Primitive u -> Picture u +illustrateControlPoints :: RGBi -> Primitive -> Picture illustrateControlPoints rgb elt = frame $ fn elt where fn (PPath _ p) = pathCtrlLines rgb p $ [elt] fn a = [a] --- Genrate lines illustrating the control points of curves on +-- | Generate lines illustrating the control points of curves on -- a Path. -- -- Two lines are generated for a Bezier curve: @@ -872,8 +915,9 @@ -- -- Nothing is generated for a straight line. -- -pathCtrlLines :: (Num u, Ord u) => RGBi -> PrimPath u -> H (Primitive u) -pathCtrlLines rgb (PrimPath start ss) = step start ss +pathCtrlLines :: RGBi -> PrimPath -> H Primitive +pathCtrlLines rgb ppath = + let (start,ss) = extractRelPath ppath in step start ss where step s (RelLineTo v:xs) = step (s .+^ v) xs @@ -884,6 +928,8 @@ step _ [] = emptyH - mkLine s v = let pp = (PrimPath s [RelLineTo v]) + mkLine s v = let seg1 = absLineTo $ s .+^ v + pp = absPrimPath s [seg1] in ostroke rgb default_stroke_attr pp + 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 @@ -1,14 +1,15 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.PictureInternal --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2012 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Internal representation of Pictures. @@ -20,44 +21,38 @@ ( Picture(..) - , DPicture , Locale , FontCtx(..) , Primitive(..) - , DPrimitive , SvgAnno(..) , XLink(..) , SvgAttr(..) , PrimPath(..) - , DPrimPath , PrimPathSegment(..) - , DPrimPathSegment , AbsPathSegment(..) - , DAbsPathSegment , PrimLabel(..) - , DPrimLabel , LabelBody(..) - , DLabelBody , KerningChar - , DKerningChar , PrimEllipse(..) , GraphicsState(..) - , pathBoundary , mapLocale -- * Additional operations , concatTrafos , deconsMatrix , repositionDeltas + , extractRelPath , zeroGS , isEmptyPath , isEmptyLabel + , pushXIdAnno + ) where import Wumpus.Core.AffineTrans @@ -66,10 +61,8 @@ import Wumpus.Core.FontSize import Wumpus.Core.Geometry import Wumpus.Core.GraphicProps -import Wumpus.Core.PtSize import Wumpus.Core.Text.Base import Wumpus.Core.TrafoInternal -import Wumpus.Core.Utils.Common import Wumpus.Core.Utils.FormatCombinators import Wumpus.Core.Utils.JoinList @@ -80,49 +73,29 @@ import qualified Data.IntMap as IntMap --- | Picture is a leaf attributed tree - where attributes are --- colour, line-width etc. It is parametric on the unit type --- of points (typically Double). --- --- Wumpus\'s leaf attributed tree, is not directly matched to --- PostScript\'s picture representation, which might be --- considered a node attributed tree (if you consider graphics --- state changes less imperatively - setting attributes rather --- than global state change). --- --- Considered as a node-attributed tree PostScript precolates --- graphics state updates downwards in the tree (vis-a-vis --- inherited attributes in an attibute grammar), where a --- graphics state change deeper in the tree overrides a higher --- one. +-- | Picture is a rose tree. Leaves themselves are attributed +-- with colour, line-width etc. The /unit/ of a Picture is +-- fixed to Double representing PostScript\'s /Point/ unit. +-- Output is always gewnerated with PostScript points - other +-- units are converted to PostScript points before building the +-- Picture. -- --- Wumpus on the other hand, simply labels each leaf with its --- drawing attributes - there is no attribute inheritance. --- When it draws the PostScript picture it does some --- optimization to avoid generating excessive graphics state --- changes in the PostScript code. +-- By attributing leaves with their drawing properties, Wumpus\'s +-- picture representaion is not directly matched to PostScript. +-- PostScript has a global graphics state (that allows local +-- modifaction) from where drawing properties are inherited. +-- Wumpus has no attribute inheritance. -- --- Omitting some details, Picture is a simple non-empty --- leaf-labelled rose tree via: +-- Omitting some details of the list representation, Picture is a +-- simple non-empty rose tree via: -- -- > tree = Leaf [primitive] | Picture [tree] -- --- The additional constructors are convenience: --- --- @Clip@ nests a picture (tree) inside a clipping path. --- --- The @Group@ constructor allows local shared graphics state --- updates for the SVG renderer - in some instances this can --- improve the code size of the generated SVG. --- -data Picture u = Leaf (Locale u) (JoinList (Primitive u)) - | Picture (Locale u) (JoinList (Picture u)) - | Clip (Locale u) (PrimPath u) (Picture u) +data Picture = Leaf Locale (JoinList Primitive) + | Picture Locale (JoinList Picture) deriving (Show) -type DPicture = Picture Double - - +type instance DUnit Picture = Double -- | Locale = (bounding box * current translation matrix) -- @@ -141,7 +114,7 @@ -- transformation, the corners of bounding boxes are transformed -- pointwise when the picture is scaled, rotated etc. -- -type Locale u = (BoundingBox u, [AffineTrafo u]) +type Locale = (BoundingBox Double, [AffineTrafo]) @@ -168,6 +141,9 @@ -- Though typically for affine transformations a Fractional -- constraint is also obliged. -- +-- Clipping is represented by a pair of the clipping path and +-- the primitive embedded within the path. +-- -- To represent XLink hyperlinks, Primitives can be annotated -- with some a hyperlink (likewise a /passive/ font change for -- better SVG code generation) and grouped - a hyperlinked arrow @@ -177,16 +153,16 @@ -- 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) - | PContext FontCtx (Primitive u) - | PSVG SvgAnno (Primitive u) - | PGroup (JoinList (Primitive u)) +data Primitive = PPath PathProps PrimPath + | PLabel LabelProps PrimLabel + | PEllipse EllipseProps PrimEllipse + | PContext FontCtx Primitive + | PSVG SvgAnno Primitive + | PGroup (JoinList Primitive) + | PClip PrimPath Primitive deriving (Eq,Show) - -type DPrimitive = Primitive Double +type instance DUnit Primitive = Double -- | Set the font /delta/ for SVG rendering. @@ -201,17 +177,21 @@ -- | SVG annotations - annotations can be: -- --- A hyperlink inside @ ... @ . +-- * A hyperlink inside @ ... @ . -- --- A group - @ ... @ +-- * A group - @ ... @ -- --- A group inside a hyperlink. +-- * A group of annotations inside a hyperlink. -- +-- * An @id@. +-- data SvgAnno = ALink XLink | GAnno [SvgAttr] | SvgAG XLink [SvgAttr] + | SvgId String deriving (Eq,Show) + -- | Primitives can be grouped with hyperlinks in SVG output. -- -- Note - this is always printed as @xlink:href="..."@. Other @@ -229,58 +209,92 @@ -- properties. Graphical properties (fill_colour, font_size, etc.) -- should be set through the appropriate Wumpus functions. -- +-- Also note, this functionality is has not been widely used. It +-- might be something of a white elephant. +-- data SvgAttr = SvgAttr { svg_attr_name :: String , svg_attr_value :: String } deriving (Eq,Show) --- | PrimPath - start point and a list of path segments. + +-- | PrimPath - a list of path segments and a CTM (translation +-- matrix). +-- +-- The start point of the path forms the (dx,dy) of the CTM. The +-- CTM is otherwise hidden from the public constructors of this +-- data type. +-- +-- Note - the PrimPath type does not support concatenation. +-- It is expected that all PrimPaths will be created /in one go/, +-- and client code defines a higher-level path type that supports +-- concatenation, splitting etc. -- -data PrimPath u = PrimPath (Point2 u) [PrimPathSegment u] +-- Primitively paths can be built like this: +-- +-- > +-- > path1 :: PrimPath +-- > path1 = absPrimPath zeroPt [ absLineTo (P2 0 60) +-- > , absLineTo (P2 40 100) +-- > , absLineTo (P2 80 60) +-- > , absLineTo (P2 80 0) +-- > , absLineTo (P2 60 0) +-- > , absLineTo (P2 60 30) +-- > , absCurveTo (P2 60 50) (P2 50 60) (P2 40 60) +-- > , absCurveTo (P2 30 60) (P2 20 50) (P2 20 30) +-- > , absLineTo (P2 20 0) +-- > ] +-- > +-- +-- Although it\'s generally expected that PrimPaths will be +-- constructed by traversing a higher-level path object and +-- collecting calls to the @absCurevTo@ and @absLineTo@ functions +-- in a list. +-- +data PrimPath = PrimPath [PrimPathSegment] PrimCTM deriving (Eq,Show) -type DPrimPath = PrimPath Double +type instance DUnit PrimPath = Double + -- | PrimPathSegment - either a relative cubic Bezier /curve-to/ -- or a relative /line-to/. -- -data PrimPathSegment u = RelCurveTo (Vec2 u) (Vec2 u) (Vec2 u) - | RelLineTo (Vec2 u) +data PrimPathSegment = RelCurveTo DVec2 DVec2 DVec2 + | RelLineTo DVec2 deriving (Eq,Show) -type DPrimPathSegment = PrimPathSegment Double - --- Design note - if paths were represented as: --- start-point plus [relative-path-segment] --- They would be cheaper to move... --- +type instance DUnit PrimPathSegment = Double -- | AbsPathSegment - either a cubic Bezier curve or a line. -- -- Note this data type is transitory - it is only used as a --- convenience to build relative paths. +-- convenience to build relative paths. Hence the unit type is +-- parametric. -- -data AbsPathSegment u = AbsCurveTo (Point2 u) (Point2 u) (Point2 u) - | AbsLineTo (Point2 u) +data AbsPathSegment = AbsCurveTo DPoint2 DPoint2 DPoint2 + | AbsLineTo DPoint2 deriving (Eq,Show) -type DAbsPathSegment = AbsPathSegment Double +type instance DUnit AbsPathSegment = Double -- | Label - represented by baseline-left point and text. -- -- Baseline-left is the dx * dy of the PrimCTM. -- -data PrimLabel u = PrimLabel - { label_body :: LabelBody u - , label_ctm :: PrimCTM u +-- +data PrimLabel = PrimLabel + { label_body :: LabelBody + , label_opt_id :: Maybe String + , label_ctm :: PrimCTM } deriving (Eq,Show) -type DPrimLabel = PrimLabel Double +type instance DUnit PrimLabel = Double -- | Label can be draw with 3 layouts. @@ -295,33 +309,40 @@ -- Kerned vertical layout - each character is encoded with the -- upwards distance from the last charcaters left base-line. -- -data LabelBody u = StdLayout EscapedText - | KernTextH [KerningChar u] - | KernTextV [KerningChar u] +data LabelBody = StdLayout EscapedText + | KernTextH [KerningChar] + | KernTextV [KerningChar] deriving (Eq,Show) -type DLabelBody = LabelBody Double +type instance DUnit LabelBody = Double --- | A Char (possibly escaped) paired with is displacement from +-- | A Char (possibly escaped) paired with its displacement from -- the previous KerningChar. -- -type KerningChar u = (u,EscapedChar) +type KerningChar = (Double,EscapedChar) -type DKerningChar = KerningChar Double -- | Ellipse represented by center and half_width * half_height. -- -- Center is the dx * dy of the PrimCTM. -- -data PrimEllipse u = PrimEllipse - { ellipse_half_width :: u - , ellipse_half_height :: u - , ellipse_ctm :: PrimCTM u +data PrimEllipse = PrimEllipse + { ellipse_half_width :: !Double + , ellipse_half_height :: !Double + , ellipse_ctm :: PrimCTM } deriving (Eq,Show) +type instance DUnit PrimEllipse = Double +-- +-- Design note - the CTM unit type is fixed to Double (PS point) +-- rather than parametric on unit. +-- +-- For the rationale see the PrimLabel design note. +-- + -------------------------------------------------------------------------------- -- Graphics state datatypes @@ -340,19 +361,11 @@ -------------------------------------------------------------------------------- --- family instances - -type instance DUnit (Picture u) = u -type instance DUnit (Primitive u) = u -type instance DUnit (PrimEllipse u) = u -type instance DUnit (PrimLabel u) = u -type instance DUnit (PrimPath u) = u - --------------------------------------------------------------------------------- -- instances +-- format -instance (Num u, PSUnit u) => Format (Picture u) where +instance Format Picture where format (Leaf m prims) = indent 2 $ vcat [ text "** Leaf-pic **" , fmtLocale m , fmtPrimlist prims ] @@ -361,23 +374,18 @@ , fmtLocale m , fmtPics pics ] - format (Clip m path pic) = indent 2 $ vcat [ text "** Clip-path **" - , fmtLocale m - , format path - , format pic ] - -fmtPics :: PSUnit u => JoinList (Picture u) -> Doc +fmtPics :: JoinList Picture -> 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]) -fmtLocale :: (Num u, PSUnit u) => Locale u -> Doc +fmtLocale :: Locale -> Doc fmtLocale (bb,_) = format bb -instance PSUnit u => Format (Primitive u) where +instance Format Primitive where format (PPath props p) = indent 2 $ vcat [ text "path:" <+> format props, format p ] @@ -396,40 +404,44 @@ format (PGroup ones) = vcat [ text "-- group ", fmtPrimlist ones ] + format (PClip path pic) = + vcat [ text "-- clip-path ", format path, format pic ] -fmtPrimlist :: PSUnit u => JoinList (Primitive u) -> Doc + + +fmtPrimlist :: JoinList Primitive -> 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]) -instance PSUnit u => Format (PrimPath u) where - format (PrimPath pt ps) = vcat (start : map format ps) - where - start = text "start_point " <> format pt +instance Format PrimPath where + format (PrimPath vs ctm) = vcat [ hcat $ map format vs + , text "ctm=" >< format ctm ] -instance PSUnit u => Format (PrimPathSegment u) where +instance Format PrimPathSegment where format (RelCurveTo p1 p2 p3) = - text "rel_curve_to " <> format p1 <+> format p2 <+> format p3 + text "rel_curve_to " >< format p1 <+> format p2 <+> format p3 - format (RelLineTo pt) = text "rel_line_to " <> format pt + format (RelLineTo pt) = text "rel_line_to " >< format pt -instance PSUnit u => Format (PrimLabel u) where - format (PrimLabel s ctm) = +instance Format PrimLabel where + format (PrimLabel s opt_id ctm) = vcat [ dquotes (format s) - , text "ctm=" <> format ctm + , maybe (char '_') text $ opt_id + , text "ctm=" >< format ctm ] -instance PSUnit u => Format (LabelBody u) where +instance Format LabelBody 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 hw hh ctm) = text "hw=" <> dtruncFmt hw - <+> text "hh=" <> dtruncFmt hh - <+> text "ctm=" <> format ctm +instance Format PrimEllipse where + format (PrimEllipse hw hh ctm) = text "hw=" >< format hw + <+> text "hh=" >< format hh + <+> text "ctm=" >< format ctm instance Format XLink where @@ -438,32 +450,44 @@ -------------------------------------------------------------------------------- -instance Boundary (Picture u) where - boundary (Leaf (bb,_) _) = bb - boundary (Picture (bb,_) _) = bb - boundary (Clip (bb,_) _ _) = bb +instance Boundary Picture where + boundary = boundaryPicture +boundaryPicture :: Picture -> BoundingBox Double +boundaryPicture (Leaf (bb,_) _) = bb +boundaryPicture (Picture (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 (PContext _ a) = boundary a - boundary (PSVG _ a) = boundary a - boundary (PGroup ones) = outer $ viewl ones - where - outer (OneL a) = boundary a - outer (a :< as) = inner (boundary a) (viewl as) - inner bb (OneL a) = bb `boundaryUnion` boundary a - inner bb (a :< as) = inner (bb `boundaryUnion` boundary a) (viewl as) +instance Boundary Primitive where + boundary = boundaryPrimitive +boundaryPrimitive :: Primitive -> BoundingBox Double +boundaryPrimitive (PPath _ p) = boundaryPrimPath p +boundaryPrimitive (PLabel a l) = labelBoundary (label_font a) l +boundaryPrimitive (PEllipse _ e) = ellipseBoundary e +boundaryPrimitive (PContext _ a) = boundaryPrimitive a +boundaryPrimitive (PSVG _ a) = boundaryPrimitive a +boundaryPrimitive (PClip p _) = boundaryPrimPath p +boundaryPrimitive (PGroup ones) = outer $ viewl ones + where + outer (OneL a) = boundaryPrimitive a + outer (a :< as) = inner (boundaryPrimitive a) (viewl as) + inner bb (OneL a) = bb `boundaryUnion` boundaryPrimitive a + inner bb (a :< as) = inner (bb `boundaryUnion` boundaryPrimitive a) + (viewl as) -pathBoundary :: (Num u, Ord u) => PrimPath u -> BoundingBox u -pathBoundary (PrimPath st xs) = step st (st,st) xs +instance Boundary PrimPath where + boundary = boundaryPrimPath + + +boundaryPrimPath :: PrimPath -> BoundingBox Double +boundaryPrimPath (PrimPath vs ctm) = + retraceBoundary (m33 *#) $ step zeroPt (zeroPt,zeroPt) vs where + m33 = matrixRepCTM ctm + step _ (lo,hi) [] = BBox lo hi step pt (lo,hi) (RelLineTo v1:rest) = @@ -490,23 +514,20 @@ -labelBoundary :: (Floating u, Real u, FromPtSize u) - => FontAttr -> PrimLabel u -> BoundingBox u -labelBoundary attr (PrimLabel body ctm) = +labelBoundary :: FontAttr -> PrimLabel -> BoundingBox Double +labelBoundary attr (PrimLabel body _ ctm) = retraceBoundary (m33 *#) untraf_bbox where m33 = matrixRepCTM ctm untraf_bbox = labelBodyBoundary (font_size attr) body -labelBodyBoundary :: (Num u, Ord u, FromPtSize u) - => FontSize -> LabelBody u -> BoundingBox u +labelBodyBoundary :: FontSize -> LabelBody -> BoundingBox Double labelBodyBoundary sz (StdLayout etxt) = stdLayoutBB sz etxt labelBodyBoundary sz (KernTextH xs) = hKerningBB sz xs labelBodyBoundary sz (KernTextV xs) = vKerningBB sz xs -stdLayoutBB :: (Num u, Ord u, FromPtSize u) - => FontSize -> EscapedText -> BoundingBox u +stdLayoutBB :: FontSize -> EscapedText -> BoundingBox Double stdLayoutBB sz etxt = textBoundsEsc sz zeroPt etxt @@ -518,8 +539,7 @@ -- then expands the right edge with the sum of the (rightwards) -- displacements. -- -hKerningBB :: (Num u, Ord u, FromPtSize u) - => FontSize -> [(u,EscapedChar)] -> BoundingBox u +hKerningBB :: FontSize -> [(Double,EscapedChar)] -> BoundingBox Double hKerningBB sz xs = rightGrow (sumDiffs xs) $ textBounds sz zeroPt "A" where sumDiffs = foldr (\(u,_) i -> i+u) 0 @@ -535,8 +555,7 @@ -- -- Also note, that the Label /grows/ downwards... -- -vKerningBB :: (Num u, Ord u, FromPtSize u) - => FontSize -> [(u,EscapedChar)] -> BoundingBox u +vKerningBB :: FontSize -> [(Double,EscapedChar)] -> BoundingBox Double vKerningBB sz xs = downGrow (sumDiffs xs) $ textBounds sz zeroPt "A" where sumDiffs = foldr (\(u,_) i -> i+u) 0 @@ -546,7 +565,7 @@ -- | Ellipse bbox is the bounding rectangle, rotated as necessary -- then retraced. -- -ellipseBoundary :: (Real u, Floating u) => PrimEllipse u -> BoundingBox u +ellipseBoundary :: PrimEllipse -> BoundingBox Double ellipseBoundary (PrimEllipse hw hh ctm) = traceBoundary $ map (m33 *#) [sw,se,ne,nw] where @@ -566,32 +585,36 @@ -- update (frame change). -- -instance (Num u, Ord u) => Transform (Picture u) where +instance Transform Picture where transform mtrx = - mapLocale $ \(bb,xs) -> (transform mtrx bb, Matrix mtrx:xs) + mapLocale $ \(bb,xs) -> let cmd = Matrix mtrx + in (transform mtrx bb, cmd : xs) -instance (Real u, Floating u) => Rotate (Picture u) where +instance Rotate Picture where rotate theta = mapLocale $ \(bb,xs) -> (rotate theta bb, Rotate theta:xs) -instance (Real u, Floating u) => RotateAbout (Picture u) where +instance RotateAbout Picture where rotateAbout theta pt = - mapLocale $ \(bb,xs) -> (rotateAbout theta pt bb, RotAbout theta pt:xs) + mapLocale $ \(bb,xs) -> let cmd = RotAbout theta pt + in (rotateAbout theta pt bb, cmd : xs) -instance (Num u, Ord u) => Scale (Picture u) where +instance Scale Picture where scale sx sy = - mapLocale $ \(bb,xs) -> (scale sx sy bb, Scale sx sy : xs) + mapLocale $ \(bb,xs) -> let cmd = Scale sx sy + in (scale sx sy bb, cmd : xs) -instance (Num u, Ord u) => Translate (Picture u) where +instance Translate Picture where translate dx dy = - mapLocale $ \(bb,xs) -> (translate dx dy bb, Translate dx dy:xs) + mapLocale $ \(bb,xs) -> let cmd = Translate dx dy + in (translate dx dy bb, cmd : xs) + -mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u +mapLocale :: (Locale -> Locale) -> Picture -> Picture 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 -------------------------------------------------------------------------------- @@ -603,73 +626,98 @@ -- (ShapeCTM is not a real matrix). -- -instance (Real u, Floating u) => Rotate (Primitive u) where +instance Rotate Primitive where 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 (PContext a chi) = PContext a $ rotate r chi rotate r (PSVG a chi) = PSVG a $ rotate r chi rotate r (PGroup xs) = PGroup $ fmap (rotate r) xs - + rotate r (PClip p chi) = PClip (rotatePath r p) (rotate r chi) -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 (PContext a chi) = PContext a $ rotateAbout r pt chi - rotateAbout r pt (PSVG a chi) = PSVG a $ rotateAbout r pt chi - rotateAbout r pt (PGroup xs) = PGroup $ fmap (rotateAbout r pt) xs +instance RotateAbout Primitive where + rotateAbout ang p0 (PPath a path) = + PPath a $ rotateAboutPath ang p0 path + rotateAbout ang p0 (PLabel a lbl) = + PLabel a $ rotateAboutLabel ang p0 lbl -instance Num u => Scale (Primitive u) where + rotateAbout ang p0 (PEllipse a ell) = + PEllipse a $ rotateAboutEllipse ang p0 ell + + rotateAbout ang p0 (PContext a chi) = + PContext a $ rotateAbout ang p0 chi + + rotateAbout ang p0 (PSVG a chi) = + PSVG a $ rotateAbout ang p0 chi + + rotateAbout ang p0 (PGroup xs) = + PGroup $ fmap (rotateAbout ang p0) xs + + rotateAbout ang p0 (PClip p chi) = + PClip (rotateAboutPath ang p0 p) (rotateAbout ang p0 chi) + + +instance Scale Primitive 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 (PContext a chi) = PContext a $ scale sx sy chi scale sx sy (PSVG a chi) = PSVG a $ scale sx sy chi scale sx sy (PGroup xs) = PGroup $ fmap (scale sx sy) xs + scale sx sy (PClip p chi) = PClip (scalePath sx sy p) (scale sx sy chi) -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 (PContext a chi) = PContext a $ translate dx dy chi - translate dx dy (PSVG a chi) = PSVG a $ translate dx dy chi - translate dx dy (PGroup xs) = PGroup $ fmap (translate dx dy) xs +instance Translate Primitive 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 (PContext a chi) = + PContext a $ translate dx dy chi + + translate dx dy (PSVG a chi) = + PSVG a $ translate dx dy chi + + translate dx dy (PGroup xs) = + PGroup $ fmap (translate dx dy) xs + + translate dx dy (PClip p chi) = + PClip (translatePath dx dy p) (translate dx dy chi) + + -------------------------------------------------------------------------------- -- Paths +-- Affine transformations on paths are applied to their control +-- points. -rotatePath :: (Real u, Floating u) => Radian -> PrimPath u -> PrimPath u -rotatePath ang = mapPath (rotate ang) (rotate ang) +rotatePath :: Radian -> PrimPath -> PrimPath +rotatePath ang (PrimPath vs ctm) = PrimPath vs (rotateCTM ang ctm) -rotateAboutPath :: (Real u, Floating u) - => Radian -> Point2 u -> PrimPath u -> PrimPath u -rotateAboutPath ang pt = mapPath (rotateAbout ang pt) (rotateAbout ang pt) +rotateAboutPath :: Radian -> DPoint2 -> PrimPath -> PrimPath +rotateAboutPath ang (P2 x y) (PrimPath vs ctm) = + PrimPath vs (rotateAboutCTM ang (P2 x y) ctm) -scalePath :: Num u => u -> u -> PrimPath u -> PrimPath u -scalePath sx sy = mapPath (scale sx sy) (scale sx sy) +scalePath :: Double -> Double -> PrimPath -> PrimPath +scalePath sx sy (PrimPath vs ctm) = PrimPath vs (scaleCTM sx sy ctm) + -- Note - translate only needs change the start point /because/ -- the path represented as a relative path. -- -translatePath :: Num u => u -> u -> PrimPath u -> PrimPath u -translatePath x y (PrimPath st xs) = PrimPath (translate x y st) xs +translatePath :: Double -> Double -> PrimPath -> PrimPath +translatePath dx dy (PrimPath vs ctm) = + PrimPath vs (translateCTM dx dy ctm) -mapPath :: (Point2 u -> Point2 u) -> (Vec2 u -> Vec2 u) - -> PrimPath u -> PrimPath u -mapPath f g (PrimPath st xs) = PrimPath (f st) (map (mapSeg g) xs) - -mapSeg :: (Vec2 u -> Vec2 u) -> PrimPathSegment u -> PrimPathSegment u -mapSeg fn (RelLineTo p) = RelLineTo (fn p) -mapSeg fn (RelCurveTo p1 p2 p3) = RelCurveTo (fn p1) (fn p2) (fn p3) - -------------------------------------------------------------------------------- -- Labels @@ -678,46 +726,44 @@ -- Rotate the baseline-left start point _AND_ the CTM of the -- label. -- -rotateLabel :: (Real u, Floating u) - => Radian -> PrimLabel u -> PrimLabel u -rotateLabel ang (PrimLabel txt ctm) = PrimLabel txt (rotateCTM ang ctm) +rotateLabel :: Radian -> PrimLabel -> PrimLabel +rotateLabel ang (PrimLabel txt opt_id ctm) = + PrimLabel txt opt_id (rotateCTM ang ctm) -- /rotateAbout/ the start-point, /rotate/ the the CTM. -- -rotateAboutLabel :: (Real u, Floating u) - => Radian -> Point2 u -> PrimLabel u -> PrimLabel u -rotateAboutLabel ang pt (PrimLabel txt ctm) = - PrimLabel txt (rotateAboutCTM ang pt ctm) +rotateAboutLabel :: Radian -> DPoint2 -> PrimLabel -> PrimLabel +rotateAboutLabel ang (P2 x y) (PrimLabel txt opt_id ctm) = + PrimLabel txt opt_id (rotateAboutCTM ang (P2 x y) ctm) -scaleLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u -scaleLabel sx sy (PrimLabel txt ctm) = PrimLabel txt (scaleCTM sx sy ctm) +scaleLabel :: Double -> Double -> PrimLabel -> PrimLabel +scaleLabel sx sy (PrimLabel txt opt_id ctm) = + PrimLabel txt opt_id (scaleCTM sx sy ctm) -- Change the bottom-left corner. -- -translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u -translateLabel dx dy (PrimLabel txt ctm) = - PrimLabel txt (translateCTM dx dy ctm) +translateLabel :: Double -> Double -> PrimLabel -> PrimLabel +translateLabel dx dy (PrimLabel txt opt_id ctm) = + PrimLabel txt opt_id (translateCTM dx dy ctm) -------------------------------------------------------------------------------- -- Ellipse -rotateEllipse :: (Real u, Floating u) - => Radian -> PrimEllipse u -> PrimEllipse u +rotateEllipse :: Radian -> PrimEllipse -> PrimEllipse rotateEllipse ang (PrimEllipse hw hh ctm) = PrimEllipse hw hh (rotateCTM ang ctm) -rotateAboutEllipse :: (Real u, Floating u) - => Radian -> Point2 u -> PrimEllipse u -> PrimEllipse u -rotateAboutEllipse ang pt (PrimEllipse hw hh ctm) = - PrimEllipse hw hh (rotateAboutCTM ang pt ctm) +rotateAboutEllipse :: Radian -> DPoint2 -> PrimEllipse -> PrimEllipse +rotateAboutEllipse ang (P2 x y) (PrimEllipse hw hh ctm) = + PrimEllipse hw hh (rotateAboutCTM ang (P2 x y) ctm) -scaleEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u +scaleEllipse :: Double -> Double -> PrimEllipse -> PrimEllipse scaleEllipse sx sy (PrimEllipse hw hh ctm) = PrimEllipse hw hh (scaleCTM sx sy ctm) @@ -725,7 +771,7 @@ -- Change the point -- -translateEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u +translateEllipse :: Double -> Double -> PrimEllipse -> PrimEllipse translateEllipse dx dy (PrimEllipse hw hh ctm) = PrimEllipse hw hh (translateCTM dx dy ctm) @@ -751,15 +797,15 @@ --- If a picture has coordinates smaller than (P2 4 4) then it --- needs repositioning before it is drawn to PostScript or SVG. +-- If a picture has coordinates smaller than (P2 4 4) especially +-- negative ones then it needs repositioning before it is drawn +-- to PostScript or SVG. -- -- (P2 4 4) gives a 4 pt margin - maybe it sould be (0,0) or -- user defined. -- -repositionDeltas :: (Num u, Ord u) - => Picture u -> (BoundingBox u, Maybe (Vec2 u)) -repositionDeltas = step . boundary +repositionDeltas :: Picture -> (BoundingBox Double, Maybe DVec2) +repositionDeltas = step . boundaryPicture where step bb@(BBox (P2 llx lly) (P2 urx ury)) | llx < 4 || lly < 4 = (BBox ll ur, Just $ V2 x y) @@ -771,12 +817,24 @@ ur = P2 (urx+x) (ury+y) +extractRelPath :: PrimPath -> (DPoint2, [PrimPathSegment]) +extractRelPath (PrimPath ss ctm) = (start, usegs) + where + (start,dctm) = unCTM ctm + mtrafo = transform (matrixRepCTM dctm) + usegs = map fn ss + + fn (RelCurveTo v1 v2 v3) = RelCurveTo (mtrafo v1) (mtrafo v2) (mtrafo v3) + fn (RelLineTo v1) = RelLineTo (mtrafo v1) + + + -------------------------------------------------------------------------------- -- | The initial graphics state. -- -- PostScript has no default font so we always want the first --- /delta/ operation not to find a match and cause a @findfint@ +-- /delta/ operation not to find a match and cause a @findfont@ -- command to be generated (PostScript @findfont@ commands are -- only written in the output on /deltas/ to reduce the -- output size). @@ -796,15 +854,27 @@ -- | Is the path empty - if so we might want to avoid printing it. -- -isEmptyPath :: PrimPath u -> Bool -isEmptyPath (PrimPath _ xs) = null xs +isEmptyPath :: PrimPath -> Bool +isEmptyPath (PrimPath xs _) = null xs -- | Is the label empty - if so we might want to avoid printing it. -- -isEmptyLabel :: PrimLabel u -> Bool -isEmptyLabel (PrimLabel txt _) = body txt +isEmptyLabel :: PrimLabel -> Bool +isEmptyLabel (PrimLabel txt _ _) = body txt where body (StdLayout esc) = destrEscapedText null esc body (KernTextH xs) = null xs body (KernTextV xs) = null xs + +-- | Annotate a Primitive with an @id@ for SVG. +-- +-- Note - for @PLabel@ this /pushes/ the id /inside/ the +-- constructor, for other elements the the id adds an extra layer +-- of nesting via the SVG group \ tag. +-- +pushXIdAnno :: String -> Primitive -> Primitive +pushXIdAnno ss (PLabel props (PrimLabel txt _ ctm )) = + PLabel props $ PrimLabel txt (Just ss) ctm + +pushXIdAnno ss prim = PSVG (SvgId ss) prim 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 @@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.PostScriptDoc --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- PostScript Doc combinators. @@ -117,7 +117,7 @@ ] -epsHeader :: PSUnit u => BoundingBox u -> ZonedTime -> Doc +epsHeader :: DBoundingBox -> ZonedTime -> Doc epsHeader bb tod = vcat $ [ text "%!PS-Adobe-3.0 EPSF-3.0" , text "%%BoundingBox:" <+> upint llx <+> upint lly @@ -126,7 +126,7 @@ , text "%%EndComments" ] where - upint = text . roundup . toDouble + upint = text . roundup (llx,lly,urx,ury) = destBoundingBox bb @@ -184,7 +184,7 @@ -- | @ ... setlinewidth @ -- -ps_setlinewidth :: PSUnit u => u -> Doc +ps_setlinewidth :: Double -> Doc ps_setlinewidth u = command "setlinewidth" [dtruncFmt u] -- | @ ... setlinecap @ @@ -199,7 +199,7 @@ -- | @ ... setmiterlimit @ -- -ps_setmiterlimit :: PSUnit u => u -> Doc +ps_setmiterlimit :: Double -> Doc ps_setmiterlimit u = command "setmiterlimit" [dtruncFmt u] -- | @ [... ...] ... setdash @ @@ -225,7 +225,8 @@ -- coordinate system and matrix operators -- | @ ... ... translate @ -ps_translate :: PSUnit u => (Vec2 u) -> Doc +-- +ps_translate :: DVec2 -> Doc ps_translate (V2 dx dy) = command "translate" [dtruncFmt dx, dtruncFmt dy] @@ -237,7 +238,7 @@ -- | @ [... ... ... ... ... ...] concat @ -- -ps_concat :: PSUnit u => Matrix3'3 u -> Doc +ps_concat :: Matrix3'3 Double -> Doc ps_concat mtrx = doc <+> text "concat" where (a,b,c,d,e,f) = deconsMatrix mtrx @@ -260,25 +261,25 @@ -- | @ ... ... moveto @ -- -ps_moveto :: PSUnit u => Point2 u -> Doc +ps_moveto :: DPoint2 -> Doc ps_moveto (P2 x y) = command "moveto" [dtruncFmt x, dtruncFmt y] -- | @ ... ... rmoveto @ -- -ps_rmoveto :: PSUnit u => Point2 u -> Doc +ps_rmoveto :: DPoint2 -> Doc ps_rmoveto (P2 x y) = command "rmoveto" [dtruncFmt x, dtruncFmt y] -- | @ ... ... lineto @ -- -ps_lineto :: PSUnit u => Point2 u -> Doc +ps_lineto :: DPoint2 -> Doc ps_lineto (P2 x y) = command "lineto" [dtruncFmt x, dtruncFmt y] -- | @ ... ... ... ... ... arc @ -- -ps_arc :: PSUnit u => Point2 u -> u -> Radian -> Radian -> Doc +ps_arc :: DPoint2 -> Double -> Radian -> Radian -> Doc ps_arc (P2 x y) radius ang1 ang2 = command "arc" $ [ dtruncFmt x , dtruncFmt y @@ -292,7 +293,7 @@ -- | @ ... ... ... ... ... ... curveto @ -- -ps_curveto :: PSUnit u => Point2 u -> Point2 u -> Point2 u -> Doc +ps_curveto :: DPoint2 -> DPoint2 -> DPoint2 -> Doc ps_curveto (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = command "curveto" $ map dtruncFmt [x1,y1, x2,y2, x3,y3] @@ -377,7 +378,7 @@ -- -- Custom Wumpus proc for filled ellipse. -- -ps_wumpus_FELL :: PSUnit u => Point2 u -> u -> u -> Doc +ps_wumpus_FELL :: DPoint2 -> Double -> Double -> Doc ps_wumpus_FELL (P2 x y) rx ry = command "FELL" $ map dtruncFmt [x, y, rx, ry] @@ -387,7 +388,7 @@ -- -- Custom Wumpus proc for stroked ellipse. -- -ps_wumpus_SELL :: PSUnit u => Point2 u -> u -> u -> Doc +ps_wumpus_SELL :: DPoint2 -> Double -> Double -> Doc ps_wumpus_SELL (P2 x y) rx ry = command "SELL" $ map dtruncFmt [x, y, rx, ry] @@ -397,14 +398,14 @@ -- -- Custom Wumpus proc for filled circle. -- -ps_wumpus_FCIRC :: PSUnit u => Point2 u -> u -> Doc +ps_wumpus_FCIRC :: DPoint2 -> Double -> Doc ps_wumpus_FCIRC (P2 x y) r = command "FCIRC" $ map dtruncFmt [x, y, r] -- | @ X Y R SCIRC @ -- -- Custom Wumpus proc for stroked circle. -- -ps_wumpus_SCIRC :: PSUnit u => Point2 u -> u -> Doc +ps_wumpus_SCIRC :: DPoint2 -> Double -> Doc ps_wumpus_SCIRC (P2 x y) r = command "SCIRC" $ map dtruncFmt [x, y, r] -- | @ SZ NAME FL @ diff --git a/src/Wumpus/Core/PtSize.hs b/src/Wumpus/Core/PtSize.hs deleted file mode 100644 --- a/src/Wumpus/Core/PtSize.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Core.PtSize --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Numeric type representing Point size (1/72 inch) which is --- PostScript and Wumpus-Core\'s internal unit size. --- --- Other unit types (e.g. centimeter) should define an --- appropriate instance of FromPtSize. --- --------------------------------------------------------------------------------- - -module Wumpus.Core.PtSize - ( - - -- * Point size type - PtSize - - -- * Extract (unscaled) PtSize as a Double - , ptSize - - -- * Conversion class - , FromPtSize(..) - - ) where - - --- | Wrapped Double representing /Point size/ for font metrics --- etc. --- -newtype PtSize = PtSize - { ptSize :: Double -- ^ Extract Point Size as a Double - } - deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) - -instance Show PtSize where - showsPrec p d = showsPrec p (ptSize d) - - --- | Convert the value of PtSize scaling accordingly. --- --- Note - the Double instance perfoms no scaling, this --- is because internally Wumpus-Core works in points. --- -class Num u => FromPtSize u where - fromPtSize :: PtSize -> u - -instance FromPtSize Double where - fromPtSize = ptSize - - - 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 @@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.SVGDoc --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2012 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- SVG Doc combinators. @@ -80,12 +80,12 @@ import Wumpus.Core.Geometry import Wumpus.Core.GraphicProps import Wumpus.Core.PictureInternal -import Wumpus.Core.Utils.Common +import Wumpus.Core.Utils.Common ( dtruncFmt ) import Wumpus.Core.Utils.FormatCombinators escapeSpecial :: Int -> Doc -escapeSpecial i = text "&#" <> int i <> char ';' +escapeSpecial i = text "&#" >< int i >< char ';' -- Note - it is easier put particular attrs at the end (esp. d @@ -99,25 +99,25 @@ svgElemB name attrs body = vcat [ open, indent 2 body, close ] where open = angles (text name <+> attrs) - close = angles (char '/' <> text name) + close = angles (char '/' >< text name) svgElemB_no_attrs :: String -> Doc -> Doc svgElemB_no_attrs name body = vcat [ open, indent 2 body, close ] where open = angles (text name) - close = angles (char '/' <> text name) + close = angles (char '/' >< text name) -- 1 line version of svgElemB -- svgElemB1 :: String -> Doc -> Doc -> Doc -svgElemB1 name attrs body = open <> body <> close +svgElemB1 name attrs body = open >< body >< close where open = angles (text name <+> attrs) - close = angles (char '/' <> text name) + close = angles (char '/' >< text name) svgAttr :: String -> Doc -> Doc -svgAttr name val = text name <> char '=' <> dquotes val +svgAttr name val = text name >< char '=' >< dquotes val dquoteText :: String -> Doc dquoteText = dquotes . text @@ -217,7 +217,7 @@ -- | @ x=\"...\" @ -- -attr_x :: PSUnit u => u -> Doc +attr_x :: Double -> Doc attr_x = svgAttr "x" . dtruncFmt @@ -225,13 +225,13 @@ -- -- /List/ version of attr_x -- -attr_xs :: PSUnit u => [u] -> Doc +attr_xs :: [Double] -> Doc attr_xs = svgAttr "x" . hsep . map dtruncFmt -- | @ y=\"...\" @ -- -attr_y :: PSUnit u => u -> Doc +attr_y :: Double -> Doc attr_y = svgAttr "y" . dtruncFmt @@ -239,34 +239,34 @@ -- -- /List/ version of attr_y -- -attr_ys :: PSUnit u => [u] -> Doc +attr_ys :: [Double] -> Doc attr_ys = svgAttr "y" . hsep . map dtruncFmt -- | @ r=\"...\" @ -- -attr_r :: PSUnit u => u -> Doc +attr_r :: Double -> Doc attr_r = svgAttr "r" . dtruncFmt -- | @ rx=\"...\" @ -- -attr_rx :: PSUnit u => u -> Doc +attr_rx :: Double -> Doc attr_rx = svgAttr "rx" . dtruncFmt -- | @ ry=\"...\" @ -- -attr_ry :: PSUnit u => u -> Doc +attr_ry :: Double -> Doc attr_ry = svgAttr "ry" . dtruncFmt -- | @ cx=\"...\" @ -- -attr_cx :: PSUnit u => u -> Doc +attr_cx :: Double -> Doc attr_cx = svgAttr "cx" . dtruncFmt -- | @ cy=\"...\" @ -- -attr_cy :: PSUnit u => u -> Doc +attr_cy :: Double -> Doc attr_cy = svgAttr "cy" . dtruncFmt @@ -280,21 +280,21 @@ -- -- c.f. PostScript's @moveto@. -- -path_m :: PSUnit u => Point2 u -> Doc +path_m :: DPoint2 -> Doc path_m (P2 x y) = char 'M' <+> dtruncFmt x <+> dtruncFmt y -- | @ L ... ... @ -- -- c.f. PostScript's @lineto@. -- -path_l :: PSUnit u => Point2 u -> Doc +path_l :: DPoint2 -> Doc path_l (P2 x y) = char 'L' <+> dtruncFmt x <+> dtruncFmt y -- | @ C ... ... ... ... ... ... @ -- -- c.f. PostScript's @curveto@. -- -path_c :: PSUnit u => Point2 u -> Point2 u -> Point2 u -> Doc +path_c :: DPoint2 -> DPoint2 -> DPoint2 -> Doc path_c (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = char 'C' <+> dtruncFmt x1 <+> dtruncFmt y1 <+> dtruncFmt x2 <+> dtruncFmt y2 @@ -303,7 +303,7 @@ val_rgb :: RGBi -> Doc val_rgb (RGBi r g b) = - text "rgb" <> tupled [integral r, integral g, integral b] + text "rgb" >< tupled [integral r, integral g, integral b] -- | @ font-family=\"...\" @ @@ -349,13 +349,13 @@ -- | @ stroke-width=\"...\" @ -- -attr_stroke_width :: PSUnit u => u -> Doc +attr_stroke_width :: Double -> Doc attr_stroke_width = svgAttr "stroke-width" . dtruncFmt -- | @ stroke-miterlimit=\"...\" @ -- -attr_stroke_miterlimit :: PSUnit u => u -> Doc +attr_stroke_miterlimit :: Double -> Doc attr_stroke_miterlimit = svgAttr "stroke-miterlimit" . dtruncFmt -- | @ stroke-linejoin=\"...\" @ @@ -384,8 +384,8 @@ attr_stroke_dasharray = svgAttr "stroke-dasharray" . step where step [] = empty - step [(a,b)] = int a <> comma <> int b - step ((a,b):xs) = int a <> comma <> int b <> step xs + step [(a,b)] = int a >< comma >< int b + step ((a,b):xs) = int a >< comma >< int b >< step xs -- | @ stroke-dasharray=\"none\" @ -- @@ -400,7 +400,7 @@ -- | @ clip_path="url(#...)" @ -- attr_clip_path :: String -> Doc -attr_clip_path ss = svgAttr "clip-path" (text "url" <> parens (text $ '#':ss)) +attr_clip_path ss = svgAttr "clip-path" (text "url" >< parens (text $ '#':ss)) -- | @ transform="..." @ @@ -410,12 +410,21 @@ -- | @ matrix(..., ..., ..., ..., ..., ...) @ -- -val_matrix :: PSUnit u => Matrix3'3 u -> Doc -val_matrix mtrx = text "matrix" <> tupled (map dtruncFmt [a,b,c,d,e,f]) +val_matrix :: Matrix3'3 Double -> Doc +val_matrix mtrx = text "matrix" >< tupled (map dtruncFmt [a,b,c,d,e,f]) where (a,b,c,d,e,f) = deconsMatrix mtrx + -- Note - Matrix is problematic for units. + -- e.g. for pica (12 ps points) we don\'t want to scale the + -- identity matrix by 12: + -- + -- > fmap (12*) [1,0,0,0,0,1] + -- > [12,0,0,0,0,12] + -- + + -- | @ translate(..., ..., ..., ..., ..., ...) @ -- -val_translate :: PSUnit u => Vec2 u -> Doc -val_translate (V2 x y) = text "translate" <> tupled [dtruncFmt x, dtruncFmt y] +val_translate :: DVec2 -> Doc +val_translate (V2 x y) = text "translate" >< tupled [dtruncFmt x, dtruncFmt y] diff --git a/src/Wumpus/Core/Text/Base.hs b/src/Wumpus/Core/Text/Base.hs --- a/src/Wumpus/Core/Text/Base.hs +++ b/src/Wumpus/Core/Text/Base.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.Text.Base --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2012 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -79,10 +79,11 @@ ) where import Wumpus.Core.Utils.FormatCombinators +import Wumpus.Core.Utils.HList import Data.Char import qualified Data.IntMap as IntMap - +import Data.Monoid -- | Internal string representation for Wumpus-Core. -- @@ -90,17 +91,20 @@ -- may be either a regular character, an integer representing a -- Unicode code-point or a PostScript glyph name. -- -newtype EscapedText = EscapedText { getEscapedText :: [EscapedChar] } - deriving (Eq,Show) +newtype EscapedText = EscapedText { getEscapedText :: H EscapedChar } + -- | Internal character representation for Wumpus-Core. -- -- An 'EscapedChar' may be either a regular character, an integer -- representing a Unicode code-point or a PostScript glyph -- name. -- +-- PostScript glyph names are generally made up only of chars +-- @[a-zA-Z]@. +-- data EscapedChar = CharLiteral Char | CharEscInt Int | CharEscName String @@ -115,16 +119,30 @@ -------------------------------------------------------------------------------- +escapedTextList :: EscapedText -> [EscapedChar] +escapedTextList = toListH . getEscapedText + +instance Eq EscapedText where + (==) a b = escapedTextList a == escapedTextList b + +instance Show EscapedText where + show = show . escapedTextList + + instance Format EscapedText where - format = hcat . map format . getEscapedText + format = hcat . map format . escapedTextList instance Format EscapedChar where format (CharLiteral c) = char c - format (CharEscInt i) = text "&#" <> int i <> semicolon - format (CharEscName s) = text "&" <> text s <> semicolon + format (CharEscInt i) = text "&#" >< int i >< semicolon + format (CharEscName s) = text "&" >< text s >< semicolon +instance Monoid EscapedText where + mempty = EscapedText emptyH + a `mappend` b = EscapedText $ getEscapedText a `appendH` getEscapedText b + -------------------------------------------------------------------------------- @@ -156,12 +174,12 @@ -- | Build an 'EscapedText' from a single 'EscChar'. -- wrapEscChar :: EscapedChar -> EscapedText -wrapEscChar ec = EscapedText [ec] +wrapEscChar ec = EscapedText $ wrapH ec -- | /Destructor/ for 'EscapedText'. -- destrEscapedText :: ([EscapedChar] -> a) -> EscapedText -> a -destrEscapedText f = f . getEscapedText +destrEscapedText f = f . escapedTextList -- | Get the character count of an 'EscapedText' string. @@ -178,15 +196,15 @@ -- -lexer :: String -> [EscapedChar] -lexer [] = [] +lexer :: String -> H EscapedChar +lexer [] = emptyH lexer ('&':'#':cs) = escNumStart cs lexer ('&':cs) = escName cs -lexer (c:cs) = CharLiteral c : lexer cs +lexer (c:cs) = CharLiteral c `consH` lexer cs -- Input is malformed if this reaches the @rest@ case. -- -escNumStart :: String -> [EscapedChar] +escNumStart :: String -> H EscapedChar escNumStart ('0':'o':cs) = escOct cs escNumStart ('0':'O':cs) = escOct cs escNumStart ('0':'x':cs) = escHex cs @@ -194,32 +212,32 @@ escNumStart (c:cs) | isDigit c = escDec (digitToInt c) cs escNumStart rest = chompToSemi rest -escName :: String -> [EscapedChar] -escName (c:cs) = let (ss,rest) = span isAlphaNum cs - in specialEscape (c:ss) : chompToSemi rest -escName [] = [] +escName :: String -> H EscapedChar +escName (c:cs) = let (ss,rest) = span isAlphaNum cs + in specialEscape (c:ss) `consH` chompToSemi rest +escName [] = emptyH -- | One digit consumed already... -- -escDec :: Int -> String -> [EscapedChar] +escDec :: Int -> String -> H EscapedChar escDec n (c:cs) | isDigit c = escDec (n*10 + digitToInt c) cs -escDec n cs | n > 0 = CharEscInt n : chompToSemi cs +escDec n cs | n > 0 = CharEscInt n `consH` chompToSemi cs | otherwise = chompToSemi cs -escHex :: String -> [EscapedChar] +escHex :: String -> H EscapedChar escHex = step 0 where step n (c:cs) | isHexDigit c = step (n*16 + digitToInt c) cs - step n cs | n > 0 = CharEscInt n : chompToSemi cs + step n cs | n > 0 = CharEscInt n `consH` chompToSemi cs | otherwise = chompToSemi cs -escOct :: String -> [EscapedChar] +escOct :: String -> H EscapedChar escOct = step 0 where step n (c:cs) | isHexDigit c = step (n*8 + digitToInt c) cs - step n cs | n > 0 = CharEscInt n : chompToSemi cs + step n cs | n > 0 = CharEscInt n `consH` chompToSemi cs | otherwise = chompToSemi cs @@ -227,10 +245,10 @@ -- The last two conditions both indicate ill-formed input, but it -- is /best/ if the lexer does not throw errors. -- -chompToSemi :: String -> [EscapedChar] +chompToSemi :: String -> H EscapedChar chompToSemi (';':cs) = lexer cs chompToSemi (_:cs) = chompToSemi cs -chompToSemi [] = [] +chompToSemi [] = emptyH -- | Special processing for @amp@ because it is so common. diff --git a/src/Wumpus/Core/TrafoInternal.hs b/src/Wumpus/Core/TrafoInternal.hs --- a/src/Wumpus/Core/TrafoInternal.hs +++ b/src/Wumpus/Core/TrafoInternal.hs @@ -1,12 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.TrafoInternal --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2012 -- License : BSD3 -- --- Maintainer : Stephen Tetley +-- Maintainer : stephen.tetley@gmail.com -- Stability : unstable -- Portability : GHC -- @@ -27,12 +28,14 @@ -- * Types PrimCTM(..) + , AffineTrafo(..) -- * CTM operations , identityCTM , makeThetaCTM , makeTranslCTM + , startPointCTM , translateCTM , scaleCTM @@ -50,9 +53,10 @@ import Wumpus.Core.AffineTrans import Wumpus.Core.Geometry -import Wumpus.Core.Utils.Common +import Wumpus.Core.Utils.Common ( dtruncFmt ) import Wumpus.Core.Utils.FormatCombinators +-- Note - PrimCTM can be specialized to Double. -- Primitives support affine transformations. -- @@ -62,65 +66,82 @@ -- -- Note - line thickness of a stroked path will not be scaled. -- -data PrimCTM u = PrimCTM - { ctm_transl_x :: !u - , ctm_transl_y :: !u - , ctm_scale_x :: !u - , ctm_scale_y :: !u +data PrimCTM = PrimCTM + { ctm_trans_x :: !Double + , ctm_trans_y :: !Double + , ctm_scale_x :: !Double + , ctm_scale_y :: !Double , ctm_rotation :: !Radian } deriving (Eq,Show) +type instance DUnit PrimCTM = Double -- | For Pictures - Affine transformations are represented as -- /syntax/ so they can be manipulated easily. -- -data AffineTrafo u = Matrix (Matrix3'3 u) - | Rotate Radian - | RotAbout Radian (Point2 u) - | Scale u u - | Translate u u +data AffineTrafo = Matrix (Matrix3'3 Double) + | Rotate Radian + | RotAbout Radian (Point2 Double) + | Scale Double Double + | Translate Double Double deriving (Eq,Show) - +type instance DUnit AffineTrafo = Double +-------------------------------------------------------------------------------- +-- instances -instance PSUnit u => Format (PrimCTM u) where +instance Format PrimCTM where format (PrimCTM dx dy sx sy ang) = - parens (text "CTM" <+> text "dx =" <> dtruncFmt dx - <+> text "dy =" <> dtruncFmt dy - <+> text "sx =" <> dtruncFmt sx - <+> text "sy =" <> dtruncFmt sy - <+> text "ang=" <> format ang ) - + parens (text "CTM" <+> text "dx =" >< dtruncFmt dx + <+> text "dy =" >< dtruncFmt dy + <+> text "sx =" >< dtruncFmt sx + <+> text "sy =" >< dtruncFmt sy + <+> text "ang=" >< format ang ) -------------------------------------------------------------------------------- -- Manipulating the PrimCTM -identityCTM :: Num u => PrimCTM u -identityCTM = PrimCTM { ctm_transl_x = 0, ctm_transl_y = 0 - , ctm_scale_x = 1, ctm_scale_y = 1 - , ctm_rotation = 0 } +identityCTM :: PrimCTM +identityCTM = PrimCTM { ctm_trans_x = 0 + , ctm_trans_y = 0 + , ctm_scale_x = 1 + , ctm_scale_y = 1 + , ctm_rotation = 0 } -makeThetaCTM :: Num u => u -> u -> Radian -> PrimCTM u -makeThetaCTM dx dy ang = PrimCTM { ctm_transl_x = dx, ctm_transl_y = dy - , ctm_scale_x = 1, ctm_scale_y = 1 + +makeThetaCTM :: Double -> Double -> Radian -> PrimCTM +makeThetaCTM dx dy ang = PrimCTM { ctm_trans_x = dx + , ctm_trans_y = dy + , ctm_scale_x = 1 + , ctm_scale_y = 1 , ctm_rotation = ang } -makeTranslCTM :: Num u => u -> u -> PrimCTM u -makeTranslCTM dx dy = PrimCTM { ctm_transl_x = dx, ctm_transl_y = dy - , ctm_scale_x = 1, ctm_scale_y = 1 +makeTranslCTM :: Double -> Double -> PrimCTM +makeTranslCTM dx dy = PrimCTM { ctm_trans_x = dx + , ctm_trans_y = dy + , ctm_scale_x = 1 + , ctm_scale_y = 1 , ctm_rotation = 0 } +startPointCTM :: DPoint2 -> PrimCTM +startPointCTM (P2 x y) = PrimCTM { ctm_trans_x = x + , ctm_trans_y = y + , ctm_scale_x = 1 + , ctm_scale_y = 1 + , ctm_rotation = 0 } -translateCTM :: Num u => u -> u -> PrimCTM u -> PrimCTM u + + +translateCTM :: Double -> Double -> PrimCTM -> PrimCTM translateCTM x1 y1 (PrimCTM dx dy sx sy ang) = PrimCTM (x1+dx) (y1+dy) sx sy ang @@ -132,19 +153,25 @@ -- It is expected that the point is extracted from the matrix, so -- scales and rotations operate on the point coordinates as well -- as the scale and rotation components. +-- -scaleCTM :: Num u => u -> u -> PrimCTM u -> PrimCTM u +-- | Scale the CTM. +-- +scaleCTM :: Double -> Double -> PrimCTM -> PrimCTM scaleCTM x1 y1 (PrimCTM dx dy sx sy ang) = let P2 x y = scale x1 y1 (P2 dx dy) in PrimCTM x y (x1*sx) (y1*sy) ang -rotateCTM :: (Real u, Floating u) => Radian -> PrimCTM u -> PrimCTM u +-- | Rotate the CTM. +-- +rotateCTM :: Radian -> PrimCTM -> PrimCTM rotateCTM theta (PrimCTM dx dy sx sy ang) = let P2 x y = rotate theta (P2 dx dy) in PrimCTM x y sx sy (circularModulo $ theta+ang) -rotateAboutCTM :: (Real u, Floating u) - => Radian -> Point2 u -> PrimCTM u -> PrimCTM u +-- | RotateAbout the CTM. +-- +rotateAboutCTM :: Radian -> DPoint2 -> PrimCTM -> PrimCTM rotateAboutCTM theta pt (PrimCTM dx dy sx sy ang) = let P2 x y = rotateAbout theta pt (P2 dx dy) in PrimCTM x y sx sy (circularModulo $ theta+ang) @@ -157,7 +184,7 @@ -- This function encapsulates the correct order (or does it? - -- some of the demos are not working properly...). -- -matrixRepCTM :: (Real u, Floating u) => PrimCTM u -> Matrix3'3 u +matrixRepCTM :: PrimCTM -> Matrix3'3 Double matrixRepCTM (PrimCTM dx dy sx sy ang) = translationMatrix dx dy * rotationMatrix (circularModulo ang) * scalingMatrix sx sy @@ -169,7 +196,7 @@ -- If the residual CTM is the identity CTM, the SVG or PostScript -- output can be optimized. -- -unCTM :: Num u => PrimCTM u -> (Point2 u, PrimCTM u) +unCTM :: PrimCTM -> (DPoint2, PrimCTM) unCTM (PrimCTM dx dy sx sy ang) = (P2 dx dy, PrimCTM 0 0 sx sy ang) @@ -178,10 +205,10 @@ -concatTrafos :: (Floating u, Real u) => [AffineTrafo u] -> Matrix3'3 u +concatTrafos :: [AffineTrafo] -> Matrix3'3 Double concatTrafos = foldr (\e ac -> matrixRepr e * ac) identityMatrix -matrixRepr :: (Floating u, Real u) => AffineTrafo u -> Matrix3'3 u +matrixRepr :: AffineTrafo -> Matrix3'3 Double matrixRepr (Matrix mtrx) = mtrx matrixRepr (Rotate theta) = rotationMatrix theta matrixRepr (RotAbout theta pt) = originatedRotationMatrix theta pt diff --git a/src/Wumpus/Core/Utils/Common.hs b/src/Wumpus/Core/Utils/Common.hs --- a/src/Wumpus/Core/Utils/Common.hs +++ b/src/Wumpus/Core/Utils/Common.hs @@ -4,11 +4,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.Utils.Common --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Utility functions and a Hughes list. @@ -19,18 +19,8 @@ module Wumpus.Core.Utils.Common ( - -- | Opt - maybe strict in Some - Opt(..) - , some - - -- | Conditional application - , applyIf - - , rescale - -- * Truncate / print a double - , PSUnit(..) - , dtruncFmt + dtruncFmt , truncateDouble , roundup @@ -47,56 +37,17 @@ import qualified Wumpus.Core.Utils.FormatCombinators as Fmt -import Data.Ratio import Data.Time -data Opt a = None | Some !a - deriving (Eq,Show) -some :: a -> Opt a -> a -some dflt None = dflt -some _ (Some a) = a -applyIf :: Bool -> (a -> a) -> a -> a -applyIf cond fn a = if cond then fn a else a - --- rescale a (originally in the range amin to amax) within the --- the range bmin to bmax. --- -rescale :: Fractional a => (a,a) -> (a,a) -> a -> a -rescale (amin,amax) (bmin,bmax) a = - bmin + apos * (brange / arange) - where - arange = amax - amin - brange = bmax - bmin - apos = a - amin - - -------------------------------------------------------------------------------- -- PS Unit -class Num a => PSUnit a where - toDouble :: a -> Double - dtrunc :: a -> String - - dtrunc = truncateDouble . toDouble - -instance PSUnit Double where - toDouble = id - dtrunc = truncateDouble - -instance PSUnit Float where - toDouble = realToFrac - -instance PSUnit (Ratio Integer) where - toDouble = realToFrac - -instance PSUnit (Ratio Int) where - toDouble = realToFrac - -dtruncFmt :: PSUnit a => a -> Fmt.Doc -dtruncFmt = Fmt.text . dtrunc +-- +dtruncFmt :: Double -> Fmt.Doc +dtruncFmt = Fmt.text . truncateDouble -- | Truncate the printed decimal representation of a Double. diff --git a/src/Wumpus/Core/Utils/FormatCombinators.hs b/src/Wumpus/Core/Utils/FormatCombinators.hs --- a/src/Wumpus/Core/Utils/FormatCombinators.hs +++ b/src/Wumpus/Core/Utils/FormatCombinators.hs @@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.Utils.FormatCombinators --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2012 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- -- Formatting combinators - pretty printers without the fitting. @@ -21,7 +21,7 @@ , Format(..) , empty , showsDoc - , (<>) + , (><) , (<+>) , vconcat , separate @@ -117,14 +117,25 @@ instance Monoid Doc where mempty = empty - mappend = (<>) + mappend = (><) +-------------------------------------------------------------------------------- + class Format a where format :: a -> Doc +instance Format Int where + format = int + +instance Format Integer where + format = integer + +instance Format Double where + format = double + + -------------------------------------------------------------------------------- -infixr 6 <>, <+> @@ -139,13 +150,17 @@ showsDoc = Doc1 +infixr 6 >< + -- | Horizontally concatenate two documents with no space -- between them. -- -(<>) :: Doc -> Doc -> Doc -a <> b = Join a b +(><) :: Doc -> Doc -> Doc +a >< b = Join a b +infixr 6 <+> + -- | Horizontally concatenate two documents with a single space -- between them. -- @@ -155,7 +170,7 @@ -- | Vertical concatenate two documents with a line break. -- vconcat :: Doc -> Doc -> Doc -vconcat a b = a <> Line <> b +vconcat a b = a >< Line >< b @@ -164,12 +179,12 @@ separate sep (a:as) = step a as where step acc [] = acc - step acc (x:xs) = step (acc <> sep <> x) xs + step acc (x:xs) = step (acc >< sep >< x) xs -- | Horizontally concatenate a list of documents with @(\<\>)@. -- hcat :: [Doc] -> Doc -hcat = foldr (<>) empty +hcat = foldr (><) empty -- | Horizontally concatenate a list of documents with @(\<+\>)@. -- @@ -276,17 +291,17 @@ punctuate :: Doc -> [Doc] -> Doc punctuate _ [] = empty punctuate _ [x] = x -punctuate s (x:xs) = x <> s <> punctuate s xs +punctuate s (x:xs) = x >< s >< punctuate s xs -- | Enclose the final Doc within the first two. -- -- There are no spaces between the documents: -- --- > enclose l r d = l <> d <> r +-- > enclose l r d = l >< d >< r -- enclose :: Doc -> Doc -> Doc -> Doc -enclose l r d = l <> d <> r +enclose l r d = l >< d >< r diff --git a/src/Wumpus/Core/Utils/JoinList.hs b/src/Wumpus/Core/Utils/JoinList.hs --- a/src/Wumpus/Core/Utils/JoinList.hs +++ b/src/Wumpus/Core/Utils/JoinList.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.Utils.JoinList --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- A \"join list\" datatype and operations. @@ -32,7 +32,7 @@ -- * Conversion between join lists and regular lists , fromList , toList - , toListF + , toListF_rl -- * Construction , one @@ -110,7 +110,7 @@ -- | Convert a join list to a regular list. -- toList :: JoinList a -> [a] -toList = joinfoldl (flip (:)) [] +toList = joinfoldr (:) [] -- | Build a join list from a regular list. -- @@ -125,10 +125,10 @@ fromList (x:xs) = Join (One x) (fromList xs) --- Note -- this works from Right to left... +-- Note -- this works from Right to Left... -- -toListF :: (a -> b) -> JoinList a -> [b] -toListF f = step [] +toListF_rl :: (a -> b) -> JoinList a -> [b] +toListF_rl f = step [] where step acc (One x) = f x : acc step acc (Join t u) = let acc' = step acc u in step acc' t @@ -153,6 +153,8 @@ one :: a -> JoinList a one = One + +infixr 5 `cons` -- | Cons an element to the front of the join list. -- 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 @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.VersionNumber --- Copyright : (c) Stephen Tetley 2010-2011 +-- Copyright : (c) Stephen Tetley 2010-2012 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -22,7 +22,7 @@ -- | Version number. -- --- > (0,42,0) +-- > (0,52,1) -- wumpus_core_version :: (Int,Int,Int) -wumpus_core_version = (0,42,0) +wumpus_core_version = (0,52,1) 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 @@ -3,10 +3,10 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.WumpusTypes --- Copyright : (c) Stephen Tetley 2009-2010 +-- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 -- --- Maintainer : Stephen Tetley +-- Maintainer : stephen.tetley@gmail.com -- Stability : unstable -- Portability : GHC -- @@ -34,26 +34,42 @@ -- * Picture types Picture - , DPicture , FontCtx , Primitive - , DPrimitive , XLink + , SvgAttr , PrimPath - , DPrimPath , PrimPathSegment - , DPrimPathSegment + , AbsPathSegment , PrimLabel - , DPrimLabel , KerningChar - , DKerningChar - -- * Printable unit for PostScript - , PSUnit(..) + , Format(..) + , stringformat + ) where import Wumpus.Core.PictureInternal -import Wumpus.Core.Utils.Common ( PSUnit(..) ) +import Wumpus.Core.Utils.FormatCombinators ( Format(..), text, Doc ) + + + +-- | 'stringformat' : String -> Doc +-- +-- The format combinators are not exported by Wumpus-Core, +-- however for debugging unit types might need to be made +-- instances of the 'Format' class. +-- +-- To define Format instances render the unit type to a String +-- then use 'stringformat', e.g: +-- +-- > +-- > instance Format Pica where +-- > format a = stringformat (show a) +-- > +-- +stringformat :: String -> Doc +stringformat = text 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.42.0 +version: 0.52.1 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -12,9 +12,10 @@ Wumpus-Core is a low-level library for generating static 2D vector pictures, its salient feature is portability due to no FFI dependencies. It can generate PostScript (EPS) files and SVG - files. The generated PostScript code is plain and reasonably + files. The generated PostScript code is plain and someways efficient as the use of stack operations, i.e @gsave@ and - @grestore@, is minimized. + @grestore@, is minimized (unfortunately there is no sharing + so the generated PostScript can be huge...). . Although Wumpus-Core only generates vector output, the generated PostScript can be interpreted by GraphicsMagick or a similar @@ -24,8 +25,8 @@ themselves are made from points. The usual affine transformations (rotations, scaling, translations) can be applied to Pictures. Unlike PostScript there is no notion of a - current point, Wumpus-Core builds pictures in a coordinate-free - style. + current point, Wumpus-Core builds pictures by direct + positioning of each element. . GENERAL DRAWBACKS... . @@ -39,8 +40,8 @@ than re-usable libraries). . Also, some of the design decisions made for Wumpus-Core are not - sophisticated - e.g. how path and text attributes like colour are - handled, and how the bounding boxes of text labels are + sophisticated - e.g. how path and text attributes like colour + are handled, and how the bounding boxes of text labels are calculated. Compared to other systems, Wumpus might be rather limited, however, the design permits a fairly simple implementation. @@ -48,21 +49,89 @@ . Changelog: . - v0.41.0 to v0.42.0: + v0.52.0 to v0.52.1: . - * Removed the function @oboundingBox@ from @Core.BoundingBox@. - It was unused in Wumpus-Core and had unwise error handling - baked-in. + * Removed internal @(<>)@ format combinator that caused + problems for GHC 7.4. . - * Renamed @direction@ in @Wumpus.Core.Geometry@, it is now - @vdirection@. + v0.51.0 to v0.52.0: . - * Fixed internal Foldable instances for JoinList. The left and - right folds worked in the wrong direction. + * Added limited support for adding SVG ids to text and + Primitives. . - * Some improvements to the Haddock documentation. + * Fixed types of @d2r@ and @r2d@ to Double for degrees, rather + than a parametric (Real a, Floating a) type. Although this is + less general, it removes the burden of type annotating the + common case. . + * Added the vector functions @orthoVec@, @vsum@ and @vdiff@ to + @Core.Geometry@. . + * Re-named @clip@ to @clipPrimitive@ + . + v0.50.0 to v0.51.0: + . + * Added special cases to handle continuity to the function + @lineDirection@ in @Core.Geometry@. + . + * Added @zeroVec@ to @Core.Geometry@. + . + * Extended some Haddock documentation. + . + v0.43.0 to v0.50.0: + . + * Major change hence the version number jump - the notion of + parametric unit has been removed from the @Picture@ objects + (it for remains the @Geometric@ objects @Point2@, @Vec2@ etc.). + Certain useful units, e.g. @em@ and @en@, are contextual on + the \"current point size\", and having a parametric unit here + was actually a hinderance to supporting units properly in + higher-level layers. Now all Picture objects (those defined + or exported from @Core.Picture@) are fixed to use Double + - representing PostScript points. Higher level layers that + intend to support alternative units must translate drawing + objects to PostScript point measurements /before/ calling the + Picture API. Geometric objects - objects defined in + @Core.Geometry@, e.g. @Point2@, @Vec2@ - are still polymorphic + on unit. + . + * Picture API change - Various function names changed. + @lineTo@ becomes @absLineTo@ and @curveTo@ becomes + @absCurveTo@. The path builders are qualified with /Prim/, + @vertexPath@ becomes @vertexPrimPath@, @vectorPath@ becomes + @vectorPrimPath@, @emptyPath@ becomes @emptyPrimPath@ and + @curvedPath@ becomes @curvedPrimPath@. @xlink@ becomes + @xlinkPrim@. + . + * API change - @PtSize@ data type replaced by @AfmUnit@ for font + measurements. + . + * API and representation change - clipping paths are represented + as @Primitive@ constructor rather than a @Picture@ constructor. + This should make them more useful. The type of the function + @clip@ in @Core.Picture@ has likewise changed. + . + * Picture API change - changed @primPath@ to @absPrimPath@, added + the functions @relPrimPath@, @relLineTo@, @relCurveTo@. + . + * Added the class @Tolerance@ to @Core.Geometry@ and made the Eq + instances of @Point2@, @Vec2@ and @BoundingBox@ tolerant. + Tolerance accounts for a fairly lax equality on floating point + numbers - it is suitable for Wumpus (printing) where high + accuracy is needed. + . + v0.42.1 to v0.43.0: + . + * API change - the function @bezierCircle@ in @Core.Geometry@ + has changed. It now implements a better method of drawing + circles with Bezier curves and no longer needs the + subvision factor. The old circle drawing function has been + retained as @subdivisionCircle@ as it is useful for + corroborating @bezierCircle@, but the general use of + @subdivisionCircle@ should be avoided. + . + * Added a function @bezierEllipse@ to @Core.Geometry@. + . build-type: Simple stability: unstable cabal-version: >= 1.2 @@ -74,7 +143,9 @@ demo/AffineTest02.hs, demo/AffineTest03.hs, demo/AffineTestBase.hs, + demo/ClipPic.hs, demo/DeltaPic.hs, + demo/EllipsePic.hs, demo/FontMetrics.hs, demo/Hyperlink.hs, demo/KernPic.hs, @@ -111,7 +182,6 @@ Wumpus.Core.OutputPostScript, Wumpus.Core.OutputSVG, Wumpus.Core.Picture, - Wumpus.Core.PtSize, Wumpus.Core.Text.Base, Wumpus.Core.Text.GlyphIndices, Wumpus.Core.Text.GlyphNames,