wumpus-core 0.43.0 → 0.50.0

raw patch · 44 files changed

+1412/−1152 lines, 44 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• demo/AffineTest01.hs +2/−2
• demo/AffineTest02.hs +2/−3
• demo/AffineTest03.hs +2/−2
• demo/AffineTestBase.hs +31/−30
• demo/ClipPic.hs +48/−0
• demo/DeltaPic.hs +3/−5
• demo/EllipsePic.hs +7/−7
• demo/FontMetrics.hs +7/−7
• demo/Hyperlink.hs +4/−2
• 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 +17/−15
• demo/TransformPath.hs +20/−18
• 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 +24/−16
• src/Wumpus/Core/Colour.hs +3/−3
• src/Wumpus/Core/FontSize.hs +75/−63
• src/Wumpus/Core/Geometry.hs +155/−56
• src/Wumpus/Core/GraphicProps.hs +25/−1
• src/Wumpus/Core/OutputPostScript.hs +57/−71
• src/Wumpus/Core/OutputSVG.hs +58/−64
• src/Wumpus/Core/PageTranslation.hs +28/−20
• src/Wumpus/Core/Picture.hs +143/−127
• src/Wumpus/Core/PictureInternal.hs +234/−218
• src/Wumpus/Core/PostScriptDoc.hs +19/−18
• src/Wumpus/Core/PtSize.hs +0/−61
• src/Wumpus/Core/SVGDoc.hs +29/−20
• src/Wumpus/Core/Text/Base.hs +4/−1
• src/Wumpus/Core/TrafoInternal.hs +62/−35
• src/Wumpus/Core/Utils/Common.hs +7/−56
• src/Wumpus/Core/Utils/FormatCombinators.hs +15/−3
• src/Wumpus/Core/Utils/JoinList.hs +8/−6
• src/Wumpus/Core/VersionNumber.hs +2/−2
• src/Wumpus/Core/WumpusTypes.hs +26/−11
• wumpus-core.cabal +46/−4

@@ -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

@@ -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

@@ -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

@@ -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)
+    ]

@@ -0,0 +1,48 @@+{-# 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 = clip 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)+    ]++

@@ -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

@@ -14,25 +14,25 @@     writeSVG "./out/ellipse01.svg" pic1  -pic1 :: DPicture+pic1 :: Picture pic1 = frame [ ellipse01 $ P2 50 50              , ellipse02 $ P2 100 50              , ellipse03 $ P2 150 50              ]  -ellipse01 :: DPoint2 -> DPrimitive+ellipse01 :: DPoint2 -> Primitive ellipse01 pt = cstroke black default_stroke_attr $ -    curvedPath $ bezierEllipse 20 30 pt+    curvedPrimPath $ bezierEllipse 20 30 pt  -ellipse02 :: DPoint2 -> DPrimitive+ellipse02 :: DPoint2 -> Primitive ellipse02 pt = cstroke red default_stroke_attr $ -    curvedPath $ rbezierEllipse 20 30 0 pt+    curvedPrimPath $ rbezierEllipse 20 30 0 pt   -ellipse03 :: DPoint2 -> DPrimitive+ellipse03 :: DPoint2 -> Primitive ellipse03 pt = cstroke red default_stroke_attr $ -    curvedPath $ rbezierEllipse 20 30 (negate $ d2r (10::Double)) pt+    curvedPrimPath $ rbezierEllipse 20 30 (negate $ d2r (10::Double)) pt 

@@ -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

@@ -15,7 +15,9 @@     writeSVG "./out/svg_link01.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"++

@@ -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  

@@ -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]

@@ -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&#0o350;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

@@ -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.

@@ -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  

@@ -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,7 +36,7 @@      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@@ -44,24 +44,24 @@      pt   = P2 70 10      ang  = d2r (30::Double) -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+     pto  = P2 60 0 `asTypeOf` dpt      ang  = d2r (30::Double)  -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

