wumpus-core 0.42.0 → 0.52.1
raw patch · 45 files changed
Files
- CHANGES +106/−0
- demo/AffineTest01.hs +2/−2
- demo/AffineTest02.hs +2/−3
- demo/AffineTest03.hs +2/−2
- demo/AffineTestBase.hs +31/−30
- demo/ClipPic.hs +49/−0
- demo/DeltaPic.hs +3/−5
- demo/EllipsePic.hs +38/−0
- demo/FontMetrics.hs +7/−7
- demo/Hyperlink.hs +6/−4
- demo/KernPic.hs +10/−9
- demo/LabelPic.hs +10/−11
- demo/Latin1Pic.hs +2/−2
- demo/MultiPic.hs +8/−8
- demo/TextBBox.hs +7/−8
- demo/TransformEllipse.hs +19/−17
- demo/TransformPath.hs +22/−20
- demo/TransformTextlabel.hs +34/−33
- demo/ZOrderPic.hs +4/−4
- doc-src/Guide.lhs +72/−73
- doc-src/WorldFrame.hs +9/−7
- doc/Guide.pdf binary
- src/Wumpus/Core.hs +2/−5
- src/Wumpus/Core/AffineTrans.hs +91/−45
- src/Wumpus/Core/BoundingBox.hs +27/−19
- src/Wumpus/Core/Colour.hs +5/−5
- src/Wumpus/Core/FontSize.hs +75/−63
- src/Wumpus/Core/Geometry.hs +336/−65
- src/Wumpus/Core/GraphicProps.hs +91/−6
- src/Wumpus/Core/OutputPostScript.hs +58/−72
- src/Wumpus/Core/OutputSVG.hs +94/−81
- src/Wumpus/Core/PageTranslation.hs +28/−20
- src/Wumpus/Core/Picture.hs +201/−155
- src/Wumpus/Core/PictureInternal.hs +301/−231
- src/Wumpus/Core/PostScriptDoc.hs +19/−18
- src/Wumpus/Core/PtSize.hs +0/−61
- src/Wumpus/Core/SVGDoc.hs +41/−32
- src/Wumpus/Core/Text/Base.hs +43/−25
- src/Wumpus/Core/TrafoInternal.hs +67/−40
- src/Wumpus/Core/Utils/Common.hs +7/−56
- src/Wumpus/Core/Utils/FormatCombinators.hs +29/−14
- src/Wumpus/Core/Utils/JoinList.hs +8/−6
- src/Wumpus/Core/VersionNumber.hs +3/−3
- src/Wumpus/Core/WumpusTypes.hs +27/−11
- wumpus-core.cabal +87/−17
CHANGES view
@@ -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
demo/AffineTest01.hs view
@@ -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
demo/AffineTest02.hs view
@@ -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
demo/AffineTest03.hs view
@@ -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
demo/AffineTestBase.hs view
@@ -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) + ]
+ demo/ClipPic.hs view
@@ -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)+ ]++
demo/DeltaPic.hs view
@@ -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
+ demo/EllipsePic.hs view
@@ -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+
demo/FontMetrics.hs view
@@ -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
demo/Hyperlink.hs view
@@ -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"++
demo/KernPic.hs view
@@ -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
demo/LabelPic.hs view
@@ -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]
demo/Latin1Pic.hs view
@@ -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
demo/MultiPic.hs view
@@ -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.
demo/TextBBox.hs view
@@ -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
demo/TransformEllipse.hs view
@@ -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
demo/TransformPath.hs view
@@ -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
demo/TransformTextlabel.hs view
@@ -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
demo/ZOrderPic.hs view
@@ -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)
doc-src/Guide.lhs view
@@ -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
doc-src/WorldFrame.hs view
@@ -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 }+
doc/Guide.pdf view
binary file changed (68361 → 67925 bytes)
src/Wumpus/Core.hs view
@@ -3,10 +3,10 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core--- Copyright : (c) Stephen Tetley 2009-2010+-- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 ----- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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
src/Wumpus/Core/AffineTrans.hs view
@@ -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) --------------------------------------------------------------------------------
src/Wumpus/Core/BoundingBox.hs view
@@ -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
src/Wumpus/Core/Colour.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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 --------------------------------------------------------------------------------
src/Wumpus/Core/FontSize.hs view
@@ -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)
src/Wumpus/Core/Geometry.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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
src/Wumpus/Core/GraphicProps.hs view
@@ -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
src/Wumpus/Core/OutputPostScript.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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+
src/Wumpus/Core/OutputSVG.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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 + }
src/Wumpus/Core/PageTranslation.hs view
@@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.PageTranslation--- Copyright : (c) Stephen Tetley 2010+-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 ----- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>--- 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
src/Wumpus/Core/Picture.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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 @\<g\>@ 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 @\<g\>@ +-- 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 +
src/Wumpus/Core/PictureInternal.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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 ...> ... </a>@ .+-- * A hyperlink inside @<a ...> ... </a>@ . ----- A group - @<g ...> ... </g>@+-- * A group - @<g ...> ... </g>@ ----- 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 \<g\> 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
src/Wumpus/Core/PostScriptDoc.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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 @
− src/Wumpus/Core/PtSize.hs
@@ -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---
src/Wumpus/Core/SVGDoc.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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]
src/Wumpus/Core/Text/Base.hs view
@@ -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.
src/Wumpus/Core/TrafoInternal.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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
src/Wumpus/Core/Utils/Common.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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.
src/Wumpus/Core/Utils/FormatCombinators.hs view
@@ -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 <stephen.tetley@gmail.com>--- 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
src/Wumpus/Core/Utils/JoinList.hs view
@@ -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. --
src/Wumpus/Core/VersionNumber.hs view
@@ -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)
src/Wumpus/Core/WumpusTypes.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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
wumpus-core.cabal view
@@ -1,5 +1,5 @@ name: wumpus-core-version: 0.42.0+version: 0.52.1 license: BSD3 license-file: LICENSE copyright: Stephen Tetley <stephen.tetley@gmail.com>@@ -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,