@@ -26,7 +26,7 @@   -pic1 :: Picture Double+pic1 :: Picture pic1 = pth `picOver` ch `picOver` xy_frame "no transform"   where      pth  = mkBlackPath id pt@@ -34,7 +34,7 @@      pt   = P2 70 10  -pic2 :: Picture Double+pic2 :: Picture pic2 = pth `picOver` ch `picOver` xy_frame "rotate 30deg"   where      pth  = mkBlackPath (rotate ang) pt@@ -43,24 +43,24 @@      ang  = d2r (30::Double)  -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+     pto  = P2 60 0 `asTypeOf` dpt      ang  = d2r (30::Double)      -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

@@ -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::Double)  -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::Double)  -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

@@ -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)

@@ -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 

@@ -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 }+

binary file changed (68361 → 67925 bytes)

@@ -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

@@ -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)  --------------------------------------------------------------------------------

@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -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+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  

@@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Core.Colour--- 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 -- -- Colour represented as RGB with each component in the range 

@@ -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) 

@@ -10,8 +10,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 -- -- 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,9 +44,15 @@    , MatrixMult(..) -  -- * UNil operations-  , uNil +  -- * Tolerance helpers+  , tEQ+  , tGT+  , tLT+  , tGTE+  , tLTE+  , tCompare+   -- * Vector operations   , vec   , hvec@@ -70,7 +77,7 @@   , rotationMatrix   , originatedRotationMatrix -  -- * matrix operations+  -- * Matrix operations   , invert   , determinant   , transpose@@ -93,23 +100,20 @@   ) 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 :: *@@ -122,33 +126,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 @@ -156,14 +180,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 @@ -215,10 +244,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@@ -243,12 +272,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@@ -266,9 +315,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]]@@ -308,18 +354,18 @@ -------------------------------------------------------------------------------- -- 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 '|'     @@ -378,25 +424,76 @@ -- 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 @@ -441,7 +538,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 @@ -605,7 +702,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@@ -637,7 +735,8 @@      mTinv = M3'3 1 0 (-x)                    0 1 (-y)  -                 0 0   1+                 0 0 1+     @@ -825,7 +924,7 @@ -- the approximation seems fine in practice. -- rbezierEllipse :: (Real u, Floating u) -              => u -> u -> Radian -> Point2 u -> [Point2 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

@@ -108,8 +108,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@@ -193,6 +211,12 @@ -- 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

@@ -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,8 +430,7 @@ -- 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 -> PrimLabel -> PsMonad Doc primLabel (LabelProps rgb attrs) (PrimLabel body ctm) = bracketPrimCTM ctm mf   where     ev    = font_enc_vector $ font_face attrs    @@ -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+  

@@ -4,11 +4,11 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Core.OutputSVG--- 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 SVG. @@ -47,7 +47,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 @@ -109,9 +108,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,8 +142,7 @@  -- | 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  @@ -153,16 +151,14 @@ -- 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 ()+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 +166,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 +174,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 +191,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,6 +207,15 @@ 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@@ -239,12 +236,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 +256,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 +294,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,15 +320,14 @@   --- 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 -> PrimLabel -> SvgMonad Doc primLabel (LabelProps rgb attrs) (PrimLabel body ctm) =      (\fa ca -> elem_text (fa <+> ca) (makeTspan rgb dtext))       <$> deltaFontAttrs attrs <*> bracketTextCTM ctm coordf@@ -340,12 +336,12 @@     coordf = \p0 -> pure $ labelBodyCoords body p0     dtext  = labelBodyText body -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 +350,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 +358,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 +366,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 +381,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@@ -496,15 +492,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 +514,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 +                     } 

@@ -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 ctm) = +    PrimLabel txt (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 

@@ -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,18 @@     frame   , multi   , fontDeltaContext-  , primPath-  , lineTo-  , curveTo-  , vertexPath-  , vectorPath-  , emptyPath-  , curvedPath+  , absPrimPath+  , absLineTo+  , absCurveTo+  , relPrimPath+  , relLineTo+  , relCurveTo+  , vertexPrimPath+  , vectorPrimPath+  , emptyPrimPath+  , curvedPrimPath   , xlinkhref-  , xlink+  , xlinkPrim   , svgattr   , annotateGroup   , annotateXLink@@ -112,10 +114,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@@ -139,7 +140,7 @@ -- \*\* 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 +155,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 +192,16 @@ -- 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 Path from a start point and a list of AbsPathSegments. ---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 +210,71 @@     step _ []                         = []  +          --- | 'lineTo' : @ end_point -> path_segment @+-- | 'absLineTo' : @ end_point -> path_segment @ --  -- Create a straight-line PathSegment, 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. -- ---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 Path from a start point and a list of RelPathSegments.+--+relPrimPath :: DPoint2 -> [PrimPathSegment] -> PrimPath+relPrimPath pt xs = PrimPath xs (startPointCTM pt)++++-- | 'relLineTo' : @ vec_to_end -> path_segment @ -- +-- Create a straight-line relative PathSegment, 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 relative PathSegment.+--+--+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 +283,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,9 +308,9 @@ -- \*\* 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@@ -296,8 +326,8 @@  -- | Create a hyperlinked Primitive. ---xlink :: XLink -> Primitive u -> Primitive u-xlink hypl p = PSVG (ALink hypl) p  +xlinkPrim :: XLink -> Primitive -> Primitive+xlinkPrim hypl p = PSVG (ALink hypl) p     -- | Create an attribute for SVG output.@@ -324,7 +354,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 +363,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 +373,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 +395,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@@ -382,8 +412,7 @@ -- -- Create a open, stroked path. ---ostroke :: Num u -        => RGBi -> StrokeAttr -> PrimPath u -> Primitive u+ostroke :: RGBi -> StrokeAttr -> PrimPath -> Primitive ostroke rgb sa p = PPath (OStroke sa rgb) p  @@ -391,8 +420,7 @@ --  -- Create a closed, stroked path. ---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 +429,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 +437,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  --------------------------------------------------------------------------------@@ -420,13 +448,13 @@ -- --  Create a filled path. ---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+zfill :: PrimPath -> Primitive zfill = fill black  @@ -439,8 +467,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 +476,12 @@ -------------------------------------------------------------------------------- -- Clipping  --- | 'clip' : @ path * picture -> Picture @+-- | 'clip' : @ path * primitive -> Primitive @ -- --- Clip a picture with respect to the supplied path.+-- Clip a primitive with respect to the supplied path. ---clip :: (Num u, Ord u) => PrimPath u -> Picture u -> Picture u-clip cp p = Clip (pathBoundary cp, []) cp p+clip :: PrimPath -> Primitive -> Primitive+clip cp p = PClip cp p  -------------------------------------------------------------------------------- -- Labels to primitive@@ -469,8 +496,7 @@ -- -- 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 * theta * @@ -481,8 +507,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 +517,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,8 +530,7 @@ -- -- 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 * theta * @@ -517,9 +541,8 @@ -- -- 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)@@ -530,7 +553,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,9 +590,7 @@ -- 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)@@ -609,9 +630,7 @@ -- 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)@@ -623,7 +642,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 +651,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 +660,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)  --------------------------------------------------------------------------------@@ -666,8 +685,7 @@ -- -- 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  @@ -677,31 +695,27 @@ -- 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 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 * theta * center ---        -> Primitive @+-- | 'rfillEllipse' : @ rgb * rx * ry * theta * center -> Primitive @ -- -- 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) @@ -710,7 +724,7 @@ -- -- 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  @@ -719,9 +733,9 @@ -- -- 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     @@ -733,14 +747,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) @@ -755,8 +769,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')@@ -775,7 +790,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@@ -788,15 +803,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@@ -808,7 +823,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 []  @@ -817,9 +832,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 @@@ -829,23 +844,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)] }@@ -859,15 +873,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:@@ -875,8 +888,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 @@ -887,6 +901,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 + 

@@ -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-2011 -- 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,39 +21,31 @@   (       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@@ -66,10 +59,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 +71,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 +112,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 +139,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 +151,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. @@ -235,52 +209,52 @@       }   deriving (Eq,Show) --- | PrimPath - start point and a list of path segments.+-- | PrimPath - a list of path segments and a CTM.+-- +-- Start point is the dx - dy of the CTM. ---data PrimPath u = PrimPath (Point2 u) [PrimPathSegment u]+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_ctm       :: PrimCTM       }   deriving (Eq,Show) -type DPrimLabel = PrimLabel Double+type instance DUnit PrimLabel = Double   -- | Label can be draw with 3 layouts.@@ -295,33 +269,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 +321,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 +334,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,39 +364,42 @@   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    format (RelLineTo pt)         = text "rel_line_to  " <> format pt -instance PSUnit u => Format (PrimLabel u) where+instance Format PrimLabel where   format (PrimLabel s ctm) =       vcat [ dquotes (format s)           , 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+instance Format PrimEllipse where+  format (PrimEllipse hw hh ctm) =  text "hw="       <> format hw+                                <+> text "hh="       <> format hh                                 <+> text "ctm="      <> format ctm    @@ -438,32 +409,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 +473,20 @@    -labelBoundary :: (Floating u, Real u, FromPtSize u) -              => FontAttr -> PrimLabel u -> BoundingBox u+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 +498,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 +514,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 +524,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 +544,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 +585,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,26 +685,25 @@ -- Rotate the baseline-left start point _AND_ the CTM of the  -- label. ---rotateLabel :: (Real u, Floating u) -            => Radian -> PrimLabel u -> PrimLabel u+rotateLabel :: Radian -> PrimLabel -> PrimLabel rotateLabel ang (PrimLabel txt ctm) = PrimLabel txt (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 ctm) = +    PrimLabel txt (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 ctm) = +    PrimLabel txt (scaleCTM sx sy ctm)   -- Change the bottom-left corner. ---translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u+translateLabel :: Double -> Double -> PrimLabel -> PrimLabel translateLabel dx dy (PrimLabel txt ctm) =      PrimLabel txt (translateCTM dx dy ctm) @@ -705,19 +711,17 @@ -- 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 +729,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 +755,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 +775,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,12 +812,12 @@  -- | 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 -> Bool isEmptyLabel (PrimLabel txt _) = body txt    where      body (StdLayout esc) = destrEscapedText null esc

@@ -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  @

@@ -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---

@@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Core.SVGDoc--- 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 -- -- SVG Doc combinators.@@ -80,7 +80,7 @@ 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  @@ -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@@ -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=\"...\" @@@ -410,12 +410,21 @@  -- | @ matrix(..., ..., ..., ..., ..., ...) @ ---val_matrix :: PSUnit u => Matrix3'3 u -> Doc+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 :: DVec2 -> Doc val_translate (V2 x y) = text "translate" <> tupled [dtruncFmt x, dtruncFmt y]

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Core.Text.Base--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -101,6 +101,9 @@ -- 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

@@ -1,12 +1,13 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Core.TrafoInternal--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- 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,32 +66,35 @@ --  -- 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@@ -97,30 +104,44 @@   - -------------------------------------------------------------------------------- -- 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

@@ -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.

@@ -3,11 +3,11 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Core.Utils.FormatCombinators--- 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 -- -- Formatting combinators - pretty printers without the fitting.@@ -120,7 +120,19 @@   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+  --------------------------------------------------------------------------------         

@@ -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. --

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

@@ -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,41 @@    -- * Picture types     Picture-  , DPicture   , FontCtx   , Primitive-  , DPrimitive   , XLink   , 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

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.43.0+version:          0.50.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -39,8 +39,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,6 +48,48 @@   .   Changelog:   .+  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@@@ -71,6 +113,7 @@   demo/AffineTest02.hs,   demo/AffineTest03.hs,   demo/AffineTestBase.hs,+  demo/ClipPic.hs,   demo/DeltaPic.hs,   demo/EllipsePic.hs,   demo/FontMetrics.hs,@@ -109,7 +152,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,