wumpus-core 0.35.0 → 0.36.0

raw patch · 56 files changed

+2950/−2589 lines, 56 filesdep −algebradep ~basePVP ok

version bump matches the API change (PVP)

Dependencies removed: algebra

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• demo/AffineTest01.hs +2/−2
• demo/AffineTest02.hs +2/−2
• demo/AffineTest03.hs +2/−2
• demo/AffineTestBase.hs +13/−13
• demo/DeltaPic.hs +2/−2
• demo/FontMetrics.hs +4/−4
• demo/KernPic.hs +3/−3
• demo/LabelPic.hs +46/−41
• demo/Latin1Pic.hs +1/−1
• demo/MultiPic.hs +1/−1
• demo/Rotated.hs +0/−70
• demo/Scaled.hs +0/−63
• demo/TransformEllipse.hs +95/−0
• demo/TransformPath.hs +109/−0
• demo/TransformTextlabel.hs +99/−0
• demo/Translated.hs +0/−59
• demo/ZOrderPic.hs +2/−2
• doc-src/Guide.lhs +41/−34
• doc-src/WorldFrame.hs +2/−2
• doc/Guide.pdf binary
• src/Wumpus/Core.hs +8/−8
• src/Wumpus/Core/AffineTrans.hs +17/−10
• src/Wumpus/Core/BoundingBox.hs +28/−19
• src/Wumpus/Core/Colour.hs +3/−2
• src/Wumpus/Core/FontSize.hs +19/−13
• src/Wumpus/Core/FormatCombinators.hs +0/−384
• src/Wumpus/Core/Geometry.hs +12/−6
• src/Wumpus/Core/GraphicProps.hs +224/−0
• src/Wumpus/Core/GraphicsState.hs +0/−166
• src/Wumpus/Core/OneList.hs +0/−137
• src/Wumpus/Core/OutputPostScript.hs +27/−12
• src/Wumpus/Core/OutputSVG.hs +24/−13
• src/Wumpus/Core/PageTranslation.hs +8/−6
• src/Wumpus/Core/Picture.hs +208/−102
• src/Wumpus/Core/PictureInternal.hs +142/−304
• src/Wumpus/Core/PostScriptDoc.hs +4/−4
• src/Wumpus/Core/PtSize.hs +1/−1
• src/Wumpus/Core/SVGDoc.hs +4/−4
• src/Wumpus/Core/Text/DefaultEncoder.hs +44/−0
• src/Wumpus/Core/Text/Encoder.hs +143/−0
• src/Wumpus/Core/Text/Latin1.hs +257/−0
• src/Wumpus/Core/Text/SymbolFont.hs +249/−0
• src/Wumpus/Core/Text/TextInternal.hs +173/−0
• src/Wumpus/Core/TextDefaultEncoder.hs +0/−44
• src/Wumpus/Core/TextEncoder.hs +0/−143
• src/Wumpus/Core/TextInternal.hs +0/−173
• src/Wumpus/Core/TextLatin1.hs +0/−257
• src/Wumpus/Core/TextSymbolFont.hs +0/−249
• src/Wumpus/Core/TrafoInternal.hs +138/−0
• src/Wumpus/Core/Utils.hs +0/−192
• src/Wumpus/Core/Utils/Common.hs +192/−0
• src/Wumpus/Core/Utils/FormatCombinators.hs +384/−0
• src/Wumpus/Core/Utils/OneList.hs +133/−0
• src/Wumpus/Core/VersionNumber.hs +2/−2
• src/Wumpus/Core/WumpusTypes.hs +1/−17
• wumpus-core.cabal +81/−20

@@ -20,8 +20,8 @@ rot30 :: (Rotate t, Fractional u, u ~ DUnit t) => t -> t
 rot30 = rotate30
 
-rot30P :: (Real u, Floating u) => PrimElement u -> PrimElement u
-rot30P = rotatePrim (d2r (30.0::Double))
+rot30P :: (Real u, Floating u) => Primitive u -> Primitive u
+rot30P = rotate30
 
 -- Primitive - Text
 

@@ -20,8 +20,8 @@ scale_onehalf_x_two = scale 1.5 2.0
 
 
-scale_onehalf_x_twoP :: Fractional u => PrimElement u -> PrimElement u
-scale_onehalf_x_twoP = scalePrim 1.5 2.0
+scale_onehalf_x_twoP :: Fractional u => Primitive u -> Primitive u
+scale_onehalf_x_twoP = scale 1.5 2.0
 
 -- Primitive - Text
 

@@ -19,8 +19,8 @@ translate_20x40 :: (Translate t, Fractional u, u ~ DUnit t) => t -> t
 translate_20x40 = translate 20.0 40.0
 
-translate_20x40P :: Fractional u => PrimElement u -> PrimElement u
-translate_20x40P = translatePrim 20.0 40.0
+translate_20x40P :: Fractional u => Primitive u -> Primitive u
+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 -> DPrimElement
+      , ata_prim_constructor    :: RGBi -> DPrimitive
       , ata_pic_transformer     :: DPicture -> DPicture
-      , ata_prim_transformer    :: DPrimElement -> DPrimElement
+      , ata_prim_transformer    :: DPrimitive -> DPrimitive
       }
 
 runATA :: AffineTrafoAlg -> IO ()
@@ -56,9 +56,9 @@                           (ata_prim_transformer ata)
 
 
-buildPictureATA :: (RGBi -> DPrimElement) 
+buildPictureATA :: (RGBi -> DPrimitive) 
          -> (DPicture -> DPicture) 
-         -> (DPrimElement -> DPrimElement) 
+         -> (DPrimitive -> DPrimitive) 
          -> DPicture
 buildPictureATA mk picF primF = 
     picture1 `picBeside` picture2 `picBeside` picture3
@@ -72,7 +72,7 @@     picture3 :: DPicture
     picture3 = illustrateBoundsPrim light_blue $ prim
       where
-        prim :: DPrimElement
+        prim :: DPrimitive
         prim = primF $ mk red
 
 
@@ -85,8 +85,8 @@       { cpa_console_msg         :: String
       , cpa_eps_file            :: FilePath
       , cpa_svg_file            :: FilePath
-      , cpa_prim_constructor    :: RGBi -> DPrimElement
-      , cpa_prim_transformer    :: DPrimElement -> DPrimElement
+      , cpa_prim_constructor    :: RGBi -> DPrimitive
+      , cpa_prim_transformer    :: DPrimitive -> DPrimitive
       }
 
 runCPA :: ControlPointAlg -> IO ()
@@ -98,27 +98,27 @@   where
     pic = cpPicture (cpa_prim_constructor cpa) (cpa_prim_transformer cpa)
 
-cpPicture :: (RGBi -> DPrimElement) -> (DPrimElement -> DPrimElement) -> DPicture
+cpPicture :: (RGBi -> DPrimitive) -> (DPrimitive -> DPrimitive) -> DPicture
 cpPicture constr trafo = 
     illustrateBounds light_blue $ illustrateControlPoints black 
                                 $ transformed_prim
   where
-   transformed_prim :: DPrimElement
+   transformed_prim :: DPrimitive
    transformed_prim = trafo $ constr red
 
 
 --------------------------------------------------------------------------------
 
-rgbLabel :: RGBi -> DPrimElement
+rgbLabel :: RGBi -> DPrimitive
 rgbLabel rgb = textlabel rgb wumpus_default_font "Wumpus!" zeroPt
 
-rgbCircle :: RGBi -> DPrimElement
+rgbCircle :: RGBi -> DPrimitive
 rgbCircle rgb = fillEllipse rgb 60 60 zeroPt
 
-rgbEllipse :: RGBi -> DPrimElement
+rgbEllipse :: RGBi -> DPrimitive
 rgbEllipse rgb = fillEllipse rgb 60 30 zeroPt
 
-rgbPath :: RGBi -> DPrimElement
+rgbPath :: RGBi -> DPrimitive
 rgbPath rgb = ostroke rgb default_stroke_attr $ dog_kennel
 --------------------------------------------------------------------------------
 -- Demo - draw a dog kennel...

@@ -41,10 +41,10 @@ -- Note - each label is fully attributed with the font style. -- There really is not attribute inheritance. ---helveticaLabel :: Int -> String -> DPoint2 -> DPrimElement+helveticaLabel :: Int -> String -> DPoint2 -> DPrimitive helveticaLabel sz ss pt = textlabel peru attrs ss pt   where     attrs = FontAttr sz common_ff -courierLabel :: String -> DPoint2 -> DPrimElement+courierLabel :: String -> DPoint2 -> DPrimitive courierLabel ss pt = textlabel black wumpus_default_font ss pt

@@ -52,7 +52,7 @@   where     chars = (map letter "ABXabdgjxy12") ++ [agraveU] -type PrimF = DPoint2 -> DPrimElement+type PrimF = DPoint2 -> DPrimitive  bodyHeight  :: PrimF bodyHeight  = vertLine peru $ fromPtSize courier48_numeral_height@@ -60,15 +60,15 @@ agraveU     :: PrimF agraveU     = textlabel black courier_attr "&#Agrave" -letter :: Char -> DPoint2 -> DPrimElement+letter :: Char -> DPoint2 -> DPrimitive letter ch pt = textlabel black courier_attr [ch] pt  -vertLine :: RGBi -> Double -> DPoint2 -> DPrimElement+vertLine :: RGBi -> Double -> DPoint2 -> DPrimitive vertLine rgb height pt =      ostroke rgb default_stroke_attr $ vertexPath [pt, pt .+^ vvec height] -haxis :: RGBi -> PtSize -> DPrimElement+haxis :: RGBi -> PtSize -> DPrimitive haxis rgb ypos =      ostroke rgb dash_attr $ vertexPath [ pt, pt .+^ hvec 440 ]   where

@@ -47,13 +47,13 @@ uUpsilon :: [ DKerningChar ] uUpsilon = [ kernEscInt 6 0o241, kernchar 12 'a', kernchar 12 'b' ]  -helveticaLabelH :: [KerningChar Double] -> DPoint2 -> DPrimElement+helveticaLabelH :: [KerningChar Double] -> DPoint2 -> DPrimitive helveticaLabelH xs pt = hkernlabel black helvetica18 xs pt -helveticaLabelV :: [KerningChar Double] -> DPoint2 -> DPrimElement+helveticaLabelV :: [KerningChar Double] -> DPoint2 -> DPrimitive helveticaLabelV xs pt = vkernlabel black helvetica18 xs pt -symbolLabelH :: [KerningChar Double] -> DPoint2 -> DPrimElement+symbolLabelH :: [KerningChar Double] -> DPoint2 -> DPrimitive symbolLabelH xs pt = hkernlabel black symbol18 xs pt  

@@ -7,46 +7,15 @@  import System.Directory --------------------------------------------------------------------------------- ---drawBounds :: (Floating u, Real u, FromPtSize u) => Picture u -> Picture u-drawBounds p        = p `picOver` (frame [zcstroke ph])-  where-    ph            = vertexPath $ [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 a = P2 hcenter vcenter -  where  -    BBox (P2 x0 y0) (P2 x1 y1) = boundary a-    hcenter                    = x0 + 0.5 * (x1 - x0)-    vcenter                    = y0 + 0.5 * (y1 - y0)------------------------------------------------------------------------------------peru :: RGBi-peru = RGBi 205  133  63--plum :: RGBi-plum = RGBi 221  160  221--black :: RGBi-black = RGBi 0 0 0 +main :: IO ()+main = do +  createDirectoryIfMissing True "./out/"+  sequence_ [ demo01, demo02, demo03, demo04, demo05+            , demo06, demo07 ]   -lbl1 :: Picture Double-lbl1 = line1 `picBeside` line2 where-  line1 = frame [textlabel peru attrs "Hello" zeroPt]-  line2 = frame [textlabel peru attrs "World" zeroPt]-  attrs = FontAttr 12 (FontFace "Helvetica" "Helvetica" -                                SVG_REGULAR latin1_font_encoder)-- demo01 :: IO () demo01 = do      writeEPS_latin1 "./out/label01.eps" lbl1@@ -131,8 +100,44 @@     pC = drawBounds $ picMoveBy `flip` (vec 0 10) $ bigLetter peru 'C'  -main :: IO ()-main = do -  createDirectoryIfMissing True "./out/"-  sequence_ [ demo01, demo02, demo03, demo04, demo05-            , demo06, demo07 ]+++--------------------------------------------------------------------------------++++drawBounds :: (Floating u, Real u, FromPtSize u) => Picture u -> Picture u+drawBounds p        = p `picOver` (frame [zcstroke ph])+  where+    ph            = vertexPath $ [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 a = P2 hcenter vcenter +  where  +    BBox (P2 x0 y0) (P2 x1 y1) = boundary a+    hcenter                    = x0 + 0.5 * (x1 - x0)+    vcenter                    = y0 + 0.5 * (y1 - y0)++--------------------------------------------------------------------------------++peru :: RGBi+peru = RGBi 205  133  63++plum :: RGBi+plum = RGBi 221  160  221++black :: RGBi+black = RGBi 0 0 0 ++++lbl1 :: Picture Double+lbl1 = line1 `picBeside` line2 where+  line1 = frame [textlabel peru attrs "Hello" zeroPt]+  line2 = frame [textlabel peru attrs "World" zeroPt]+  attrs = FontAttr 12 (FontFace "Helvetica" "Helvetica" +                                SVG_REGULAR latin1_font_encoder)+

@@ -29,7 +29,7 @@   -helveticaLabel :: String -> DPoint2 -> DPrimElement+helveticaLabel :: String -> DPoint2 -> DPrimitive helveticaLabel ss pt = textlabel black helvetica18 ss pt  helvetica18 :: FontAttr

@@ -26,7 +26,7 @@     ]  -square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> PrimElement u+square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> Primitive u square rgb sidelen bl = fill rgb $ vertexPath $     [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen] 

@@ -1,70 +0,0 @@-{-# OPTIONS -Wall #-}--module Rotated where--import Wumpus.Core-import Wumpus.Core.Colour--import Data.AffineSpace--import System.Directory---main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    writeEPS_latin1 "./out/rot_square.eps"  pic1-    writeSVG_latin1 "./out/rot_square.svg"  pic1-    writeEPS_latin1 "./out/rot_circle.eps"  pic2-    writeSVG_latin1 "./out/rot_circle.svg"  pic2-    writeEPS_latin1 "./out/rot_label.eps"   pic3-    writeSVG_latin1 "./out/rot_label.svg"   pic3----- both squares should share the bottom left coord...--deg45 :: Radian-deg45 = d2r (45.0::Double)---pic1 :: DPicture-pic1 = illustrateBounds grey $ frame $ -    [ rotatePrim deg45 $ square blue 50 (P2 100 100)-    , square red 50 (P2 100 100)-    ]------ both ellipses should share the same center-pic2 :: DPicture-pic2 = illustrateBounds grey $ frame $ -    [ rotatePrim deg45 $ ellipseHH blue 25 (P2 100 100)-    , ellipseHH red 25 (P2 100 100)-    ]----- both labels should share the same bottom left corner-pic3 :: DPicture-pic3 = illustrateBounds grey $ frame $ -    [ rotatePrim deg45 $  label blue (P2 100 100)-    , label red (P2 100 100)-    ]---square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> PrimElement u-square rgb sidelen bl = fill rgb $ vertexPath $-    [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen]----ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> PrimElement u-ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr- -label :: Num u => RGBi -> Point2 u -> PrimElement u-label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl---grey :: RGBi-grey = RGBi 176 197 223--

@@ -1,63 +0,0 @@-{-# OPTIONS -Wall #-}--module Scaled where--import Wumpus.Core-import Wumpus.Core.Colour--import Data.AffineSpace--import System.Directory--main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    writeEPS_latin1 "./out/scaled_square.eps"  pic1-    writeSVG_latin1 "./out/scaled_square.svg"  pic1-    writeEPS_latin1 "./out/scaled_circle.eps"  pic2-    writeSVG_latin1 "./out/scaled_circle.svg"  pic2-    writeEPS_latin1 "./out/scaled_label.eps"   pic3-    writeSVG_latin1 "./out/scaled_label.svg"   pic3----- both squares should share the bottom left corner--pic1 :: DPicture-pic1 = illustrateBounds grey $ frame $ -    [ uniformScalePrim 0.5 $ square blue 50 (P2 100 100)-    , square red 50 (P2 100 100)-    ]----- both ellipses should share the same center-pic2 :: DPicture-pic2 = illustrateBounds grey $ frame $ -    [ uniformScalePrim 0.5 $ ellipseHH blue 25 (P2 100 100)-    , ellipseHH red 25 (P2 100 100)-    ]----- both labels should share the same bottom left corner-pic3 :: DPicture-pic3 = illustrateBounds grey $ frame $-    [ uniformScalePrim 0.5 $ label blue (P2 100 100)-    , label red (P2 100 100)-    ]----square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> PrimElement u-square rgb sidelen bl = fill rgb $ vertexPath $-    [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen]--ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> PrimElement u-ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr- -label :: Num u => RGBi -> Point2 u -> PrimElement u-label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl---grey :: RGBi-grey = RGBi 176 197 223--

@@ -0,0 +1,95 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++module TransformEllipse where++import Wumpus.Core+import Wumpus.Core.Colour++import Data.AffineSpace                         -- package: vector-space++import System.Directory+++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/transform_ellipse01.eps" pic1+    writeSVG_latin1 "./out/transform_ellipse01.svg" pic1+    writeEPS_latin1 "./out/transform_ellipse02.eps" pic2+    writeSVG_latin1 "./out/transform_ellipse02.svg" pic2+    writeEPS_latin1 "./out/transform_ellipse03.eps" pic3+    writeSVG_latin1 "./out/transform_ellipse03.svg" pic3+    writeEPS_latin1 "./out/transform_ellipse04.eps" pic4+    writeSVG_latin1 "./out/transform_ellipse04.svg" pic4+    writeEPS_latin1 "./out/transform_ellipse05.eps" pic5+    writeSVG_latin1 "./out/transform_ellipse05.svg" pic5++++pic1 :: Picture Double+pic1 = cb `picOver` ell `picOver` xy_frame "no transform"+  where+     ell  = mkRedEllipse id 20 10 pt+     cb   = crossbar 20 10 pt+     pt   = P2 70 10+++pic2 :: Picture Double+pic2 = cb `picOver` ell `picOver` xy_frame "rotate 30deg"+  where+     ell  = mkRedEllipse (rotate ang) 20 10 pt+     cb   = rotate ang $ crossbar 20 10 pt+     pt   = P2 70 10+     ang  = 0.25*pi++pic3 :: Picture Double+pic3 = cb `picOver` ell `picOver` xy_frame "rotateAbout (60,0) 30deg"+  where+     ell  = mkRedEllipse (rotateAbout ang pto) 20 10 pt+     cb   = rotateAbout ang pto $ crossbar 20 10 pt+     pt   = P2 70 10+     pto  = P2 60 0+     ang  = 0.25*pi+++pic4 :: Picture Double+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 = cb `picOver` ell `picOver` xy_frame "translate -70 -10"+  where+     ell  = mkRedEllipse (translate (-70) (-10)) 20 10 pt+     cb   = translate (-70) (-10) $ crossbar 20 10 pt+     pt   = P2 70 10+++mkRedEllipse :: (Real u, Floating u, FromPtSize u) +             => (Primitive u -> Primitive u) +             -> u -> u -> Point2 u -> Picture u+mkRedEllipse trafo rx ry pt = frame [ trafo $ fillEllipse red rx ry pt] ++crossbar :: (Real u, Floating u, FromPtSize u) +         => u -> u -> Point2 u -> Picture u+crossbar rx ry ctr = frame [ostroke black default_stroke_attr $ path west ps]+  where+    ps    = [ lineTo east, lineTo ctr, lineTo north, lineTo 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 ss = +    frame [ mkline (P2 (-4) 0) (P2 150 0)+          , mkline (P2 0 (-4)) (P2 0 150) +          , textlabel black wumpus_default_font ss (P2 0 (-20))+          ]++  where+    mkline p1 p2 = ostroke black default_stroke_attr $ path p1 [lineTo p2]

@@ -0,0 +1,109 @@+{-# OPTIONS -Wall #-}++module TransformPath where++import Wumpus.Core+import Wumpus.Core.Colour++import Data.AffineSpace                         -- package: vector-space++import System.Directory+++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/transform_path01.eps" pic1+    writeSVG_latin1 "./out/transform_path01.svg" pic1+    writeEPS_latin1 "./out/transform_path02.eps" pic2+    writeSVG_latin1 "./out/transform_path02.svg" pic2+    writeEPS_latin1 "./out/transform_path03.eps" pic3+    writeSVG_latin1 "./out/transform_path03.svg" pic3+    writeEPS_latin1 "./out/transform_path04.eps" pic4+    writeSVG_latin1 "./out/transform_path04.svg" pic4+    writeEPS_latin1 "./out/transform_path05.eps" pic5+    writeSVG_latin1 "./out/transform_path05.svg" pic5++++pic1 :: Picture Double+pic1 = pth `picOver` ch `picOver` xy_frame "no transform"+  where+     pth  = mkBlackPath id pt+     ch   = zcrosshair pt+     pt   = P2 70 10+++pic2 :: Picture Double+pic2 = pth `picOver` ch `picOver` xy_frame "rotate 30deg"+  where+     pth  = mkBlackPath (rotate ang) pt+     ch   = rotate ang $ zcrosshair pt+     pt   = P2 70 10+     ang  = 0.25*pi++pic3 :: Picture Double+pic3 = pth `picOver` ch `picOver` xy_frame "rotateAbout (60,0) 30deg"+  where+     pth  = mkBlackPath (rotateAbout ang pto) pt+     ch   = rotateAbout ang pto $ zcrosshair pt+     pt   = P2 70 10+     pto  = P2 60 0+     ang  = 0.25*pi+++pic4 :: Picture Double+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 = pth `picOver` ch `picOver` xy_frame "translate -70 -10"+  where+     pth  = mkBlackPath (translate (-70) (-10)) pt+     ch   = translate (-70) (-10) $ zcrosshair pt+     pt   = P2 70 10+++mkBlackPath :: (Real u, Floating u, FromPtSize u) +             => (Primitive u -> Primitive u) +             -> Point2 u -> Picture u+mkBlackPath trafo bl = +    frame [ trafo $ ostroke black custom_stroke_attr $ path bl ps]+  where+    ps = [lineTo p1, lineTo p2, lineTo p3]+    p1 = bl .+^ vec 25 12+    p2 = p1 .+^ vec 6 (-12)+    p3 = p2 .+^ vec 25 12++++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 = crosshair 56 12 ++crosshair :: (Real u, Floating u, FromPtSize u) +          => u -> u -> Point2 u -> Picture u+crosshair w h bl = frame [ostroke burlywood default_stroke_attr $ path bl ps]+  where+    ps    = [ lineTo tr, lineTo br, lineTo tl, lineTo bl ]+    tl    = bl .+^ vvec h+    tr    = bl .+^ vec  w h+    br    = bl .+^ hvec w+    +burlywood :: RGBi+burlywood = RGBi 222 184 135++xy_frame :: (Real u, Floating u, FromPtSize u) => String -> Picture u+xy_frame ss = +    frame [ mkline (P2 (-4) 0) (P2 150 0)+          , mkline (P2 0 (-4)) (P2 0 150) +          , textlabel black wumpus_default_font ss (P2 0 (-20))+          ]++  where+    mkline p1 p2 = ostroke black default_stroke_attr $ path p1 [lineTo p2]

@@ -0,0 +1,99 @@+{-# OPTIONS -Wall #-}++module TransformTextlabel where++import Wumpus.Core+import Wumpus.Core.Colour++import Data.AffineSpace                         -- package: vector-space++import System.Directory+++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    writeEPS_latin1 "./out/transform_textlabel01.eps" pic1+    writeSVG_latin1 "./out/transform_textlabel01.svg" pic1+    writeEPS_latin1 "./out/transform_textlabel02.eps" pic2+    writeSVG_latin1 "./out/transform_textlabel02.svg" pic2+    writeEPS_latin1 "./out/transform_textlabel03.eps" pic3+    writeSVG_latin1 "./out/transform_textlabel03.svg" pic3+    writeEPS_latin1 "./out/transform_textlabel04.eps" pic4+    writeSVG_latin1 "./out/transform_textlabel04.svg" pic4+    writeEPS_latin1 "./out/transform_textlabel05.eps" pic5+    writeSVG_latin1 "./out/transform_textlabel05.svg" pic5++++pic1 :: Picture Double+pic1 = txt `picOver` ch `picOver` xy_frame "no transform"+  where+     txt  = mkBlackTextlabel id pt+     ch   = zcrosshair pt+     pt   = P2 70 10+++pic2 :: Picture Double+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  = 0.25*pi++pic3 :: Picture Double+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  = 0.25*pi+++pic4 :: Picture Double+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++pic5 :: Picture Double+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+++mkBlackTextlabel :: (Real u, Floating u, FromPtSize u) +                 => (Primitive u -> Primitive u) +                 -> Point2 u -> Picture u+mkBlackTextlabel trafo bl = +    frame [ trafo $ textlabel black wumpus_default_font "rhubarb" bl ] ++zcrosshair :: (Real u, Floating u, FromPtSize u) => Point2 u -> Picture u+zcrosshair = crosshair 56 12 ++crosshair :: (Real u, Floating u, FromPtSize u) +          => u -> u -> Point2 u -> Picture u+crosshair w h bl = frame [ostroke burlywood default_stroke_attr $ path bl ps]+  where+    ps    = [ lineTo tr, lineTo br, lineTo tl, lineTo bl ]+    tl    = bl .+^ vvec h+    tr    = bl .+^ vec  w h+    br    = bl .+^ hvec w+    +burlywood :: RGBi+burlywood = RGBi 222 184 135++xy_frame :: (Real u, Floating u, FromPtSize u) => String -> Picture u+xy_frame ss = +    frame [ mkline (P2 (-4) 0) (P2 150 0)+          , mkline (P2 0 (-4)) (P2 0 150) +          , textlabel black wumpus_default_font ss (P2 0 (-20))+          ]++  where+    mkline p1 p2 = ostroke black default_stroke_attr $ path p1 [lineTo p2]

@@ -1,59 +0,0 @@-{-# OPTIONS -Wall #-}--module Translated where--import Wumpus.Core-import Wumpus.Core.Colour--import Data.AffineSpace--import System.Directory--main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    writeEPS_latin1 "./out/trans_square.eps"  pic1-    writeSVG_latin1 "./out/trans_square.svg"  pic1-    writeEPS_latin1 "./out/trans_circle.eps"  pic2-    writeSVG_latin1 "./out/trans_circle.svg"  pic2-    writeEPS_latin1 "./out/trans_label.eps"   pic3-    writeSVG_latin1 "./out/trans_label.svg"   pic3----- both squares should share the bottom left coord...-pic1 :: DPicture-pic1 = illustrateBounds grey $ frame $ -    [ translatePrim 100 10 $ square blue 50 (P2 100 100)-    , square red 50 (P2 100 100)-    ]--pic2 :: DPicture-pic2 = illustrateBounds grey $ frame $ -    [ translatePrim 100 10 $ ellipseHH blue 25 (P2 100 100)-    , ellipseHH red 25 (P2 100 100)-    ]--pic3 :: DPicture-pic3 = illustrateBounds grey $ frame $ -    [ translatePrim 100 10 $ label blue (P2 100 100)-    , label red (P2 100 100)-    ]----square :: (Num u, Ord u) => RGBi -> u -> Point2 u -> PrimElement u-square rgb sidelen bl = fill rgb $ vertexPath $-    [bl, bl .+^ hvec sidelen, bl .+^ V2 sidelen sidelen, bl .+^ vvec sidelen]--ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> PrimElement u-ellipseHH rgb radius ctr = fillEllipse rgb radius (0.5*radius) ctr- -label :: Num u => RGBi -> Point2 u -> PrimElement u-label rgb bl = textlabel rgb wumpus_default_font "Wumpus" bl---grey :: RGBi-grey = RGBi 176 197 223---

@@ -19,7 +19,7 @@ zorder_msg :: String zorder_msg = unlines $      [ ""-    , "Wumpus-core draws lists of 'PrimElement' left-to-right."+    , "Wumpus-core draws lists of Primitives left-to-right."     , "The head of the list will be drawn first - it will appear"     , "at the top of the output file. It will also be drawn at"     , "the back of the Z-Order."@@ -38,7 +38,7 @@ pic2 :: DPicture  pic2 = multi $ map (\a -> frame [a]) $ prim_list (P2 200 0) -prim_list :: DPoint2 -> [DPrimElement]+prim_list :: DPoint2 -> [DPrimitive] prim_list = sequence [ fillEllipse red   20 20                      , \p -> fillEllipse green 20 20 (p .+^ hvec 20)                      , \p -> fillEllipse blue  20 20 (p .+^ hvec 40)

@@ -23,7 +23,7 @@ \section{About \wumpuscore}
 %-----------------------------------------------------------------
 
-This guide was last updated for \wumpuscore version 0.35.0.
+This guide was last updated for \wumpuscore version 0.36.0.
 
 \wumpuscore is a Haskell library for generating 2D vector 
 pictures. It was written with portability as a priority, so it has 
@@ -54,7 +54,7 @@ Some internal data types are also exported as opaque - 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.}]
@@ -87,10 +87,10 @@ 
 \item[\texttt{Wumpus.Core.Geometry.}]
 The usual types an 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 
+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 
-constraints on the unit, class constraints like 
+constraints on the unit - class constraints like 
 \texttt{Fractional u} can then be shifted to the instance 
 declaration rather than the class declaration.
 
@@ -169,17 +169,13 @@ multiple labels.
 
 Primitives are attributed with drawing styles - font name and 
-size for labels; line width, colour, etc. for paths. Drawing 
-\emph{primitives} is unfortunately complicated due to the need to 
-support hyperlinks in SVG output. Primitives have to be lifted 
-to a \texttt{PrimElement} before they can be placed within a 
-\texttt{Picture} - in practive this lifting is done automatically 
-by using the shorthand constructors in 
-\texttt{Wumpus.Core.Picture}. 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). 
+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). 
 
 \begin{figure}
 \centering
@@ -206,9 +202,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. If one wanted 
-to draw blue or red arrows with \wumpuscore, one would make the 
-drawing colour a parameter of the arrow creation function.
+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.
 
 %-----------------------------------------------------------------
 \section{Affine transformations}
@@ -244,14 +240,11 @@ \end{array}
 \end{displaymath}
 
-Affine transformations are communicated to PostScript as 
-\texttt{concat} commands. Effectively \wumpuscore performs no
+Affine transformations on Pictures are communicated to PostScript
+as \texttt{concat} commands. For Pictures, \wumpuscore performs no
 transformations itself, delegating all the work to PostScript or
-SVG. This means transformations can generally be located in the 
-output if a picture needs to be debugged, though as this might 
-not be very helpful in practice. Internally \wumpuscore only 
-performs the transformation on the bounding box of a picture - it 
-needs to do this to maintain the size metrics of a picture 
+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.
 
@@ -270,15 +263,29 @@ <g transform="matrix(1.0, 0.0, 0.0, 1.0, 10.0, 20.0)"> ... </g>
 \end{verbatim}
 
-For efficiency reasons \wumpuscore supports some transformations
-on Primitives. These are not affine transformations as Primitives
-are not in an affine frame until they are lifted to Pictures 
-(Primitives have no notion of origin). For Paths, all the 
-transformations are precomputed before the output is generated. 
-Unfortunately scaling and rotation cannot be precomputed for 
-labels and ellipses, so matrix operations are generated in the 
-PostScript and SVG output.
+\wumpuscore also supports the regular affine transformations 
+on Primitives (the arbitrary matrix transformation 
+\texttt{transform} is not supported). Transformations are 
+implicitly interpreted in the standard affine frame - origin at 
+(0,0) and unit scaling vectors for the bases. 
 
+For paths, all the transformations are precomputed on the control 
+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).
+
+One consequence of transformations operating on the control points
+of primitives is that scalings do not scale the tip of the 
+\emph{drawing pen}. If a path is stroked, lifted to a Picture and
+then scaled the whole graphics state is effectively scaled 
+including the pen tip so the path is drawn with a thicker outline. 
+However, if a path is stoked and then scaled as a Primitive, the 
+drawing pen is not scaled so the path will be drawn with the 
+regular line width.
 
 %-----------------------------------------------------------------
 \section{Font handling}

@@ -26,13 +26,13 @@   -makeLabelPrim :: String -> DPoint2 -> DPrimElement+makeLabelPrim :: String -> DPoint2 -> DPrimitive makeLabelPrim = textlabel black attrs    where     attrs     = FontAttr 10 (FontFace "Helvetica" "Helvetica"                                        SVG_REGULAR latin1_font_encoder) -makeLinePrim :: Double -> DPoint2 -> DPoint2 -> DPrimElement+makeLinePrim :: Double -> DPoint2 -> DPoint2 -> DPrimitive makeLinePrim lw a b = ostroke black attrs $ path a [lineTo b]   where     attrs = default_stroke_attr {line_width=lw}

binary file changed (59489 → 59778 bytes)

@@ -32,14 +32,14 @@   , module Wumpus.Core.Colour   , module Wumpus.Core.FontSize   , module Wumpus.Core.Geometry-  , module Wumpus.Core.GraphicsState+  , module Wumpus.Core.GraphicProps   , module Wumpus.Core.OutputPostScript   , module Wumpus.Core.OutputSVG   , module Wumpus.Core.Picture   , module Wumpus.Core.PtSize-  , module Wumpus.Core.TextEncoder-  , module Wumpus.Core.TextLatin1-  , module Wumpus.Core.TextSymbolFont+  , module Wumpus.Core.Text.Encoder+  , module Wumpus.Core.Text.Latin1+  , module Wumpus.Core.Text.SymbolFont   , module Wumpus.Core.VersionNumber   , module Wumpus.Core.WumpusTypes @@ -52,14 +52,14 @@                                    cyan, magenta ) import Wumpus.Core.FontSize hiding ( textBoundsEnc ) import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState hiding ( GraphicsState )+import Wumpus.Core.GraphicProps import Wumpus.Core.OutputPostScript import Wumpus.Core.OutputSVG import Wumpus.Core.Picture import Wumpus.Core.PtSize-import Wumpus.Core.TextEncoder-import Wumpus.Core.TextLatin1-import Wumpus.Core.TextSymbolFont+import Wumpus.Core.Text.Encoder+import Wumpus.Core.Text.Latin1+import Wumpus.Core.Text.SymbolFont import Wumpus.Core.VersionNumber import Wumpus.Core.WumpusTypes 

@@ -18,23 +18,30 @@ -- The common affine transformations represented as type classes - -- scaling, rotation, translation. ----- Internally, when a picture is composed and transformed, Wumpus+--+-- Internally, when a Picture is composed and transformed, Wumpus -- only transforms the bounding box - transformations of the  -- picture content (paths or text labels) are communicated to  -- PostScript or SVG for final rendering. This is because Wumpus  -- has no access to the paths that make fonts so cannot transform  -- them directly. ----- As well as Pictures, some elements - e.g. Vectors, Points and --- BoundingBoxes - are also instances of the affine classes. The--- implementation of the instances considers that under --- transformation these objects are implicitly within the standard --- affine frame (origin at point zero and unit basis vectors for --- the horizontal and vertical). +-- Other elements - Vectors, Points, BoundingBoxes and Primtives - +-- are also instances of the affine classes. However, generally +-- Wumpus transforms these elements directly rather than +-- delegating the transformation to PostScript or SVG (the +-- situation for the Label primitive is more complicated - the +-- /start/ point is transformed by Wumpus but a matrix +-- transformation is sent to PostScript to manipulate the opaque +-- character objects). ----- This assumption cannot hold for primitives because text is --- special in PostScript and SVG, so there are no instances of --- the affine classes for Primitive or PrimElement.+-- Note - transformations on Primitives are applied to the control +-- points of the primitive not the /drawing/. A scaled, stroked +-- path will be drawn with at the standard line width rather than +-- with a thicker line. Also, text may not render pleasantly after +-- it has been transformed, PostScript references seem to caution +-- against transforming text and recommend changing @/scalefont@ +-- instead of scaling via a transfomation.  --  -- To generate efficient PostScript, Wumpus relies on the matrix -- representations of the affine transformations being invertible.

@@ -15,7 +15,11 @@ -- -- Empty pictures cannot be created with Wumpus. This greatly  -- simplifies the implementation of pictures and bounding boxes.+--+-- Note - some of the functions exposed by this module are +-- expected to be pertinent only to Wumpus-Core itself. -- +--  --------------------------------------------------------------------------------  module Wumpus.Core.BoundingBox @@ -45,21 +49,21 @@   ) where  import Wumpus.Core.AffineTrans-import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry-import Wumpus.Core.Utils ( PSUnit(..) )--import Data.Semigroup                               -- package: algebra-+import Wumpus.Core.Utils.Common ( PSUnit(..) )+import Wumpus.Core.Utils.FormatCombinators   -- | Bounding box of a picture, represented by the lower left and -- upper right corners. --  -- We cannot construct empty pictures - so bounding boxes are --- spared the obligation to be /empty/. BoundingBox is an instance--- of the Semigroup class where @append@ is the union operation.+-- spared the obligation to be /empty/.  -- +-- BoundingBox operates as a semigroup where @boundaryUnion@ is the+-- addition.+-- +--  data BoundingBox u = BBox        { ll_corner :: Point2 u       , ur_corner :: Point2 u @@ -73,12 +77,8 @@ -------------------------------------------------------------------------------- -- instances --- BBox is NOT monoidal - it\'s much simpler that way. -instance Ord u => Semigroup (BoundingBox u) where-  append = boundaryUnion - instance PSUnit u => Format (BoundingBox u) where   format (BBox p0 p1) = parens (text "BBox" <+> text "ll=" <> format p0                                              <+> text "ur=" <> format p1) @@ -124,7 +124,9 @@  -------------------------------------------------------------------------------- --- | Contruct a bounding box, vis the BBox constructor with range +-- | 'bbox' : @lower_left_corner * upper_right_corner -> BoundingBox@+--+-- Contruct a bounding box, vis the BBox constructor with range  -- checking on the corner points. -- -- @bbox@ throws an error if the width or height of the @@ -136,25 +138,28 @@    | otherwise            = error "Wumpus.Core.BoundingBox.bbox - malformed."  --- | Create a BoundingBox with bottom left corner at the origin,+-- | 'obbox' : @width * height -> BoundingBox@+--+-- Create a BoundingBox with bottom left corner at the origin, -- and dimensions @w@ and @h@. -- obbox :: Num u => u -> u -> BoundingBox u obbox w h = BBox zeroPt (P2 w h) --- | Destructor for BoundingBox.+-- | 'destBoundingBox' : @ bbox -> (lower_left_x, lower_lefy_y, +--      upper_right_x, upper_right_y)@ ----- Assembles a four-tuple @ (ll_x, ll_y, ur_x, ur_y) @.+-- Destructor for BoundingBox, assembles a four-tuple of the x +-- and y values of the corner points. -- --- Arguably this is easier to pattern match upon as it removes a +-- Arguably this is easier to pattern match upon, as it removes a  -- layer of nesting. -- destBoundingBox :: BoundingBox u -> (u,u,u,u) destBoundingBox (BBox (P2 llx lly) (P2 urx ury)) = (llx, lly, urx, ury)   --- | The union of two bounding boxes. This is also the @append@ --- of BoundingBox\'s @Semigroup@ instance.+-- | The union of two bounding boxes.  -- boundaryUnion :: Ord u => BoundingBox u -> BoundingBox u -> BoundingBox u BBox ll ur `boundaryUnion` BBox ll' ur' = BBox (minPt ll ll') (maxPt ur ur')@@ -184,8 +189,12 @@     fromCorners (bl,br,tr,tl) = [bl,br,tr,tl]  --- | Generate all the corners of a bounding box, counter-clock +-- | 'boundaryCorners' : @bbox -> (bottom_left, bottm_right,+--      top_right, top_left)@+-- +-- Generate all the corners of a bounding box, counter-clock  -- wise from the bottom left, i.e. @(bl, br, tr, tl)@.+-- boundaryCorners :: BoundingBox u -> (Point2 u, Point2 u, Point2 u, Point2 u) boundaryCorners (BBox bl@(P2 x0 y0) tr@(P2 x1 y1)) = (bl, br, tr, tl) where     br = P2 x1 y0

@@ -18,7 +18,8 @@ -- @Wumpus.Core.Colour@ directly to use them. -- -- PostScript has no support for RGB-alpha and hence does not--- transparency. Thus Wumpus in turn cannot support transparency.+-- support transparency. Thus Wumpus in turn cannot support +-- transparency. -- -------------------------------------------------------------------------------- @@ -41,7 +42,7 @@        ) where -import Wumpus.Core.FormatCombinators+import Wumpus.Core.Utils.FormatCombinators  import Data.Word 

@@ -19,10 +19,10 @@ -- of the text). --  -- This is a deficiency of Wumpus, and limits its text handling--- capabilities - for example, text cannot be reliably centered--- as its true length is not known. However, more powerful --- alternatives would need access to the metrics embedded within--- font files. This would require a font loader and add +-- capabilities - for example, text cannot be reliably centered +-- or right aligned as its true length is not known. However, more +-- powerful alternatives would need access to the metrics embedded +-- within font files. This would require a font loader and add  -- significant implementation complexity. --  --------------------------------------------------------------------------------@@ -62,7 +62,7 @@ import Wumpus.Core.BoundingBox import Wumpus.Core.Geometry import Wumpus.Core.PtSize-import Wumpus.Core.TextInternal+import Wumpus.Core.Text.TextInternal  import Data.AffineSpace                 -- package: vector-space @@ -153,9 +153,10 @@ courier48_spacer_width = 3.0  --- | Width of the supplied string when printed at 48pt.+-- | Width of the supplied string when printed at 48pt (i.e. n +-- chars + (n-1) spacers). ----- (i.e. n chars + (n-1) spacers)+-- Use 'charCount' to calculate the @CharCount@. -- widthAt48pt :: CharCount -> PtSize widthAt48pt n = (courier48_width * len) + (courier48_spacer_width * len_sub)@@ -183,7 +184,8 @@ -- problems (this a current deficiency of Wumpus). -- textWidth :: FontSize -> CharCount -> PtSize-textWidth sz n = (fromIntegral sz)/48 * widthAt48pt n+textWidth _  n | n <= 0 = 0+textWidth sz n          = (fromIntegral sz)/48 * widthAt48pt n   -- | Text height is just identity/double-coercion of the Point size.@@ -211,10 +213,12 @@ descenderDepth :: FontSize -> PtSize descenderDepth sz = (fromIntegral sz) / 48 * courier48_descender_depth --- | Find the bounding box for the character count at the +-- | 'textBounds' : @ font_size * baseline_left * text -> BBox@+--+-- Find the bounding box for the character count at the  -- supplied font-size. -- --- The supplied point represents the bottom left corner of the +-- The supplied point represents the baseline left corner of the  -- a regular upper-case letter (that is without descenders). -- The bounding box will always be /dropped/ to accommodate  -- ascenders - no interpretation of the string takes place to @@ -229,8 +233,10 @@ textBounds sz pt ss = textBoundsBody sz pt (charCount ss)   --- | Version of textBounds for EncodedText.+-- | 'textBoundsEnc' : @ font_size * baseline_left * encoded_text -> BBox@ -- +--  Version of textBounds for EncodedText.+--  -- Note this function is hidded by the top-level module  -- @Wumpus.Core@. --@@ -241,12 +247,12 @@  textBoundsBody :: (Num u, Ord u, FromPtSize u)                 => FontSize -> Point2 u -> Int -> BoundingBox u-textBoundsBody sz body_bl len = bbox bl tr +textBoundsBody sz baseline_left len = bbox bl tr    where     h           = fromPtSize $ textHeight sz     w           = fromPtSize $ textWidth  sz len     dd          = fromPtSize $ descenderDepth sz-    bl          = body_bl .-^ V2 0 dd +    bl          = baseline_left .-^ V2 0 dd      tr          = bl .+^ V2 w h  

@@ -1,384 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.FormatCombinators--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Formatting combinators - pretty printers without the fitting.--------------------------------------------------------------------------------------module Wumpus.Core.FormatCombinators-  (-    Doc-  , DocS-  , Format(..)-  , empty-  , showsDoc-  , (<>)-  , (<+>)  -  , vconcat-  , separate-  , hcat-  , hsep-  , vcat--  , text-  , char-  , int-  , integer-  , integral-  , float-  , double--  , space-  , comma-  , semicolon-  , line--  , fill--  , punctuate-  , enclose-  , squotes-  , dquotes-  , parens-  , brackets-  , braces-  , angles--  , lparen-  , rparen-  , lbracket-  , rbracket-  , lbrace-  , rbrace-  , langle-  , rangle--  , list-  , tupled-  , semiBraces--  , indent-    -  ) where--import Data.Monoid-import Numeric---- | Doc is a Join List ...----data Doc = Doc1   ShowS -         | Join   Doc   Doc-         | Line-         | Indent !Int  Doc ---type DocS = Doc -> Doc----- Join could be improved...----unDoc :: Doc -> ShowS-unDoc = step 0 id-  where-   step _ acc (Doc1 sf)    = acc . sf-   step n acc (Join a b)   = let acc' = step n acc a in step n acc' b-   step n acc Line         = acc . showChar '\n' . indentS n-   step n acc (Indent i d) = step (n+i) (acc . (indentS i)) d---indentS :: Int -> ShowS-indentS i | i < 1     = id-          | otherwise = showString $ replicate i ' '--runDoc :: Doc -> String-runDoc = ($ "") . unDoc---instance Show Doc where-  show = runDoc--instance Monoid Doc where-  mempty = empty-  mappend = (<>)---class Format a where format :: a -> Doc-----------------------------------------------------------------------------------        -infixr 6 <>, <+>------ | Create an empty, zero length document.----empty :: Doc-empty = Doc1 id---- | Create a document from a ShowS function.----showsDoc :: ShowS -> Doc-showsDoc = Doc1----- | Horizontally concatenate two documents with no space --- between them.--- -(<>) :: Doc -> Doc -> Doc-a <> b = Join a b ----- | Horizontally concatenate two documents with a single space --- between them.--- -(<+>) :: Doc -> Doc -> Doc-a <+> b = Join a (Join space b)---- | Vertical concatenate two documents with a line break.--- -vconcat :: Doc -> Doc -> Doc-vconcat a b = a <> Line <> b----separate :: Doc -> [Doc] -> Doc-separate _   []     = empty-separate sep (a:as) = step a as-  where-    step acc []     = acc-    step acc (x:xs) = step (acc <> sep <> x) xs---- | Horizontally concatenate a list of documents with @(\<\>)@.----hcat :: [Doc] -> Doc-hcat = foldr (<>) empty---- | Horizontally concatenate a list of documents with @(\<+\>)@.----hsep :: [Doc] -> Doc-hsep = separate space---- | Vertically concatenate a list of documents, with a line --- break between each doc.----vcat :: [Doc] -> Doc-vcat []     = empty-vcat (x:xs) = step x xs -  where-    step acc (z:zs) = step (acc `vconcat` z) zs-    step acc []     = acc---- | Create a document from a literal string.--- --- The string should not contain newlines (though this is not --- enforced). ----text :: String -> Doc-text = Doc1 . showString----- | Create a document from a literal character.------ The char should not be a tab or newline. ----char :: Char -> Doc-char = Doc1 . showChar---- | Show the Int as a Doc.------ > int  = text . show----int :: Int -> Doc-int  = Doc1 . showInt---- | Show the Integer as a Doc.----integer :: Integer -> Doc-integer = Doc1 . showInt---- | Show an \"integral value\" as a Doc via 'fromIntegral'.----integral :: Integral a => a -> Doc-integral = Doc1 . showInt---- | Show the Float as a Doc.----float :: Double -> Doc-float = Doc1 . showFloat---- | Show the Double as a Doc.----double :: Double -> Doc-double = Doc1 . showFloat- --- | Create a Doc containing a single space character.----space :: Doc-space = char ' '---- | Create a Doc containing a comma, \",\".----comma :: Doc-comma = char ','---- | Create a Doc containing a semi colon, \";\".----semicolon :: Doc-semicolon = char ';'---- | Create a Doc containing newline, \"\\n\".----line :: Doc -line = char '\n'--------------------------------------------------------------------------------------- | Fill a doc to the supplied length, padding the right-hand--- side with spaces.------ Note - this function is expensive - it unrolls the functional--- representation of the String. --- --- Also it should only be used for single line Doc\'s.--- -fill :: Int -> Doc -> Doc-fill i d = Doc1 (padr i ' ' $ unDoc d) --padr :: Int -> Char -> ShowS -> ShowS-padr i c df = step (length $ df []) -  where-    step len | len >= i  = df-             | otherwise = df . showString (replicate (i-len) c)-------------------------------------------------------------------------------------- | Punctuate the Doc list with the separator, producing a Doc. ----punctuate :: Doc -> [Doc] -> Doc-punctuate _ []     = empty-punctuate _ [x]    = x-punctuate s (x:xs) = x <> s <> punctuate s xs----- | Enclose the final Doc within the first two.------ There are no spaces between the documents:------ > enclose l r d = l <> d <> r----enclose :: Doc -> Doc -> Doc -> Doc-enclose l r d = l <> d <> r------ | Enclose the Doc within single quotes.----squotes :: Doc -> Doc-squotes = enclose (char '\'') (char '\'')---- | Enclose the Doc within double quotes.----dquotes :: Doc -> Doc-dquotes = enclose (char '"') (char '"')---- | Enclose the Doc within parens @()@.----parens :: Doc -> Doc-parens = enclose lparen rparen---- | Enclose the Doc within square brackets @[]@.----brackets :: Doc -> Doc-brackets = enclose lbracket rbracket---- | Enclose the Doc within curly braces @{}@.----braces :: Doc -> Doc-braces = enclose lbrace rbrace---- | Enclose the Doc within angle brackets @\<\>@.----angles :: Doc -> Doc-angles = enclose langle rangle------ | Create a Doc containing a left paren, \'(\'.----lparen :: Doc-lparen = char '('---- | Create a Doc containing a right paren, \')\'.----rparen :: Doc-rparen = char ')'---- | Create a Doc containing a left square bracket, \'[\'.----lbracket :: Doc-lbracket = char '['---- | Create a Doc containing a right square bracket, \']\'.----rbracket :: Doc-rbracket = char ']'---- | Create a Doc containing a left curly brace, \'{\'.----lbrace :: Doc-lbrace = char '{'---- | Create a Doc containing a right curly brace, \'}\'.----rbrace :: Doc-rbrace = char '}'---- | Create a Doc containing a left angle bracket, \'\<\'.----langle :: Doc-langle = char '<'---- | Create a Doc containing a right angle bracket, \'\>\'.----rangle :: Doc-rangle = char '>'---- | Comma separate the list of documents and enclose in square--- brackets.----list :: [Doc] -> Doc-list = brackets . punctuate comma---- | Comma separate the list of documents and enclose in parens.----tupled :: [Doc] -> Doc-tupled = parens . punctuate comma---- | Separate the list with a semicolon and enclose in curly --- braces.----semiBraces :: [Doc] -> Doc-semiBraces = braces . punctuate semicolon----- | Horizontally indent a Doc.------ Note - this space-prefixes the Doc on /the current line/. It--- does not indent subsequent lines if the Doc spans multiple --- lines.----indent :: Int -> Doc -> Doc-indent i d | i < 1     = d-           | otherwise = Indent i d--

@@ -76,14 +76,15 @@   , r2d   , circularModulo +  -- * Bezier curves   , bezierArc   , bezierCircle    ) where  -import Wumpus.Core.FormatCombinators-import Wumpus.Core.Utils+import Wumpus.Core.Utils.Common+import Wumpus.Core.Utils.FormatCombinators  import Data.AffineSpace                         -- package: vector-space import Data.VectorSpace@@ -411,7 +412,7 @@ -------------------------------------------------------------------------------- -- Points --- | Construct a point at 0 0.+-- | Construct a point at (0,0). -- zeroPt :: Num u => Point2 u zeroPt = P2 0 0@@ -640,7 +641,7 @@ r2d = (*) (180/pi) . fromRadian  --- | Modulate a (positive) angle to be in the range 0..2*pi+-- | Modulo a (positive) angle into the range @0..2*pi@. -- circularModulo :: Radian -> Radian circularModulo r = d2r $ dec + (fromIntegral $ i `mod` 360)@@ -655,7 +656,10 @@ -------------------------------------------------------------------------------- -- Bezier curves --- | Create an arc - this construction is the analogue of +-- | 'bezierArc' : @ radius * ang1 * ang2 * center -> +--       (start_point, control_point1, control_point2, end_point) @+-- +-- Create an arc - this construction is the analogue of  -- PostScript\'s @arc@ command, but the arc is created as a  -- Bezier curve so it should span less than 90deg. --@@ -674,7 +678,9 @@     p3    = pt .+^ avec ang2 r  --- | Make a circle from Bezier curves - @n@ is the number of +-- | 'bezierCircle' : @ n * radius * center -> [Point] @ +-- +-- Make a circle from Bezier curves - @n@ is the number of  -- subdivsions per quadrant. -- bezierCircle :: (Fractional u, Floating u) 

@@ -0,0 +1,224 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.GraphicProps+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Data types for stroke and label styles corresponding to the+-- styles provided by PostScript / SVG (@StrokeAttr@, etc.).+--+-- Data types for annotating Primitives with their drawing style+-- (@PathProps@, etc.). Wumpus represents pictures as trees and+-- decorates all elements (paths, text-labels) with their drawing+-- style. This is boardly similar to how SVG handles attributes. +-- For PostScript output, Wumpus renders attribute changes as +-- graphics state updates. +--   +--------------------------------------------------------------------------------+++module Wumpus.Core.GraphicProps+  (+  +  -- * Stroke attributes+    StrokeAttr(..)+  , LineCap(..)+  , LineJoin(..)+  , DashPattern(..)++  -- * Font attributes+  , FontAttr(..)+  , FontFace(..)+  , SVGFontStyle(..)+++  -- * Drawing styles for Primitives+  , PathProps(..)+  , LabelProps(..)+  , EllipseProps(..)++  -- * Defaults+  , default_stroke_attr+  , defaultFont+  , wumpus_default_font++  ) where++import Wumpus.Core.Colour+import Wumpus.Core.Text.Encoder+import Wumpus.Core.Text.Latin1+import Wumpus.Core.Utils.FormatCombinators++++-- | Stroke attributes for drawing paths.+--+data StrokeAttr = StrokeAttr+      { line_width      :: Double+      , miter_limit     :: Double+      , line_cap        :: LineCap+      , line_join       :: LineJoin+      , dash_pattern    :: DashPattern+      }+  deriving (Eq,Show)++++-- | Line cap - default in output is butt.+--+data LineCap = CapButt | CapRound | CapSquare+  deriving (Enum,Eq,Show)++-- | Line join - default in output is miter.+--+data LineJoin = JoinMiter | JoinRound | JoinBevel+  deriving (Enum,Eq,Show)++-- | Dash pattern - either a solid line or a list of on-off pairs+-- together with an /offset/ into the dashes.+--+data DashPattern = Solid | Dash Int [(Int,Int)]+  deriving (Eq,Show)+++-- | Font face and size. Equivalent fonts have different names+-- in PostScript and SVG. A PostScript font name includes the +-- font style (e.g. @Times-BoldItalic@) whereas an SVG font has +-- a name (the @font-family@ attribute) and a style.+--+-- For PostScript, the following fonts are expected to exist on +-- most platforms:+--+-- > Times-Roman  Times-Italic  Times-Bold  Times-BoldOtalic+-- > Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique+-- > Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique+-- > Symbol+--+-- See the PostScript Language Reference Manual.+--+data FontAttr = FontAttr +      { font_size       :: Int +      , font_face       :: FontFace+      }+  deriving (Eq,Ord,Show)++-- | 'FontFace' : @ postscript_name * svg_font_family * svg_font_style @+--+data FontFace = FontFace+      { font_name       :: String        -- for PostScript+      , svg_font_family :: String        -- for SVG+      , svg_font_style  :: SVGFontStyle+      , font_enc_name   :: FontEncoderName+      }+  deriving (Eq,Ord,Show)++++-- | SVG font styles - potentially a style may generate both+-- @font-weight@ and @font-style@ attributes in the SVG output.+--+data SVGFontStyle = SVG_REGULAR | SVG_BOLD | SVG_ITALIC | SVG_BOLD_ITALIC+                  | SVG_OBLIQUE | SVG_BOLD_OBLIQUE+  deriving (Eq,Ord,Show)+++--------------------------------------------------------------------------------++-- | Note when drawn /filled/ and drawn /stroked/ the same+-- polygon will have (slightly) different size:+--+-- * A filled shape fills /within/ the boundary of the shape+--+-- * A stroked shape draws a pen line around the boundary+--   of the shape. The actual size depends on the thickness+--   of the line (stroke width).+--+data PathProps = CFill RGBi +               | CStroke StrokeAttr RGBi+               | OStroke StrokeAttr RGBi+               -- Note - first colour fill, second colur stroke.+               | CFillStroke RGBi StrokeAttr RGBi+  deriving (Eq,Show)+++-- | Font rendering properties for a PrimLabel.+--+data LabelProps = LabelProps +      { label_colour    :: RGBi+      , label_font      :: FontAttr+      }+  deriving (Eq,Ord,Show)++++-- | Ellipses and circles are always closed.+--+data EllipseProps = EFill RGBi+                  | EStroke StrokeAttr RGBi +                  -- Note - first colour fill, second colour stroke.+                  | EFillStroke RGBi StrokeAttr RGBi +  deriving (Eq,Show)+++++--------------------------------------------------------------------------------++instance Format PathProps where+  format (CFill rgb)          = format rgb <+> text "Fill"+  format (CStroke _ rgb)      = format rgb <+> text "Closed-stroke"+  format (OStroke _ rgb)      = format rgb <+> text "Open-stroke"+  format (CFillStroke f _ s)  = format f <+> text "Fill" <> char '/'+                                         <+> format s <+> text "Stroke"   ++++instance Format LabelProps where+  format (LabelProps rgb attr) = format rgb +                             <+> text (font_name $ font_face attr)++instance Format EllipseProps where+  format (EFill rgb)          = format rgb <+> text "Fill"+  format (EStroke _ rgb)      = format rgb <+> text "Stroke"+  format (EFillStroke f _ s)  = format f <+> text "Fill" <> char '/'+                            <+> format s <+> text "Stroke"   ++--------------------------------------------------------------------------------+-- Defaults++-- | Default stroke attributes.+--+default_stroke_attr :: StrokeAttr+default_stroke_attr = StrokeAttr { line_width      = 1+                                 , miter_limit     = 1+                                 , line_cap        = CapButt+                                 , line_join       = JoinMiter+                                 , dash_pattern    = Solid+                                 }+++++-- | Constructor for the default font, which is @Courier@ (aliased +-- to @Courier New@ for SVG) at the supplied size.+--+defaultFont :: Int -> FontAttr+defaultFont sz = FontAttr sz face +  where+    face = FontFace { font_name         = "Courier"+                    , svg_font_family   = "Courier New"+                    , svg_font_style    = SVG_REGULAR+                    , font_enc_name     = latin1_font_encoder+                    }+++-- | Constant for the default font (@Courier@) at 14 point.+--+wumpus_default_font :: FontAttr+wumpus_default_font = defaultFont 14

@@ -1,166 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.GraphicsState--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Data types for stroke and label attributes. --- --- Wumpus represents pictures as trees - a leaf represents a --- path or text label. All attributes of a path or text label --- (colour, stroke width, font, ...) are stored in the leaf. So--- a picture is a leaf labelled tree.--- --- By contrast, PostScript maintains a global /graphics state/. A --- PostScript program is free to modify the graphics state --- anywhere in the program and subsequent elements are all drawn --- according to the modified graphics state. ------ When Wumpus renders Pictures as PostScript it maintains a --- limited graphics state with just current colour and current --- font. This is so Wumpus can avoid repeating @setrgbcolor@ and--- @findfont@ operations in the generated PostScript if --- subsequent elements share the same values.--- ---   ------------------------------------------------------------------------------------module Wumpus.Core.GraphicsState -  (-  -- * Data types  -    GraphicsState(..)-  -  -- ** Stroke attributes-  , StrokeAttr(..)-  , LineCap(..)-  , LineJoin(..)-  , DashPattern(..)--  -- ** Font-  , FontAttr(..)-  , FontFace(..)-  , SVGFontStyle(..)--  -- * Initial graphic state-  , zeroGS-  , default_stroke_attr--  ) where--import Wumpus.Core.Colour-import Wumpus.Core.TextEncoder-import Wumpus.Core.TextLatin1---- Graphics state datatypes---- | Graphics state used by the rendering monads.------ This type is hidden by the top-level module @Wumpus.Core@.----data GraphicsState = GraphicsState-      { gs_draw_colour  :: RGBi-      , gs_font_size    :: Int-      , gs_font_face    :: FontFace-      , gs_stroke_attr  :: StrokeAttr -      }-  deriving (Eq,Show)---- | Stroke attributes for drawing paths.----data StrokeAttr = StrokeAttr-      { line_width      :: Double-      , miter_limit     :: Double-      , line_cap        :: LineCap-      , line_join       :: LineJoin-      , dash_pattern    :: DashPattern-      }-  deriving (Eq,Show)------ | Line cap - default in output is butt.----data LineCap = CapButt | CapRound | CapSquare-  deriving (Enum,Eq,Show)---- | Line join - default in output is miter.----data LineJoin = JoinMiter | JoinRound | JoinBevel-  deriving (Enum,Eq,Show)---- | Dash pattern - either a solid line or a list of on-off pairs--- together with an /offset/ into the dashes.----data DashPattern = Solid | Dash Int [(Int,Int)]-  deriving (Eq,Show)----- | Font face and size. Equivalent fonts have different names--- in PostScript and SVG. A PostScript font name includes the --- font style (e.g. @Times-BoldItalic@) whereas an SVG font has --- a name (the @font-family@ attribute) and a style.------ For PostScript, the following fonts are expected to exist on --- most platforms:------ > Times-Roman  Times-Italic  Times-Bold  Times-BoldOtalic--- > Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique--- > Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique--- > Symbol------ See the PostScript Language Reference Manual.----data FontAttr = FontAttr -      { font_size       :: Int -      , font_face       :: FontFace-      }-  deriving (Eq,Ord,Show)---- | 'FontFace' : @ postscript_name * svg_font_family * svg_font_style @----data FontFace = FontFace-      { font_name       :: String        -- for PostScript-      , svg_font_family :: String        -- for SVG-      , svg_font_style  :: SVGFontStyle-      , font_enc_name   :: FontEncoderName-      }-  deriving (Eq,Ord,Show)------ | SVG font styles - potentially a style may generate both--- @font-weight@ and @font-style@ attributes in the SVG output.----data SVGFontStyle = SVG_REGULAR | SVG_BOLD | SVG_ITALIC | SVG_BOLD_ITALIC-                  | SVG_OBLIQUE | SVG_BOLD_OBLIQUE-  deriving (Eq,Ord,Show)----- | The initial graphics state--zeroGS ::  GraphicsState -zeroGS = GraphicsState { gs_draw_colour  = black-                       , gs_font_size    = (-1)-                       , gs_font_face    = unmatchable_face-                       , gs_stroke_attr  = default_stroke_attr-                       }-  where-    unmatchable_face = FontFace "DONT_MATCH" "" SVG_BOLD_OBLIQUE latin1_font_encoder----- | Default stroke attributes.----default_stroke_attr :: StrokeAttr-default_stroke_attr = StrokeAttr { line_width      = 1-                                 , miter_limit     = 1-                                 , line_cap        = CapButt-                                 , line_join       = JoinMiter-                                 , dash_pattern    = Solid-                                 }

@@ -1,137 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.OneList--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Data type for non-empty lists.--- -----------------------------------------------------------------------------------module Wumpus.Core.OneList-  (-   -- OneMany-    OneList-  , ViewL(..)--  , one-  , cons-  , head-  , viewl--  , fromList--  , toListF-  , accumMapL-  , isOne-  , isMany-   -  ) where---import Data.Semigroup                           -- package: algebra--import Control.Applicative-import Data.Foldable-import Data.Monoid-import Data.Traversable--import Prelude hiding ( head )---data OneList a = One a | Many a (OneList a)-  deriving (Eq)--data ViewL a = OneL a | a :< (OneList a)-  deriving (Eq)--------------------------------------------------------------------------------------- Instances--instance Show a => Show (OneList a) where-  show = ('{':) . ($ []) . step where-     step (One a)     = shows a . showChar '}'-     step (Many a as) = shows a . showChar ',' . step as---instance Functor OneList where-  fmap f (One a)        = One $ f a-  fmap f (Many a as)    = Many (f a) (fmap f as)--instance Foldable OneList where-  foldMap f (One a)     = f a-  foldMap f (Many a as) = f a `mappend` foldMap f as--  foldr f b0 = step b0 where-    step b (One a)      = f a b-    step b (Many a as)  = f a (step b as)--  foldl f b0 = step b0 where-    step b (One a)      = f b a-    step b (Many a as)  = step (f b a) as---instance Traversable OneList where-  traverse f (One a)      = One  <$> f a-  traverse f (Many a as)  = Many <$> f a <*> traverse f as---instance Semigroup (OneList e) where-  (One a)     `append` bs  = Many a bs-  (Many a as) `append` bs  = Many a (as `append` bs)------------------------------------------------------------------------------------- | Construct One.-one :: a -> OneList a-one = One----- | Prepend an element. Obviously this transforms a One to a Many.-cons :: a -> OneList a -> OneList a-cons a as   = Many a as---- | 'head' is total of course.-head :: OneList a -> a-head (One a)    = a-head (Many a _) = a--viewl :: OneList a -> ViewL a-viewl (One a)     = OneL a-viewl (Many a as) = a :< as---- | Construct Many. Not this function throws a error if the list has--- zero or one elements-fromList :: [a] -> OneList a-fromList []     = error "OneList.fromList: cannot build Many from empty list"-fromList [a]    = One a-fromList (a:as) = Many a (fromList as)---toListF :: (a -> b) -> OneList a -> [b]-toListF f = step where-  step (One x)     = [f x]-  step (Many x xs) = f x : step xs---accumMapL :: (x -> st -> (y,st)) -> OneList x -> st -> (OneList y,st)-accumMapL f (One x)     st = let (y,st') = f x st in (One y,st')-accumMapL f (Many x xs) st = (Many y ys,st'')-                             where (y, st')  = f x st-                                   (ys,st'') = accumMapL f xs st'--isMany :: OneList a -> Bool-isMany (Many _ _) = True-isMany _          = False--isOne :: OneList a -> Bool-isOne (One _)     = True-isOne _           = False-

@@ -29,17 +29,19 @@  import Wumpus.Core.BoundingBox import Wumpus.Core.Colour-import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState-import Wumpus.Core.OneList+import Wumpus.Core.GraphicProps import Wumpus.Core.PictureInternal import Wumpus.Core.PostScriptDoc-import Wumpus.Core.TextDefaultEncoder-import Wumpus.Core.TextEncoder-import Wumpus.Core.TextInternal-import Wumpus.Core.Utils+import Wumpus.Core.Text.DefaultEncoder+import Wumpus.Core.Text.Encoder+import Wumpus.Core.Text.TextInternal+import Wumpus.Core.TrafoInternal+import Wumpus.Core.Utils.Common+import Wumpus.Core.Utils.OneList+import Wumpus.Core.Utils.FormatCombinators + import Control.Applicative hiding ( empty, some ) import Control.Monad @@ -161,6 +163,11 @@ -- | Output a series of pictures to a Postscript file. Each  -- picture will be printed on a separate page.  --+-- Generally an encoder should always support the principal+-- encoders for the fonts used (e.g. Latin1) /and/ the encoder +-- for the Symbol font, as characters from the Symbol font may +-- be used as decorations for plot marks, etc.+-- writePS :: (Real u, Floating u, PSUnit u)          => FilePath -> TextEncoder -> [Picture u] -> IO () writePS filepath enc pic = @@ -170,14 +177,24 @@ -- The .eps file can then be imported or embedded in another  -- document. --+-- Generally an encoder should always support the principal+-- encoders for the fonts used (e.g. Latin1) /and/ the encoder for+-- the Symbol font, as characters from the Symbol font may be used +-- as decorations for plot marks, etc.+-- writeEPS :: (Real u, Floating u, PSUnit u)            => FilePath -> TextEncoder -> Picture u -> IO () writeEPS filepath enc pic =     getZonedTime >>= \ztim -> writeFile filepath (show $ epsDraw ztim enc pic)  --- | Version of 'writePS' - using Latin1 encoding.+-- | Version of 'writePS' - using the /default encoder/ which +-- supports Latin1 and the Symbol font. -- +-- Generally an encoder should always support the principal+-- encoder (e.g. Latin1) /and/ the Symbol font, as characters from+-- the Symbol font may be used as decorations for plot marks, etc.+--  writePS_latin1 :: (Real u, Floating u, PSUnit u)                 => FilePath -> [Picture u] -> IO () writePS_latin1 filepath = writePS filepath defaultEncoder@@ -260,7 +277,7 @@ -- state.  -- picture :: (Real u, Floating u, PSUnit u) => Picture u -> PsMonad Doc-picture (Leaf    (_,xs) ones)   = bracketTrafos xs $ oneConcat primElement ones+picture (Leaf    (_,xs) ones)   = bracketTrafos xs $ oneConcat primitive ones picture (Picture (_,xs) ones)   = bracketTrafos xs $ oneConcat picture ones picture (Group   (_,xs) _ pic) = bracketTrafos xs (picture pic) picture (Clip    (_,xs) cp pic) = bracketTrafos xs $@@ -281,14 +298,12 @@  -- No action is taken for hyperlinks in PostScript. ---primElement :: (Real u, Floating u, PSUnit u) => PrimElement u -> PsMonad Doc-primElement (Atom prim)         = primitive prim-primElement (XLinkGroup _ ones) = oneConcat primElement ones  primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> PsMonad Doc primitive (PPath props pp)     = primPath props pp primitive (PLabel props lbl)   = primLabel props lbl primitive (PEllipse props ell) = primEllipse props ell+primitive (PGroup _ ones)      = oneConcat primitive ones   primPath :: PSUnit u

@@ -38,17 +38,18 @@  import Wumpus.Core.BoundingBox import Wumpus.Core.Colour-import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState-import Wumpus.Core.OneList+import Wumpus.Core.GraphicProps import Wumpus.Core.PageTranslation import Wumpus.Core.PictureInternal import Wumpus.Core.SVGDoc-import Wumpus.Core.TextDefaultEncoder-import Wumpus.Core.TextEncoder-import Wumpus.Core.TextInternal-import Wumpus.Core.Utils+import Wumpus.Core.Text.DefaultEncoder+import Wumpus.Core.Text.Encoder+import Wumpus.Core.Text.TextInternal+import Wumpus.Core.TrafoInternal+import Wumpus.Core.Utils.Common+import Wumpus.Core.Utils.FormatCombinators+import Wumpus.Core.Utils.OneList  import Control.Applicative hiding ( empty, some ) import Data.Maybe@@ -132,13 +133,23 @@  -- | Output a picture to a SVG file.  --+-- Generally an encoder should always support the principal+-- encoders for the fonts used (e.g. Latin1) /and/ the encoder for+-- the Symbol font, as characters from the Symbol font may be used +-- as decorations for plot marks, etc.+-- writeSVG :: (Real u, Floating u, PSUnit u)           => FilePath -> TextEncoder -> Picture u -> IO () writeSVG filepath enc pic =      writeFile filepath $ show $ svgDraw enc pic  --- | Version of 'writeSVG' - using Latin1 and Symbol font encodings. +-- | Version of 'writeSVG' - using Latin1 and Symbol font encoders.  --+-- Generally an encoder should always support the principal+-- encoders for the fonts used (e.g. Latin1) /and/ the encoder for +-- the Symbol font, as characters from the Symbol font may be used +-- as decorations for plot marks, etc.+-- writeSVG_latin1 :: (Real u, Floating u, PSUnit u)                  => FilePath -> Picture u -> IO () writeSVG_latin1 filepath = writeSVG filepath defaultEncoder@@ -170,7 +181,7 @@   picture :: (Real u, Floating u, PSUnit u) => Picture u -> SvgMonad Doc-picture (Leaf    (_,xs) ones)   = bracketTrafos xs $ oneConcat primElement ones+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@@ -193,14 +204,14 @@     instep ac (e :< rest) = fn e >>= \a -> instep (ac `vconcat` a) (viewl rest)  -primElement :: (Real u, Floating u, PSUnit u) => PrimElement u -> SvgMonad Doc-primElement (Atom prim)          = primitive prim-primElement (XLinkGroup xl ones) = drawXLink xl <$> oneConcat primElement ones- primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc primitive (PPath props pp)     = primPath props pp primitive (PLabel props lbl)   = primLabel props lbl primitive (PEllipse props ell) = primEllipse props ell+primitive (PGroup mb ones)     = +    case mb of+      Nothing -> oneConcat primitive ones+      Just xl -> drawXLink xl <$> oneConcat primitive ones    drawXLink :: XLink -> Doc -> Doc

@@ -12,6 +12,11 @@ -- -- Core page translation for SVG. --+-- Note - initially an optimized translate was planned - smaller +-- SVG code size and less use of /rectifying/ transformations for +-- text. However working out a translation scheme proved to be +-- tricky and Wumpus is stuck with the /trivialTransformation/.+-- --------------------------------------------------------------------------------  @@ -24,7 +29,7 @@  import Wumpus.Core.AffineTrans import Wumpus.Core.PictureInternal-+import Wumpus.Core.TrafoInternal   --------------------------------------------------------------------------------@@ -39,19 +44,16 @@ trivialTranslation pic = scale 1 (-1) (trivPic pic)  trivPic :: Num u => Picture u -> Picture u-trivPic (Leaf lc ones)      = Leaf lc $ fmap trivPrimElt ones+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 trivPic (Group lc upd pic)  = Group lc upd $ trivPic pic -trivPrimElt :: Num u => PrimElement u -> PrimElement u-trivPrimElt (Atom prim)          = Atom (trivPrim prim)-trivPrimElt (XLinkGroup xl ones) = XLinkGroup xl $ fmap trivPrimElt ones- trivPrim :: Num u => Primitive u -> Primitive u trivPrim (PPath a pp)     = PPath a pp trivPrim (PLabel a lbl)   = PLabel a (trivLabel lbl) trivPrim (PEllipse a ell) = PEllipse a (trivEllipse ell)+trivPrim (PGroup xl ones) = PGroup xl $ fmap trivPrim ones   trivLabel :: Num u => PrimLabel u -> PrimLabel u

@@ -31,7 +31,7 @@   , curvedPath   , xlinkhref   , xlinkGroup-+  , primGroup    -- * Constructing primitives   , ostroke@@ -46,8 +46,8 @@   , clip    , textlabel+  , rtextlabel   , ztextlabel-  , wumpus_default_font    , hkernlabel   , vkernlabel@@ -56,10 +56,12 @@   , kernEscName    , strokeEllipse+  , rstrokeEllipse   , fillEllipse+  , rfillEllipse   , zellipse   , fillStrokeEllipse-  +  , rfillStrokeEllipse      -- * Operations   , extendBoundary  @@ -80,22 +82,20 @@ import Wumpus.Core.AffineTrans import Wumpus.Core.BoundingBox import Wumpus.Core.Colour-import Wumpus.Core.FormatCombinators hiding ( fill ) import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState-import Wumpus.Core.OneList+import Wumpus.Core.GraphicProps import Wumpus.Core.PictureInternal import Wumpus.Core.PtSize-import Wumpus.Core.TextInternal-import Wumpus.Core.TextLatin1-import Wumpus.Core.Utils+import Wumpus.Core.Text.TextInternal+import Wumpus.Core.TrafoInternal+import Wumpus.Core.Utils.Common+import Wumpus.Core.Utils.FormatCombinators hiding ( fill )+import Wumpus.Core.Utils.OneList  import Data.AffineSpace                         -- package: vector-space-import Data.Semigroup                           -- package: algebra   - -------------------------------------------------------------------------------- -- Construction @@ -109,13 +109,13 @@ -- -- This function throws an error when supplied the empty list. ---frame :: (Real u, Floating u, FromPtSize u) => [PrimElement u] -> Picture u+frame :: (Real u, Floating u, FromPtSize u) => [Primitive u] -> Picture u frame []     = error "Wumpus.Core.Picture.frame - empty list" frame (p:ps) = let (bb,ones) = step p ps in Leaf (bb,[]) ones    where     step a []     = (boundary a, one a)     step a (x:xs) = let (bb', rest) = step x xs-                    in ( boundary a `append` bb', cons a rest )+                    in ( boundary a `boundaryUnion` bb', cons a rest )   @@ -129,7 +129,7 @@   where     step a []     = (boundary a, one a)     step a (x:xs) = let (bb', rest) = step x xs-                    in ( boundary a `append` bb', cons a rest )+                    in ( boundary a `boundaryUnion` bb', cons a rest )   -- | Update the font /delta/ attributes for SVG output.@@ -169,13 +169,21 @@ path :: Point2 u -> [PrimPathSegment u] -> PrimPath u path = PrimPath  --- | Create a straight-line PathSegment.+-- | 'lineTo' : @ end_point -> path_segment @+-- +-- Create a straight-line PathSegment, the start point is +-- implicitly the previous point in a path. -- lineTo :: Point2 u -> PrimPathSegment u lineTo = PLineTo --- | Create a curved PathSegment.+-- | 'curveTo' : @ 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 -> PrimPathSegment u curveTo = PCurveTo @@ -210,55 +218,83 @@  -- | Create a hyperlinked group of Primitives. ---xlinkGroup :: XLink -> [PrimElement u] -> PrimElement u-xlinkGroup _     [] = error "Picture.xlinkGroup - empty prims list"-xlinkGroup xlink (x:xs) = XLinkGroup xlink (step x xs)+-- This function throws a runtime error when supplied with an+-- empty list.+-- +xlinkGroup :: XLink -> [Primitive u] -> Primitive u+xlinkGroup _     []     = error "Picture.xlinkGroup - empty prims list"+xlinkGroup xlink (x:xs) = PGroup (Just xlink) (step x xs)   where     step a []     = one a     step a (y:ys) = cons a (step y ys)  ++-- | Group a list of Primitives.+--+-- This function throws a runtime error when supplied with an+-- empty list.+--+primGroup :: [Primitive u] -> Primitive u+primGroup []     = error "Picture.primGroup - empty prims list"+primGroup (x:xs) = PGroup Nothing (step x xs)+  where+    step a []     = one a+    step a (y:ys) = cons a (step y ys) + -------------------------------------------------------------------------------- -- Take Paths to Primitives  -- *** Stroke --- | Create a open, stroked path.+-- | 'ostroke' : @ rgb * stroke_attr * path -> Primitive @ --+-- Create a open, stroked path.+-- ostroke :: Num u -        => RGBi -> StrokeAttr -> PrimPath u -> PrimElement u-ostroke rgb sa p = Atom $ PPath (OStroke sa rgb) p+        => RGBi -> StrokeAttr -> PrimPath u -> Primitive u+ostroke rgb sa p = PPath (OStroke sa rgb) p  --- | Create a closed, stroked path.+-- | 'cstroke' : @ rgb * stroke_attr * path -> Primitive @+-- +-- Create a closed, stroked path. -- cstroke :: Num u -        => RGBi -> StrokeAttr -> PrimPath u -> PrimElement u-cstroke rgb sa p = Atom $ PPath (CStroke sa rgb) p+        => RGBi -> StrokeAttr -> PrimPath u -> Primitive u+cstroke rgb sa p = PPath (CStroke sa rgb) p  --- | Create an open, stroked path using the default stroke +-- | 'zostroke' : @ path -> Primitive @+--+-- Create an open, stroked path using the default stroke  -- attributes and coloured black. ---zostroke :: Num u => PrimPath u -> PrimElement u+zostroke :: Num u => PrimPath u -> Primitive u zostroke = ostroke black default_stroke_attr  --- | Create a closed stroked path using the default stroke +-- | 'zcstroke' : @ path -> Primitive @+--+-- Create a closed stroked path using the default stroke  -- attributes and coloured black. ---zcstroke :: Num u => PrimPath u -> PrimElement u+zcstroke :: Num u => PrimPath u -> Primitive u zcstroke = cstroke black default_stroke_attr  -------------------------------------------------------------------------------- -- *** Fill  --- | Create a filled path.+-- | 'fill' : @ rgb * path -> Primitive @ ---fill :: Num u => RGBi -> PrimPath u -> PrimElement u-fill rgb p = Atom $ PPath (CFill rgb) p+--  Create a filled path.+--+fill :: Num u => RGBi -> PrimPath u -> Primitive u+fill rgb p = PPath (CFill rgb) p --- | Create a filled path coloured black. -zfill :: Num u => PrimPath u -> PrimElement u+-- | 'zfill' : @ path -> Primitive @+--+-- Create a filled path coloured black. +zfill :: Num u => PrimPath u -> Primitive u zfill = fill black  @@ -266,14 +302,14 @@ -- Filled and stroked (closed) paths  --- | Create a closed path that is both filled and stroked (the fill--- is below in the zorder).+-- | 'fillStroke' : @ fill_rgb * stroke_attr * stroke_rgb * path -> Primitive @ ----- > fill colour * stroke attrs * stroke_colour * ...+-- 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 -> PrimElement u-fillStroke frgb sa srgb p = Atom $ PPath (CFillStroke frgb sa srgb) p+        => RGBi -> StrokeAttr -> RGBi -> PrimPath u -> Primitive u+fillStroke frgb sa srgb p = PPath (CFillStroke frgb sa srgb) p   @@ -281,7 +317,9 @@ -------------------------------------------------------------------------------- -- Clipping  --- | Clip a picture with respect to the supplied path.+-- | 'clip' : @ path * picture -> Picture @+-- +-- Clip a picture 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@@ -289,7 +327,9 @@ -------------------------------------------------------------------------------- -- Labels to primitive --- | Create a text label. The string should not contain newline+-- | 'textlabel' : @ rgb * font_attr * string * baseline_left -> Primitive @+--+-- Create a text label. The string should not contain newline -- or tab characters. Also double-spaces should not be used - a  -- rendering agent for SVG will coalesce double-spaces into a  -- single space. For precise control of spacing and kerning use@@ -298,35 +338,40 @@ -- The supplied point is the left baseline. -- textlabel :: Num u -          => RGBi -> FontAttr -> String -> Point2 u -> PrimElement u-textlabel rgb attr txt pt = Atom $ PLabel (LabelProps rgb attr) lbl +          => RGBi -> FontAttr -> String -> Point2 u -> Primitive u+textlabel rgb attr txt pt = rtextlabel rgb attr txt 0 pt++-- | 'rtextlabel' : @ rgb * font_attr * string * rotation * +--      baseline_left -> Primitive @+--+-- Create a text label rotated by the supplied angle about the +-- baseline-left. +--+-- The supplied point is the left baseline.+--+rtextlabel :: Num u +           => RGBi -> FontAttr -> String -> Radian -> Point2 u -> Primitive u+rtextlabel rgb attr txt theta pt = PLabel (LabelProps rgb attr) lbl    where-    lbl = PrimLabel pt (StdLayout $ lexLabel txt) identityCTM+    lbl = PrimLabel pt (StdLayout $ lexLabel txt) (thetaCTM theta)  --- | Create a label where the font is @Courier@, text size is 14pt+-- | 'ztextlabel' : @ string * baseline_left -> Primitive @+--+-- Create a label where the font is @Courier@, text size is 14pt -- and colour is black. ---ztextlabel :: Num u => String -> Point2 u -> PrimElement u+ztextlabel :: Num u => String -> Point2 u -> Primitive u ztextlabel = textlabel black wumpus_default_font  --- | Constant for the default font, which is @Courier@ (aliased --- to @Courier New@ for SVG) at 14 point.-------wumpus_default_font :: FontAttr-wumpus_default_font = FontAttr 14 face -  where-    face = FontFace { font_name         = "Courier"-                    , svg_font_family   = "Courier New"-                    , svg_font_style    = SVG_REGULAR-                    , font_enc_name     = latin1_font_encoder-                    }  -------------------------------------------------------------------------------- --- | Create a text label with horizontal /kerning/ for each +-- | 'hkernlabel' : @ rgb * font_attr * kerning_chars * +--        baseline_left -> Primitive @+--+-- Create a text label with horizontal /kerning/ for each  -- character.  -- -- Note - kerning is relative to the left baseline of the @@ -351,14 +396,17 @@ -- hkernlabel :: Num u              => RGBi -> FontAttr -> [KerningChar u] -> Point2 u -            -> PrimElement u-hkernlabel rgb attr xs pt = Atom $ PLabel (LabelProps rgb attr) lbl +            -> Primitive u+hkernlabel rgb attr xs pt = PLabel (LabelProps rgb attr) lbl    where     lbl = PrimLabel pt (KernTextH xs) identityCTM   --- | Create a text label with vertical /kerning/ for each +-- | 'vkernlabel' : @ rgb * font_attr * kerning_chars * +--        baseline_left -> Primitive @+--+-- Create a text label with vertical /kerning/ for each  -- character - the text is expected to grow downwards.  -- -- Note - /kerning/ here is the measure between baselines of @@ -386,26 +434,34 @@ -- vkernlabel :: Num u              => RGBi -> FontAttr -> [KerningChar u] -> Point2 u -            -> PrimElement u-vkernlabel rgb attr xs pt = Atom $ PLabel (LabelProps rgb attr) lbl +            -> Primitive u+vkernlabel rgb attr xs pt = PLabel (LabelProps rgb attr) lbl    where     lbl = PrimLabel pt (KernTextV xs) identityCTM   --- | Construct a regular (i.e. non-special) Char along with its +-- | 'kernchar' : @ displacement * char -> KerningChar @+-- +-- Construct a regular (i.e. non-special) Char along with its  -- displacement from the left-baseline of the previous Char. -- kernchar :: u -> Char -> KerningChar u kernchar u c = (u, CharLiteral c) --- | Construct a Char by its character code along with its ++-- | 'kernEscInt' : @ displacement * char_code -> KerningChar @+-- +-- 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 u i = (u, CharEscInt i) --- | Construct a Char by its character name along with its ++-- | 'kernEscName' : @ displacement * char_name -> KerningChar @+-- +-- Construct a Char by its character name along with its  -- displacement from the left-baseline of the previous Char. -- kernEscName :: u -> String -> KerningChar u@@ -414,7 +470,9 @@ --------------------------------------------------------------------------------  --- | Create a stroked ellipse.+-- | 'strokeEllipse' : @ rgb * stroke_attr * rx * ry * center -> Primtive @+-- +-- Create a stroked ellipse. -- -- Note - within Wumpus, ellipses are considered an unfortunate -- but useful /optimization/. Drawing good cicles with Beziers @@ -431,37 +489,86 @@ -- Avoid non-uniform scaling stroked ellipses! -- strokeEllipse :: Num u -             => RGBi -> StrokeAttr -> u -> u -> Point2 u -> PrimElement u-strokeEllipse rgb sa hw hh pt = -    Atom $ PEllipse (EStroke sa rgb) (PrimEllipse pt hw hh identityCTM)+             => RGBi -> StrokeAttr -> u -> u -> Point2 u -> Primitive u+strokeEllipse rgb sa hw hh pt = rstrokeEllipse rgb sa hw hh 0 pt --- | Create a filled ellipse.++-- | 'rstrokeEllipse' : @ rgb * stroke_attr * rx * ry * rotation * +--      center -> Primtive @+-- +-- Create a stroked ellipse rotated about the center by /theta/. --+rstrokeEllipse :: Num u +               => RGBi -> StrokeAttr -> u -> u -> Radian -> Point2 u+               -> Primitive u+rstrokeEllipse rgb sa rx ry theta pt = +    PEllipse (EStroke sa rgb) (mkPrimEllipse rx ry theta pt)++++-- | 'fillEllipse' : @ rgb * stroke_attr * rx * ry * center -> Primtive @+--+-- Create a filled ellipse.+-- fillEllipse :: Num u -             => RGBi -> u -> u -> Point2 u -> PrimElement u-fillEllipse rgb hw hh pt = -    Atom $ PEllipse (EFill rgb) (PrimEllipse pt hw hh identityCTM)+             => RGBi -> u -> u -> Point2 u -> Primitive u+fillEllipse rgb rx ry pt = rfillEllipse rgb rx ry 0 pt+  +-- | 'rfillEllipse' : @ colour * stroke_attr * rx * ry * +--      rotation * center -> Primtive @+--+-- Create a filled ellipse rotated about the center by /theta/.+--+rfillEllipse :: Num u +             => RGBi -> u -> u -> Radian -> Point2 u -> Primitive u+rfillEllipse rgb rx ry theta pt = +    PEllipse (EFill rgb) (mkPrimEllipse rx ry theta pt) --- | Create a black, filled ellipse. -zellipse :: Num u => u -> u -> Point2 u -> PrimElement u-zellipse hw hh pt = fillEllipse black hw hh pt +-- | 'zellipse' : @ rx * ry * center -> Primtive @+--+-- Create a black, filled ellipse. +--+zellipse :: Num u => u -> u -> Point2 u -> Primitive u+zellipse hw hh pt = rfillEllipse black hw hh 0 pt --- | Create a bordered (i.e. filled and stroked) ellipse.++-- | 'fillStrokeEllipse' : @ fill_rgb * stroke_attr * stroke_rgb * rx * ry *+--      center -> Primtive @ --+-- Create a bordered (i.e. filled and stroked) ellipse.+-- fillStrokeEllipse :: Num u -                 => RGBi -> StrokeAttr -> RGBi -> u -> u -> Point2 u -                 -> PrimElement u-fillStrokeEllipse frgb sa srgb hw hh pt = -    Atom $ PEllipse (EFillStroke frgb sa srgb) (PrimEllipse pt hw hh identityCTM)+                  => RGBi -> StrokeAttr -> RGBi -> u -> u -> Point2 u +                  -> Primitive u+fillStrokeEllipse frgb sa srgb rx ry pt = +    rfillStrokeEllipse frgb sa srgb rx ry 0 pt+      +-- | 'rfillStrokeEllipse' : @ fill_rgb * stroke_attr * stroke_rgb * rx * ry *+--      theta * center -> Primtive @+--+-- 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 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 rx ry theta pt = PrimEllipse pt rx ry (thetaCTM theta)+ -------------------------------------------------------------------------------- -- Operations --- | Extend the bounding box of a picture. +-- | 'extendBoundary' : @ x * y * picture -> Picture @+-- +-- Extend the bounding box of a picture.  -- -- The bounding box is both horizontal directions by @x@ and  -- both vertical directions by @y@. @x@ and @y@ must be positive@@ -482,7 +589,7 @@  infixr 6 `picBeside`, `picOver` --- | 'picOver' : @ picture -> picture -> picture @+-- | 'picOver' : @ picture * picture -> Picture @ -- -- Draw the first picture on top of the second picture -  -- neither picture will be moved.@@ -490,20 +597,20 @@ picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u a `picOver` b = Picture (bb,[]) (cons b $ one a)    where-    bb = boundary a `append` boundary b+    bb = boundary a `boundaryUnion` boundary b  -- picOver note - draw b, put b first in the list, so it draws  -- first in the output (this is also @behind@ in the Z-Order).  --- | 'picMoveBy' : @ picture -> vector -> picture @+-- | 'picMoveBy' : @ picture * vector -> Picture @ --  --  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  --- | 'picBeside' : @ picture -> picture -> picture @+-- | 'picBeside' : @ picture * picture -> Picture @ -- -- Move the second picture to sit at the right side of the -- first picture@@ -524,7 +631,7 @@ printPicture pic = putStrLn (show $ format pic) >> putStrLn []  --- | 'illustrateBounds' : @ colour -> picture -> picture @+-- | 'illustrateBounds' : @ bbox_rgb * picture -> Picture @ --  -- Draw the picture on top of an image of its bounding box. -- The bounding box image will be drawn in the supplied colour.@@ -534,7 +641,7 @@ illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb p)   --- | 'illustrateBoundsPrim' : @ colour -> primitive -> picture @+-- | 'illustrateBoundsPrim' : @ bbox_rgb * primitive -> Picture @ --  -- Draw the primitive on top of an image of its bounding box. -- The bounding box image will be drawn in the supplied colour.@@ -542,7 +649,7 @@ -- The result will be lifted from Primitive to Picture. --  illustrateBoundsPrim :: (Real u, Floating u, FromPtSize u) -                     => RGBi -> PrimElement u -> Picture u+                     => RGBi -> Primitive u -> Picture u illustrateBoundsPrim rgb p = frame (p : boundsPrims rgb p)  @@ -551,7 +658,7 @@ -- joining the corners. -- boundsPrims :: (Num u, Ord u, Boundary t, u ~ DUnit t) -            => RGBi -> t -> [PrimElement u]+            => RGBi -> t -> [Primitive u] boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ]   where     (bl,br,tr,tl) = boundaryCorners $ boundary a@@ -563,26 +670,25 @@                                         , dash_pattern = Dash 0 [(1,2)] }  --- | Generate the control points illustrating the Bezier curves +-- | 'illustrateControlPoints' : @ control_point_rgb * primitive -> Picture @+-- +-- Generate the control points illustrating the Bezier curves  -- within a picture. --  -- This has no effect on TextLabels. Nor does it draw Beziers of --- a hyperlinked obkect.+-- a hyperlinked object. --  -- Pseudo control points are generated for ellipses, although  -- strictly speaking ellipses do not use Bezier curves - they  -- are implemented with PostScript\'s @arc@ command.   -- illustrateControlPoints :: (Real u, Floating u, FromPtSize u)-                        => RGBi -> PrimElement u -> Picture u-illustrateControlPoints rgb elt = outer elt+                        => RGBi -> Primitive u -> Picture u+illustrateControlPoints rgb elt = frame $ step elt   where-    outer a@(Atom prim) = frame (a : step prim)-    outer a             = frame [a]-     step (PEllipse _ e) = ellipseCtrlLines rgb e     step (PPath    _ p) = pathCtrlLines rgb p-    step _              = []+    step a              = [a]  -- Genrate lines illustrating the control points of curves on  -- a Path.@@ -592,7 +698,7 @@ -- -- Nothing is generated for a straight line. ---pathCtrlLines :: (Num u, Ord u) => RGBi -> PrimPath u -> [PrimElement u]+pathCtrlLines :: (Num u, Ord u) => RGBi -> PrimPath u -> [Primitive u] pathCtrlLines rgb (PrimPath start ss) = step start ss   where      -- trail the current end point through the recursion...@@ -611,7 +717,7 @@ -- start-point to control-point1; control-point2 to end-point -- ellipseCtrlLines :: (Real u, Floating u) -                 => RGBi -> PrimEllipse u -> [PrimElement u]+                 => RGBi -> PrimEllipse u -> [Primitive u] ellipseCtrlLines rgb pe = start all_points   where      -- list in order: 

@@ -22,51 +22,35 @@     Picture(..)   , DPicture   , Locale-  , AffineTrafo(..)   , FontCtx(..) -  , PrimElement(..)-  , DPrimElement   , Primitive(..)   , DPrimitive   , XLink(..)    , PrimPath(..)   , DPrimPath-  , PathProps(..)   , PrimPathSegment(..)   , DPrimPathSegment   , PrimLabel(..)   , DPrimLabel-  , LabelProps(..)   , LabelBody(..)   , DLabelBody   , KerningChar   , DKerningChar     , PrimEllipse(..)-  , EllipseProps(..)-  , PrimCTM(..) +  , GraphicsState(..)+   , pathBoundary   , mapLocale -  -- * PrimCTM-  , identityCTM-  , scaleCTM-  , rotateCTM-  , matrixRepCTM-  , translMatrixRepCTM--  , rotatePrim-  , scalePrim-  , uniformScalePrim-  , translatePrim-   -- * Additional operations   , concatTrafos   , deconsMatrix   , repositionDeltas +  , zeroGS    ) where @@ -74,17 +58,18 @@ import Wumpus.Core.BoundingBox import Wumpus.Core.Colour import Wumpus.Core.FontSize-import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState-import Wumpus.Core.OneList+import Wumpus.Core.GraphicProps import Wumpus.Core.PtSize-import Wumpus.Core.TextInternal-import Wumpus.Core.Utils+import Wumpus.Core.Text.Latin1+import Wumpus.Core.Text.TextInternal+import Wumpus.Core.TrafoInternal+import Wumpus.Core.Utils.Common+import Wumpus.Core.Utils.FormatCombinators+import Wumpus.Core.Utils.OneList   import Data.AffineSpace                         -- package: vector-space-import Data.Semigroup                           -- package: algebra  import qualified Data.Foldable                  as F @@ -125,7 +110,7 @@ -- updates for the SVG renderer - in some instances this can  -- improve the code size of the generated SVG. ---data Picture u = Leaf     (Locale u)              (OneList (PrimElement u))+data Picture u = Leaf     (Locale u)              (OneList (Primitive u))                | Picture  (Locale u)              (OneList (Picture u))                | Clip     (Locale u) (PrimPath u) (Picture u)                | Group    (Locale u) FontCtx      (Picture u)@@ -133,24 +118,7 @@  type DPicture = Picture Double --- | To represent XLink hyperlinks, Primitives in a Leaf are --- actualy encoded in a tree rather a list.------ As a design, this is rather unfortunate as it demands an extra --- wrapper for ever element regardless of whether hyperlinks are --- actually used. But it does mean that one hyperlink can cover a --- complex graphic element - for example an arrow might be drawn --- with one or more paths, plus extra (filled or stroked) paths --- for the tip and tail, but each element should be within the --- link. ----data PrimElement u = Atom             (Primitive u)-                   | XLinkGroup XLink (OneList (PrimElement u))-  deriving (Show) -type DPrimElement = PrimElement Double-- -- | Set the font /delta/ for SVG rendering.  --  -- Note - this does not change the default colour or font style. @@ -181,15 +149,6 @@ type Locale u = (BoundingBox u, [AffineTrafo u])  --- | 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-  deriving (Eq,Show)                   -- | Wumpus\'s drawings are built from two fundamental  -- primitives: paths (straight line segments and Bezier curves) @@ -214,9 +173,14 @@ -- Though typically for affine transformations a Fractional  -- constraint is also obliged. ---data Primitive u = PPath    PathProps    (PrimPath u)-                 | PLabel   LabelProps   (PrimLabel u)-                 | PEllipse EllipseProps (PrimEllipse u)+-- To represent XLink hyperlinks, Primitives can be grouped +-- together at the same type (so 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)+                 | PGroup   (Maybe XLink) (OneList (Primitive u))   deriving (Eq,Show)  type DPrimitive = Primitive Double@@ -226,6 +190,7 @@ newtype XLink = XLink { getXLink :: String }   deriving (Eq,Show) + -- | PrimPath - start point and a list of path segments. -- data PrimPath u = PrimPath (Point2 u) [PrimPathSegment u]@@ -241,20 +206,6 @@  type DPrimPathSegment = PrimPathSegment Double --- | Note when drawn /filled/ and drawn /stroked/ the same--- polygon will have (slightly) different size:------ * A filled shape fills /within/ the boundary of the shape------ * A stroked shape draws a pen line around the boundary---   of the shape. The actual size depends on the thickness---   of the line (stroke width).----data PathProps = CFill RGBi -               | CStroke StrokeAttr RGBi-               | OStroke StrokeAttr RGBi-               | CFillStroke RGBi StrokeAttr RGBi-  deriving (Eq,Show)   -- | Label - represented by /baseline/ left point and text.@@ -268,15 +219,7 @@  type DPrimLabel = PrimLabel Double --- | Font rendering properties for a PrimLabel.----data LabelProps   = LabelProps -      { label_colour :: RGBi-      , label_font   :: FontAttr-      }-  deriving (Eq,Ord,Show) - -- | Label can be draw with 3 layouts. --  -- The standard layout uses @show@ for PostScript and a single @@ -315,23 +258,22 @@   deriving (Eq,Show)  --- | Ellipses and circles are always closed.----data EllipseProps = EFill RGBi-                  | EStroke StrokeAttr RGBi -                  -- Note - first colour fill, second colour stroke.-                  | EFillStroke RGBi StrokeAttr RGBi -  deriving (Eq,Show)   --- Note - primitives are not considered to exist in an affine --- space. ++--------------------------------------------------------------------------------+-- Graphics state datatypes++-- | Graphics state used by the rendering monads. ---data PrimCTM u = PrimCTM -      { ctm_scale_x     :: u-      , ctm_scale_y     :: u-      , ctm_rotation    :: Radian +-- This type is hidden by the top-level module @Wumpus.Core@.+--+data GraphicsState = GraphicsState+      { gs_draw_colour  :: RGBi+      , gs_font_size    :: Int+      , gs_font_face    :: FontFace+      , gs_stroke_attr  :: StrokeAttr        }   deriving (Eq,Show) @@ -340,9 +282,10 @@ -- family instances  type instance DUnit (Picture u)     = u-type instance DUnit (PrimElement 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@@ -351,7 +294,7 @@ instance (Num u, PSUnit u) => Format (Picture u) where   format (Leaf m prims)     = indent 2 $ vcat [ text "** Leaf-pic **"                                               , fmtLocale m -                                              , fmtPrimElems prims ]+                                              , fmtPrimlist prims ]    format (Picture m pics)   = indent 2 $ vcat [ text "** Tree-pic **"                                               , fmtLocale m@@ -372,17 +315,7 @@   where     fn (n,acc) e = (n+1, vcat [ acc, text "-- " <+> int n, format e, line]) -fmtPrimElems :: PSUnit u => OneList (PrimElement u) -> Doc-fmtPrimElems 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 (PrimElement u) where-  format (Atom prim)          = format prim-  format (XLinkGroup xl ones) = vcat [ text "-- xlink " <+> format xl -                                     , fmtPrimElems ones  ]-                                     - fmtLocale :: (Num u, PSUnit u) => Locale u -> Doc fmtLocale (bb,_) = format bb @@ -397,7 +330,16 @@   format (PEllipse props e) =        indent 2 $ vcat [ text "ellipse:" <+> format props, format e ] +  format (PGroup xl ones)   = +      vcat [ text "-- group " <+> (maybe empty format xl), fmtPrimlist ones  ] ++fmtPrimlist :: PSUnit u => OneList (Primitive u) -> 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@@ -429,32 +371,6 @@                                    <+> text "ctm="      <> format ctm    -instance PSUnit u => Format (PrimCTM u) where-  format (PrimCTM x y ang) = -      parens (text "CTM" <+> text "sx="   <> dtruncFmt x -                         <+> text "sy="   <> dtruncFmt y -                         <+> text "ang="  <> format ang  )---instance Format PathProps where-  format (CFill rgb)          = format rgb <+> text "Fill"-  format (CStroke _ rgb)      = format rgb <+> text "Closed-stroke"-  format (OStroke _ rgb)      = format rgb <+> text "Open-stroke"-  format (CFillStroke f _ s)  = format f <+> text "Fill" <> char '/'-                            <+> format s <+> text "Stroke"   ----instance Format LabelProps where-  format (LabelProps rgb attr) = format rgb -                             <+> text (font_name $ font_face attr)--instance Format EllipseProps where-  format (EFill rgb)          = format rgb <+> text "Fill"-  format (EStroke _ rgb)      = format rgb <+> text "Stroke"-  format (EFillStroke f _ s)  = format f <+> text "Fill" <> char '/'-                            <+> format s <+> text "Stroke"   - instance Format XLink where   format (XLink ss) = text "xlink" <+> text ss @@ -468,20 +384,18 @@   boundary (Group   (bb,_) _ _) = bb  -instance (Real u, Floating u, FromPtSize u) => Boundary (PrimElement u) where-  boundary (Atom prim)         = boundary prim-  boundary (XLinkGroup _ ones) = outer $ viewl ones +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 (PGroup _ ones)  = outer $ viewl ones      where       outer (OneL a)     = boundary a       outer (a :< as)    = inner (boundary a) (viewl as) -      inner bb (OneL a)  = bb `append` boundary a-      inner bb (a :< as) = inner (bb `append` boundary a) (viewl as)+      inner bb (OneL a)  = bb `boundaryUnion` boundary a+      inner bb (a :< as) = inner (bb `boundaryUnion` boundary a) (viewl as) -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   @@ -526,6 +440,7 @@             => FontSize -> EncodedText -> BoundingBox u stdLayoutBB sz etxt = textBoundsEnc sz zeroPt etxt + -- Note - this assumes positive deltas (and a nonempty list)... -- -- Kern deltas are relative to the left basepoint, so they are@@ -579,11 +494,11 @@ -------------------------------------------------------------------------------- -- Affine transformations --- Note YRange remains constant (as do the actually points --- within the primitives).--- --- TO DO - this is potentially wrong...-+-- Affine transformation of Pictures only transforms the +-- BoundingBox, the primitives within the picture are untouched.+-- The transformation is transmitted to PostScript as a matrix +-- update (frame change).+--  instance (Num u, Ord u) => Transform (Picture u) where   transform mtrx = @@ -613,168 +528,61 @@ mapLocale f (Clip lc pp pic)   = Clip (f lc) pp pic mapLocale f (Group lc upd pic) = Group (f lc) upd pic ------------------------------------------------------------------------------------ Manipulating the PrimCTM -identityCTM :: Num u => PrimCTM u-identityCTM = PrimCTM { ctm_scale_x = 1, ctm_scale_y = 1, ctm_rotation = 0 }----scaleCTM :: Num u => u -> u -> PrimCTM u -> PrimCTM u-scaleCTM x1 y1 (PrimCTM sx sy ang) = PrimCTM (x1*sx) (y1*sy) ang--rotateCTM :: Radian -> PrimCTM u -> PrimCTM u-rotateCTM ang1 (PrimCTM sx sy ang) = PrimCTM sx sy (circularModulo $ ang1+ang)--matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u-matrixRepCTM (PrimCTM sx sy ang) = -    rotationMatrix (circularModulo ang) * scalingMatrix sx sy----- Note - the order of combining a translation (i.e. the --- location of a point) and the CTM is crucial as matrix--- multiplication is not commutative.------ This function encapsulates the correct order.----translMatrixRepCTM :: (Floating u, Real u) -                   => u -> u -> PrimCTM u -> Matrix3'3 u-translMatrixRepCTM x y ctm = translationMatrix x y * matrixRepCTM ctm--- -------------------------------------------------------------------------------- -- Transform primitives  --- | Rotate a Primitive.--- --- Note - this is not an affine transformation as Primitives are--- not regarded as being within an affine frame.------ * Paths are rotated about their start point.------ * Labels are rotated about the bottom-left corner.------ * Ellipses are rotated about the center.------ For Primitives and Ellipses applying a rotation and or a scale --- will generate an additional matrix transformation in the --- generated PostScript. For Paths all transformations are--- \"cost-free\".+-- Note - Primitives are not instances of transform ---rotatePrim :: (Real u, Floating u) -           => Radian -> PrimElement u -> PrimElement u-rotatePrim ang (Atom prim)             = Atom $ rotatePrimitive ang prim-rotatePrim ang (XLinkGroup xlink ones) = -    XLinkGroup xlink $ fmap (rotatePrim ang) ones---rotatePrimitive :: (Real u, Floating u) -                => Radian -> Primitive u -> Primitive u-rotatePrimitive ang (PPath a path)   = PPath    a $ rotatePath ang path-rotatePrimitive ang (PLabel a lbl)   = PLabel   a $ rotateLabel ang lbl-rotatePrimitive ang (PEllipse a ell) = PEllipse a $ rotateEllipse ang ell----- | Scale a Primitive.+-- (ShapeCTM is not a real matrix). -- --- Note - this is not an affine transformation as Primitives are--- not regarded as being within an affine frame.------ An affine scaling uniformly scales all the elements in a --- Picture. It is just a change of the Picture\'s basis vectors.--- The elements within the Picture are unchanged - though --- obviously rendering changes according to the transformation.------ By contrast, the scaling operation on Primitives changes the --- properties of the object as it is applied - e.g. for a path--- the vector between the start point and all subsequent points--- is changed with respect to the x,y scaling factors; for an--- ellipse the half-width and half-height of the ellipse is--- scaled.------ For Primitives and Ellipses applying a rotation and or a scale --- will generate an additional matrix transformation in the --- generated PostScript. For Paths all transformations are --- \"cost-free\".----scalePrim :: Num u => u -> u -> PrimElement u -> PrimElement u-scalePrim x y (Atom prim)             = Atom $ scalePrimitive x y prim-scalePrim x y (XLinkGroup xlink ones) = -    XLinkGroup xlink $ fmap (scalePrim x y) ones +instance (Real u, Floating u) => Rotate (Primitive u) 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 (PGroup xln xs)  = PGroup xln $ fmap (rotate r) xs+  -scalePrimitive :: Num u => u -> u -> Primitive u -> Primitive u-scalePrimitive x y (PPath a path)   = PPath    a $ scalePath x y path-scalePrimitive x y (PLabel a lbl)   = PLabel   a $ scaleLabel x y lbl-scalePrimitive x y (PEllipse a ell) = PEllipse a $ scaleEllipse x y ell+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 (PGroup xln xs)  = PGroup xln $ fmap (rotateAbout r pt) xs --- | Apply a uniform scale to a Primitive.----uniformScalePrim :: Num u => u -> PrimElement u -> PrimElement u-uniformScalePrim d = scalePrim d d  --- | Translate a primitive.------ Translation is essentially \"cost-free\" for the generated --- PostScript or SVG. Paths are translated before the PostScript --- is generated. For Ellipses and Labels, translation will --- either move the bottom-left origin (Label) or center --- (Ellipse); or if they are also scaled or rotated the --- translation will be concatenated into the matrix operation in --- the generated output. --- -translatePrim :: Num u => u -> u -> PrimElement u -> PrimElement u-translatePrim x y (Atom prim)             = -    Atom $ translatePrimitive x y prim+instance Num u => Scale (Primitive u) 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 (PGroup xln xs)   = PGroup xln $ fmap (scale sx sy) xs -translatePrim x y (XLinkGroup xlink ones) = -    XLinkGroup xlink $ fmap (translatePrim x y) ones -translatePrimitive :: Num u => u -> u -> Primitive u -> Primitive u-translatePrimitive x y (PPath a path)   = PPath a $ translatePath x y path-translatePrimitive x y (PLabel a lbl)   = PLabel a $ translateLabel x y lbl-translatePrimitive x y (PEllipse a ell) = PEllipse a $ translateEllipse x y ell-+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 (PGroup xln xs)  = PGroup xln $ fmap (translate dx dy) xs   -------------------------------------------------------------------------------- -- Paths --- Cannot support general matrix transform or rotateAbout on --- Ellipses or Labels so there are not supported on Paths.--- --- rotatePath - rotate the path about its start point.--- --- This is a visually intuitive interpretation - Primitives are--- not in an affine space (they have an origin, i.e. the location --- (0,0), but do not have tangible basis vectors) so manipulating --- them cannot follow the standard affine interpretation.---  rotatePath :: (Real u, Floating u) => Radian -> PrimPath u -> PrimPath u-rotatePath ang (PrimPath start xs) = PrimPath start $ map (mapSeg fn) xs -  where-    fn = rotateAbout ang start+rotatePath ang = mapPath (rotate ang) --- scalePath - scale the vector between each point and the start --- point.------ This produces visually inituitive results. As primitives --- don\'t exist in an affine space / affine frame until they--- are lifted to Pictures their manipulation cannot correspond--- to the standard affine manipulations.---++rotateAboutPath :: (Real u, Floating u) +                => Radian -> Point2 u -> PrimPath u -> PrimPath u+rotateAboutPath ang pt = mapPath (rotateAbout ang pt) ++ scalePath :: Num u => u -> u -> PrimPath u -> PrimPath u-scalePath x y (PrimPath pt xs) = PrimPath pt $ map (mapSeg fn) xs-  where-    fn p1 = let dif = p1 .-. pt in pt .+^ (scale x y $ dif)+scalePath sx sy = mapPath (scale sx sy) --- translatePath - move all points in the path by the supplied --- x and y values.---+ translatePath :: Num u => u -> u -> PrimPath u -> PrimPath u translatePath x y = mapPath (translate x y) @@ -791,42 +599,61 @@   --- Rotations on a (primitive) Label are interpreted as rotating--- about the bottom-left corner.+-- Rotate the baseline-left start point _AND_ the CTM of the +-- label. ---rotateLabel :: Radian -> PrimLabel u -> PrimLabel u-rotateLabel ang (PrimLabel pt txt ctm) = PrimLabel pt txt (rotateCTM ang ctm)+rotateLabel :: (Real u, Floating u) +            => Radian -> PrimLabel u -> PrimLabel u+rotateLabel ang (PrimLabel pt txt ctm) = +    PrimLabel (rotate ang pt) 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 pt0 (PrimLabel pt txt ctm) = +    PrimLabel (rotateAbout ang pt0 pt) txt (rotateCTM ang ctm)++ scaleLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u-scaleLabel x y (PrimLabel pt txt ctm) = PrimLabel pt txt (scaleCTM x y ctm)+scaleLabel sx sy (PrimLabel pt txt ctm) = +    PrimLabel (scale sx sy pt) txt (scaleCTM sx sy ctm)   -- Change the bottom-left corner. -- translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u-translateLabel x y (PrimLabel pt txt ctm) = PrimLabel (translate x y pt) txt ctm+translateLabel dx dy (PrimLabel pt txt ctm) = +    PrimLabel (translate dx dy pt) txt ctm  -------------------------------------------------------------------------------- -- Ellipse  -rotateEllipse :: Radian -> PrimEllipse u -> PrimEllipse u+rotateEllipse :: (Real u, Floating u) +              => Radian -> PrimEllipse u -> PrimEllipse u rotateEllipse ang (PrimEllipse pt hw hh ctm) = -    PrimEllipse pt hw hh (rotateCTM ang ctm)+    PrimEllipse (rotate ang pt) hw hh (rotateCTM ang ctm)      +rotateAboutEllipse :: (Real u, Floating u) +              => Radian -> Point2 u -> PrimEllipse u -> PrimEllipse u+rotateAboutEllipse ang pt0 (PrimEllipse pt hw hh ctm) = +    PrimEllipse (rotateAbout ang pt0 pt) hw hh (rotateCTM ang ctm) + scaleEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u-scaleEllipse x y (PrimEllipse pt hw hh ctm) = -    PrimEllipse (translate x y pt) hw hh (scaleCTM x y ctm)+scaleEllipse sx sy (PrimEllipse pt hw hh ctm) = +    PrimEllipse (scale sx sy pt) hw hh (scaleCTM sx sy ctm)        -- Change the point -- translateEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u-translateEllipse x y (PrimEllipse pt hw hh ctm) = -    PrimEllipse (translate x y pt) hw hh ctm+translateEllipse dx dy (PrimEllipse pt hw hh ctm) = +    PrimEllipse (translate dx dy pt) hw hh ctm   @@ -834,17 +661,6 @@ -- Additional operations  -concatTrafos :: (Floating u, Real u) => [AffineTrafo u] -> Matrix3'3 u-concatTrafos = foldr (\e ac -> matrixRepr e * ac) identityMatrix--matrixRepr :: (Floating u, Real u) => AffineTrafo u -> Matrix3'3 u-matrixRepr (Matrix mtrx)        = mtrx-matrixRepr (Rotate theta)       = rotationMatrix theta-matrixRepr (RotAbout theta pt)  = originatedRotationMatrix theta pt-matrixRepr (Scale sx sy)        = scalingMatrix sx sy -matrixRepr (Translate dx dy)    = translationMatrix dx dy-- -- | Destructor for Matrix3'3. --  -- Pattern matching on 6-tuple may be more convenient than using @@ -879,4 +695,26 @@         y  = 4 - lly         ll = P2 (llx+x) (lly+y)         ur = P2 (urx+x) (ury+y) +++--------------------------------------------------------------------------------++-- | 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@+-- command to be generated (PostScript @findfont@ commands are +-- only written in the output on /deltas/ to reduce the +-- output size).+--+zeroGS ::  GraphicsState +zeroGS = GraphicsState { gs_draw_colour  = black+                       , gs_font_size    = (-1)+                       , gs_font_face    = unmatchable_face+                       , gs_stroke_attr  = default_stroke_attr+                       }+  where+    unmatchable_face = FontFace "DONT_MATCH"     "" +                                SVG_BOLD_OBLIQUE latin1_font_encoder+ 

@@ -65,12 +65,12 @@  import Wumpus.Core.BoundingBox import Wumpus.Core.Colour-import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState+import Wumpus.Core.GraphicProps import Wumpus.Core.PictureInternal-import Wumpus.Core.TextEncoder-import Wumpus.Core.Utils+import Wumpus.Core.Text.Encoder+import Wumpus.Core.Utils.Common+import Wumpus.Core.Utils.FormatCombinators  import Data.Time 

@@ -49,7 +49,7 @@ -- Note - the Double instance perfoms no scaling, this -- is because internally Wumpus-Core works in points. -- -class FromPtSize u where+class Num u => FromPtSize u where   fromPtSize :: PtSize -> u  instance FromPtSize Double where

@@ -76,12 +76,12 @@   ) where  import Wumpus.Core.Colour-import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState+import Wumpus.Core.GraphicProps import Wumpus.Core.PictureInternal-import Wumpus.Core.TextEncoder-import Wumpus.Core.Utils+import Wumpus.Core.Text.Encoder+import Wumpus.Core.Utils.Common+import Wumpus.Core.Utils.FormatCombinators   escapeSpecial :: CharCode -> String

@@ -0,0 +1,44 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Text.DefaultEncoder+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- This is the default @TextEncoder@ with lookups for both Latin1+-- character codes / names and Symbol font.+--+--------------------------------------------------------------------------------++module Wumpus.Core.Text.DefaultEncoder+  ( +    defaultEncoder++  ) where++import Wumpus.Core.Text.Encoder+import Wumpus.Core.Text.Latin1+import Wumpus.Core.Text.SymbolFont++import Data.Map+++-- | This is the default encoder supporting names and codes for +-- both Latin1 and the Symbol font.+--+defaultEncoder :: TextEncoder+defaultEncoder = TextEncoder+      { svg_encoding_name       = "ISO-8859-1"+      , font_encoder_map        = fem+      }+  where+    fem = insert symbol_font_encoder symbolFontEncoder +        $ insert latin1_font_encoder latin1FontEncoder+        $ empty ++

@@ -0,0 +1,143 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Text.Encoder+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Extended character code handling.+-- +-- Wumpus uses SVG style escaping to embed character codes or +-- names in regular strings:+--+-- > "regular ascii text &#egrave; more ascii text"+--  +-- i.e. character names and codes are delimited by @&\#@ on the +-- left and @;@ on the right.+--+-- In Wumpus both character names and character codes can+-- be embedded in strings - (e.g. @ &\#egrave; or &\#232; @).+--+-- Character codes can be also be expressed as octal or +-- hexadecimal:+--+-- > myst&#0o350;re+--+-- > myst&#0xE8;re+--+-- In the generated PostScript, Wumpus uses the character name, +-- e.g.:  +--+-- > (myst) show /egrave glyphshow (re) show+-- +-- The generated SVG uses the numeric code, e.g.: +--+-- > mystère+--+-- To accommodate both, Wumpus defines a TextEncoder record which+-- provides a two-way mapping between character codes and glyph +-- names for a character set.+--+--------------------------------------------------------------------------------++module Wumpus.Core.Text.Encoder+  ( +    GlyphName+  , CharCode+  , PostScriptLookup+  , SVGLookup++  , FontEncoderName(..)+  , TextEncoder(..)+  , FontEncoder(..)++  ) where++import Data.Map+import Data.Word++type GlyphName        = String+type CharCode         = Int ++type PostScriptLookup = CharCode -> Maybe GlyphName+type SVGLookup        = GlyphName -> Maybe CharCode++++-- | Font encoder name - a newtype wrapped /number/.+-- +-- Ideally this would be an enumerated type, but it has to be +-- open - new encoders need to be added, so an enum is out of the+-- question.+--+-- A String would be good, but would have slow lookup when used +-- as a key. Dealing with multiple encoders was added late to +-- Wumpus-Core - it is necessary, but taking a performace hit +-- because of it is chagrin. So instead /uniquely/ asssigned+-- numbers are used.+--+-- Numbers below 10000 are reserved for Wumpus, though it is +-- unlikely to need more than a handful. Numbers above are free +-- to use (clearly clashes are possible, but probably unlikely).+-- +-- Wumpus-Core assigns the following, other Wumpus libraries may +-- assign more:+--+-- > 0 - Latin1 (for Helvetica, Times Roman, Courier...)+--+-- > 1 - Symbol Font+-- +newtype FontEncoderName = FontEncoderName { getFontEncoderName :: Word16 }+  deriving (Eq,Ord)++instance Show FontEncoderName where+  show = step . getFontEncoderName+    where+      step 0 = "Latin1"+      step 1 = "Symbol-Font"+      step n = show n++-- | 'TextEncoder'+--+-- An /instance/ needs: +--+-- * A map of FontEncoderNames to FontEncoders.+--+-- * The name of the encoding - this is printed in the xml +-- prologue of the SVG file as the @encoding@ attribute. Latin +-- 1\'s official name is seemingly \"ISO-8859-1\". +-- +-- * The name of the default encoder - this should naturally be +-- in the Font Encoder map.+-- +-- +data TextEncoder = TextEncoder+      { svg_encoding_name       :: String+      , font_encoder_map        :: Map FontEncoderName FontEncoder+      }++-- | 'FontEncoder'.+--+-- * The functions for looking up codes by glyph-name and +-- glyph-name by code. +-- +-- * Fallback glyph-names and char codes in case lookup fails.+-- +-- "Wumpus.Core.TextLatin1" defines an implementation for Latin 1.+--+data FontEncoder = FontEncoder  +      { ps_lookup           :: PostScriptLookup+      , svg_lookup          :: SVGLookup+      , ps_fallback         :: GlyphName+      , svg_fallback        :: CharCode+      }+                     ++-- no show instance as a TextEncoder contains functions.++

@@ -0,0 +1,257 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Text.Latin1+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- A @TextEncoder@ record instance for Latin1 characters.+-- +--------------------------------------------------------------------------------++module Wumpus.Core.Text.Latin1+  ( +  +    latin1_font_encoder+  , latin1FontEncoder+  , latin1FontAll++  ) where++import Wumpus.Core.Text.Encoder++import qualified Data.Map as Map+++-- | Latin1 Font Encoder name +--  +-- (Number 0) +--+latin1_font_encoder :: FontEncoderName+latin1_font_encoder = FontEncoderName 0++-- | Latin1 FontEncoder instance.+latin1FontEncoder :: FontEncoder+latin1FontEncoder = FontEncoder +    { ps_lookup         = Map.lookup `flip` codeToName+    , svg_lookup        = Map.lookup `flip` nameToCode+    , ps_fallback       = "space"+    , svg_fallback      = 0o040+    }++nameToCode :: Map.Map GlyphName CharCode+nameToCode = Map.fromList latin1FontAll++codeToName :: Map.Map CharCode GlyphName+codeToName = foldr fn Map.empty latin1FontAll where+  fn (s,i) a = Map.insert i s a ++-- | A lookup list of Latin 1 names to their octal code.+latin1FontAll :: [(GlyphName, CharCode)]+latin1FontAll = +    [ ("A",                     0o101)+    , ("AE",                    0o306)+    , ("Aacute",                0o301)+    , ("Acircumflex",           0o302)+    , ("Adieresis",             0o304)+    , ("Agrave",                0o300)+    , ("Aring",                 0o305)+    , ("Atilde",                0o303)+    , ("B",                     0o102)+    , ("C",                     0o103)+    , ("Ccedilla",              0o307)+    , ("D",                     0o104)+    , ("E",                     0o105)+    , ("Eacute",                0o311)+    , ("Ecircumflex",           0o312)+    , ("Edieresis",             0o313)+    , ("Egrave",                0o310)+    , ("Eth",                   0o320)+    , ("F",                     0o106)+    , ("G",                     0o107)+    , ("H",                     0o110)+    , ("I",                     0o111)+    , ("Iacute",                0o315)+    , ("Icircumflex",           0o316)+    , ("Idieresis",             0o317)+    , ("Igrave",                0o314)+    , ("J",                     0o112)+    , ("K",                     0o113)+    , ("L",                     0o114)+    , ("M",                     0o115)+    , ("N",                     0o116)+    , ("Ntilde",                0o321)+    , ("O",                     0o117)+    , ("Oacute",                0o323)+    , ("Ocircumflex",           0o324)+    , ("Odieresis",             0o326)+    , ("Ograve",                0o322)+    , ("Oslash",                0o351)+    , ("Otilde",                0o325)+    , ("P",                     0o120)+    , ("Q",                     0o121)+    , ("R",                     0o122)+    , ("S",                     0o123)+    , ("T",                     0o124)+    , ("Thorn",                 0o336)+    , ("U",                     0o125)+    , ("Uacute",                0o332)+    , ("Ucircumflex",           0o333)+    , ("Udieresis",             0o334)+    , ("Ugrave",                0o331)+    , ("V",                     0o126)+    , ("W",                     0o127)+    , ("X",                     0o130)+    , ("Y",                     0o131)+    , ("Yacute",                0o335)+    , ("Z",                     0o132)+    , ("a",                     0o141)+    , ("aacute",                0o341)+    , ("acircumflex",           0o342)+    , ("acute2",                0o264)+    , ("adieresis",             0o344)+    , ("ae",                    0o346)+    , ("agrave",                0o340)+    , ("ampersand",             0o046)+    , ("aring",                 0o345)+    , ("asciicircum",           0o136)+    , ("asciitilde",            0o176)+    , ("asterisk",              0o052)+    , ("at",                    0o100)+    , ("atilde",                0o343)+    , ("b",                     0o142)+    , ("backslash",             0o134)+    , ("bar",                   0o174)+    , ("braceleft",             0o173)+    , ("braceright",            0o175)+    , ("bracketleft",           0o133)+    , ("bracketright",          0o135)+    , ("breve",                 0o226)+    , ("brokenbar",             0o246)+    , ("c",                     0o143)+    , ("caron",                 0o237)+    , ("ccedilla",              0o347)+    , ("cedilla",               0o270)+    , ("cent",                  0o242)+    , ("circumflex",            0o223)+    , ("colon",                 0o072)+    , ("comma",                 0o054)+    , ("copyright",             0o251)+    , ("currency",              0o244)+    , ("d",                     0o144)+    , ("degree",                0o260)+    , ("dieresis",              0o250)+    , ("divide",                0o367)+    , ("dollar",                0o044)+    , ("dotaccent",             0o227)+    , ("dotlessi",              0o220)+    , ("e",                     0o145)+    , ("eacute",                0o351)+    , ("ecircumflex",           0o352)+    , ("edieresis",             0o353)+    , ("egrave",                0o350)+    , ("eight",                 0o070)+    , ("equal",                 0o075)+    , ("eth",                   0o360)+    , ("exclam",                0o041)+    , ("exclamdown",            0o241)+    , ("f",                     0o146)+    , ("five",                  0o065)+    , ("four",                  0o064)+    , ("g",                     0o147)+    , ("germandbls",            0o337)+    , ("grave",                 0o221)+    , ("greater",               0o076)+    , ("guillemotleft",         0o253)+    , ("guillemotright",        0o273)+    , ("h",                     0o150)+    , ("hungarumlaut",          0o235)+    , ("hyphen",                0o255)+    , ("i",                     0o151)+    , ("iacute",                0o355)+    , ("icircumflex",           0o356)+    , ("idieresis",             0o357)+    , ("igrave",                0o354)+    , ("j",                     0o152)+    , ("k",                     0o153)+    , ("l",                     0o154)+    , ("less",                  0o074)+    , ("logicalnot",            0o254)+    , ("m",                     0o155)+    , ("macron",                0o257)+    , ("minus",                 0o055)+    , ("mu",                    0o265)+    , ("multiply",              0o327)+    , ("n",                     0o156)+    , ("nine",                  0o071)+    , ("ntilde",                0o361)+    , ("numbersign",            0o043)+    , ("o",                     0o157)+    , ("oacute",                0o363)+    , ("ocircumflex",           0o364)+    , ("odieresis",             0o366)+    , ("ogonek",                0o236)+    , ("ograve",                0o362)+    , ("one",                   0o061)+    , ("onehalf",               0o275)+    , ("onequarter",            0o274)+    , ("onesuperior",           0o271)+    , ("ordfeminine",           0o252)+    , ("ordmasculine",          0o272)+    , ("oslash",                0o370)+    , ("otilde",                0o365)+    , ("p",                     0o160)+    , ("paragraph",             0o266)+    , ("parenleft",             0o050)+    , ("parenright",            0o051)+    , ("percent",               0o045)+    , ("period",                0o056)+    , ("periodcentered",        0o267)+    , ("plus",                  0o053)+    , ("plusminus",             0o261)+    , ("q",                     0o161)+    , ("question",              0o077)+    , ("questiondown",          0o277)+    , ("quotedbl",              0o042)+    , ("quoteleft",             0o140)+    , ("quoteright",            0o047)+    , ("r",                     0o162)+    , ("registered",            0o256)+    , ("ring",                  0o232)+    , ("s",                     0o163)+    , ("section",               0o247)+    , ("semicolon",             0o073)+    , ("seven",                 0o067)+    , ("six",                   0o066)+    , ("slash",                 0o057)+    , ("space",                 0o040)+    , ("sterling",              0o243)+    , ("t",                     0o164)+    , ("thorn",                 0o376)+    , ("three",                 0o063)+    , ("threequarters",         0o276)+    , ("threesuperior",         0o263)+    , ("tilde",                 0o224)+    , ("two",                   0o062)+    , ("twosuperior",           0o262)+    , ("u",                     0o165)+    , ("uacute",                0o372)+    , ("ucircumflex",           0o373)+    , ("udieresis",             0o374)+    , ("ugrave",                0o371)+    , ("underscore",            0o137)+    , ("v",                     0o166)+    , ("w",                     0o167)+    , ("x",                     0o170)+    , ("y",                     0o171)+    , ("yacute",                0o375)+    , ("ydieresis",             0o377)+    , ("yen",                   0o245)+    , ("z",                     0o172)+    , ("zero",                  0o060)+    ]

@@ -0,0 +1,249 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Text.SymbolFont+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- A @TextEncoder@ record instance for Symbol font characters.+-- +--------------------------------------------------------------------------------++module Wumpus.Core.Text.SymbolFont+  ( +  +    symbol_font_encoder+  , symbolFontEncoder+  , symbolFontAll++  ) where++import Wumpus.Core.Text.Encoder++import qualified Data.Map as Map++++-- | Symbol Font Encoder name +--+-- (Number 1)+-- +symbol_font_encoder :: FontEncoderName+symbol_font_encoder = FontEncoderName 1++++-- | Latin1 TextEncoder instance.+symbolFontEncoder :: FontEncoder+symbolFontEncoder = FontEncoder +    { ps_lookup         = Map.lookup `flip` codeToName+    , svg_lookup        = Map.lookup `flip` nameToCode+    , ps_fallback       = "space"+    , svg_fallback      = 0o040+    }++nameToCode :: Map.Map GlyphName CharCode+nameToCode = Map.fromList symbolFontAll++codeToName :: Map.Map CharCode GlyphName+codeToName = foldr fn Map.empty symbolFontAll where+  fn (s,i) a = Map.insert i s a ++-- | A lookup list of Latin 1 names to their octal code.+symbolFontAll :: [(GlyphName, CharCode)]+symbolFontAll = +    [ ("Alpha",                 0o101)+    , ("Beta",                  0o102)+    , ("Chi",                   0o103)+    , ("Delta",                 0o104)+    , ("Epsilon",               0o105)+    , ("Eta",                   0o110)+    , ("Euro",                  0o240)+    , ("Gamma",                 0o107)+    , ("Ifraktur",              0o301)+    , ("Iota",                  0o111)+    , ("Kappa",                 0o113)+    , ("Lambda",                0o114)+    , ("Mu",                    0o115)+    , ("Nu",                    0o116)+    , ("Omega",                 0o127)+    , ("Omicron",               0o117)+    , ("Phi",                   0o106)+    , ("Pi",                    0o120)+    , ("Psi",                   0o131)+    , ("Rfraktur",              0o302)+    , ("Rho",                   0o122)+    , ("Sigma",                 0o123)+    , ("Tau",                   0o124)+    , ("Theta",                 0o121)+    , ("Upsilon",               0o125)+    , ("Upsilon1",              0o241)+    , ("Xi",                    0o130)+    , ("Zeta",                  0o132)+    , ("aleph",                 0o300)+    , ("alpha",                 0o141)+    , ("ampersand",             0o046)+    , ("angle",                 0o320)+    , ("angleleft",             0o341)+    , ("angleright",            0o361)+    , ("approxequal",           0o273)+    , ("arrowboth",             0o253)+    , ("arrowdblboth",          0o333)+    , ("arrowdbldown",          0o337)+    , ("arrowdblleft",          0o334)+    , ("arrowdblright",         0o336)+    , ("arrowdblup",            0o335)+    , ("arrowdown",             0o257)+    , ("arrowhorizex",          0o276)+    , ("arrowleft",             0o254)+    , ("arrowright",            0o256)+    , ("arrowup",               0o255)+    , ("arrowvertex",           0o275)+    , ("asteriskmath",          0o052)+    , ("bar",                   0o174)+    , ("beta",                  0o142)+    , ("braceleft",             0o173)+    , ("braceright",            0o175)+    , ("bracelefttp",           0o354)+    , ("braceleftmid",          0o355)+    , ("braceleftbt",           0o356)+    , ("bracerighttp",          0o374)+    , ("bracerightmid",         0o375)+    , ("bracerightbt",          0o376)+    , ("braceex",               0o357)+    , ("bracketleft",           0o133)+    , ("bracketright",          0o135)+    , ("bracketlefttp",         0o351)+    , ("bracketleftex",         0o352)+    , ("bracketleftbt",         0o353)+    , ("bracketrighttp",        0o371)+    , ("bracketrightex",        0o372)+    , ("bracketrightbt",        0o373)+    , ("bullet",                0o267)+    , ("carriagereturn",        0o277)+    , ("chi",                   0o143)+    , ("circlemultiply",        0o304)+    , ("circleplus",            0o305)+    , ("club",                  0o247)+    , ("colon",                 0o072)+    , ("comma",                 0o054)+    , ("congruent",             0o100)+    , ("copyrightsans",         0o343)+    , ("copyrightserif",        0o323)+    , ("degree",                0o260)+    , ("delta",                 0o144)+    , ("diamond",               0o250)+    , ("divide",                0o270)+    , ("dotmath",               0o327)+    , ("eight",                 0o070)+    , ("element",               0o316)+    , ("ellipsis",              0o274)+    , ("emptyset",              0o306)+    , ("epsilon",               0o145)+    , ("equal",                 0o075)+    , ("equivalence",           0o272)+    , ("eta",                   0o150)+    , ("exclam",                0o041)+    , ("existential",           0o044)+    , ("five",                  0o065)+    , ("florin",                0o246)+    , ("four",                  0o064)+    , ("fraction",              0o244)+    , ("gamma",                 0o147)+    , ("gradient",              0o321)+    , ("greater",               0o076)+    , ("greaterequal",          0o263)+    , ("heart",                 0o251)+    , ("infinity",              0o245)+    , ("integral",              0o362)+    , ("integraltp",            0o363)+    , ("integralex",            0o364)+    , ("integralbt",            0o365)+    , ("intersection",          0o307)+    , ("iota",                  0o151)+    , ("kappa",                 0o153)+    , ("lambda",                0o154)+    , ("less",                  0o074)+    , ("lessequal",             0o243)+    , ("logicaland",            0o331)+    , ("logicalnot",            0o330)+    , ("logicalor",             0o332)+    , ("lozenge",               0o340)+    , ("minus",                 0o055)+    , ("minute",                0o242)+    , ("mu",                    0o155)+    , ("multiply",              0o264)+    , ("nine",                  0o071)+    , ("notelement",            0o317)+    , ("notequal",              0o271)+    , ("notsubset",             0o313)+    , ("nu",                    0o156)+    , ("numbersign",            0o043)+    , ("omega",                 0o167)+    , ("omega1",                0o166)+    , ("omicron",               0o157)+    , ("one",                   0o061)+    , ("parenleft",             0o050)+    , ("parenright",            0o051)+    , ("parenlefttp",           0o346)+    , ("parenleftex",           0o347)+    , ("parenleftbt",           0o350)+    , ("parenrighttp",          0o366)+    , ("parenrightex",          0o367)+    , ("parenrightbt",          0o370)+    , ("partialdiff",           0o266)+    , ("percent",               0o045)+    , ("period",                0o056)+    , ("perpendicular",         0o136)+    , ("phi",                   0o146)+    , ("phi1",                  0o152)+    , ("pi",                    0o160)+    , ("plus",                  0o053)+    , ("plusminus",             0o261)+    , ("product",               0o325)+    , ("propersubset",          0o314)+    , ("propersuperset",        0o311)+    , ("proportional",          0o265)+    , ("psi",                   0o171)+    , ("question",              0o077)+    , ("radical",               0o326)+    , ("radicalex",             0o140)+    , ("reflexsubset",          0o315)+    , ("reflexsuperset",        0o312)+    , ("registersans",          0o342)+    , ("registerserif",         0o322)+    , ("rho",                   0o162)+    , ("second",                0o262)+    , ("semicolon",             0o073)+    , ("seven",                 0o067)+    , ("sigma",                 0o163)+    , ("sigma1",                0o126)+    , ("similar",               0o176)+    , ("six",                   0o066)+    , ("slash",                 0o057)+    , ("space",                 0o040)+    , ("spade",                 0o252)+    , ("suchthat",              0o047)+    , ("summation",             0o345)+    , ("tau",                   0o164)+    , ("therefore",             0o134)+    , ("theta",                 0o161)+    , ("theta1",                0o112)+    , ("three",                 0o063)+    , ("trademarksans",         0o344)+    , ("trademarkserif",        0o324)+    , ("two",                   0o062)+    , ("underscore",            0o137)+    , ("union",                 0o310)+    , ("universal",             0o042)+    , ("upsilon",               0o165)+    , ("weierstrass",           0o303)+    , ("xi",                    0o170)+    , ("zero",                  0o060)+    , ("zeta",                  0o172)+    ]

@@ -0,0 +1,173 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Text.TextInternal+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Extended character handling.+-- +--------------------------------------------------------------------------------++module Wumpus.Core.Text.TextInternal+  ( ++    EncodedText(..)    +  , TextChunk(..)+  , EncodedChar(..)++  , textLength+  , lookupByCharCode  +  , lookupByGlyphName+  , getSvgFallback+  , getPsFallback+  +  , lexLabel++  ) where++import Wumpus.Core.Text.Encoder+import Wumpus.Core.Utils.FormatCombinators++import Data.Char+import qualified Data.Map as Map++newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] }+  deriving (Eq,Show)++-- | Wumpus supports both escaped names e.g. @egrave@ and escaped+-- (numeric decimal) character codes in the input string for a +-- TextLabel.+-- +data TextChunk = TextSpan    String+               | TextEscInt  Int+               | TextEscName GlyphName+  deriving (Eq,Show)++-- | For KernLabels Wumpus needs a Char version of TextChunk.+--+data EncodedChar = CharLiteral Char+                 | CharEscInt  Int+                 | CharEscName GlyphName+  deriving (Eq,Show)+++--------------------------------------------------------------------------------++instance Format EncodedText where+  format = hcat . map format . getEncodedText++instance Format TextChunk where+  format (TextSpan s)    = text s+  format (TextEscInt i)  = text "&#" <> int i  <> semicolon+  format (TextEscName s) = text "&#" <> text s <> semicolon++instance Format EncodedChar where+  format (CharLiteral c) = char c+  format (CharEscInt i)  = text "&#" <> int i  <> semicolon+  format (CharEscName s) = text "&#" <> text s <> semicolon+++--------------------------------------------------------------------------------+++textLength :: EncodedText -> Int+textLength = foldr add 0 . getEncodedText where +    add (TextSpan s) n = n + length s+    add _            n = n + 1+++lookupByCharCode :: FontEncoderName -> CharCode -> TextEncoder -> Maybe GlyphName+lookupByCharCode name i enc = +    Map.lookup name (font_encoder_map enc) >>= \a -> (ps_lookup a) i++lookupByGlyphName :: FontEncoderName -> GlyphName -> TextEncoder -> Maybe CharCode+lookupByGlyphName name i enc = +    Map.lookup name (font_encoder_map enc) >>= \a -> (svg_lookup a) i+++getSvgFallback :: FontEncoderName -> TextEncoder -> CharCode+getSvgFallback name enc = case Map.lookup name (font_encoder_map enc) of+   Just fe -> svg_fallback fe +   Nothing -> 0o040                     -- wild guess++getPsFallback :: FontEncoderName -> TextEncoder -> GlyphName+getPsFallback name enc = case Map.lookup name (font_encoder_map enc) of+   Just fe -> ps_fallback fe +   Nothing -> "space"                    -- wild guess+++-- | 'lexLabel' input is regular text and escaped glyph names or+-- decimal character codes. Escaping follows the SVG convention,+-- start with @&#@ (ampersand hash) end with @;@ (semicolon).+--+-- Special chars are output to PostScript as:+--+-- > /egrave glyphshow+--+-- Special chars are output to SVG as an escaped decimal, e.g.:+--+-- > &#232;+--+-- Note, HTML entity names do not seem to be supported in SVG,+-- @ &egrave; @ does not work in FireFox or Chrome.+--+lexLabel :: String -> EncodedText+lexLabel = EncodedText . lexer++-- Note - the lexer reads number spans with isDigit, so reads +-- decimals only.+-- +lexer :: String -> [TextChunk]+lexer []            = []+lexer ('&':'#':cs)  = escStart cs+lexer (c:cs)        = let (ss,rest) = span (/= '&') cs +                      in TextSpan (c:ss) : lexer rest++escStart :: String -> [TextChunk]+escStart ('0':'o':cs)           = escOct cs+escStart ('0':'O':cs)           = escOct cs+escStart ('0':'x':cs)           = escHex cs+escStart ('0':'X':cs)           = escHex cs+escStart (c:cs) | isDigit c     = escDec (digitToInt c) cs+escStart (c:cs)                 = let (ss,rest) = span isAlphaNum cs +                                  in TextEscName (c:ss) : chompToSemi rest+escStart []                     = [] ++-- | One digit consumed already...+--+escDec :: Int -> String -> [TextChunk]+escDec n (c:cs) | isDigit c = escDec (n*10 + digitToInt c) cs+escDec n cs     | n > 0     = TextEscInt n : chompToSemi cs+                | otherwise = chompToSemi cs++escHex :: String -> [TextChunk]+escHex = step 0+  where+    step n (c:cs) | isHexDigit c = step (n*16 + digitToInt c) cs+    step n cs     | n > 0        = TextEscInt n : chompToSemi cs+                  | otherwise    = chompToSemi cs +++escOct :: String -> [TextChunk]+escOct = step 0+  where+    step n (c:cs) | isHexDigit c = step (n*8 + digitToInt c) cs+    step n cs     | n > 0        = TextEscInt n : chompToSemi cs+                  | otherwise    = chompToSemi cs ++++-- The last two conditions both indicate ill-formed input, but it+-- is /best/ if the lexer does not throw errors.+-- +chompToSemi :: String -> [TextChunk]+chompToSemi (';':cs) = lexer cs+chompToSemi (_:cs)   = chompToSemi cs           +chompToSemi []       = []+

@@ -1,44 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.TextDefaultEncoder--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ This is the default Text encoder with lookups for both Latin1--- and Symbol font.--------------------------------------------------------------------------------------module Wumpus.Core.TextDefaultEncoder-  ( -    defaultEncoder--  ) where--import Wumpus.Core.TextEncoder-import Wumpus.Core.TextLatin1-import Wumpus.Core.TextSymbolFont--import Data.Map----- | This is the default encoder supporting names and codes for --- both Latin1 and the Symbol font.----defaultEncoder :: TextEncoder-defaultEncoder = TextEncoder-      { svg_encoding_name       = "ISO-8859-1"-      , font_encoder_map        = fem-      }-  where-    fem = insert symbol_font_encoder symbolFontEncoder -        $ insert latin1_font_encoder latin1FontEncoder-        $ empty --

@@ -1,143 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.TextEncoder--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Extended character code handling.--- --- Wumpus uses SVG style escaping to embed character codes or --- names in regular strings:------ > "regular ascii text &#egrave; more ascii text"---  --- i.e. character names and codes are delimited by @&\#@ on the --- left and @;@ on the right.------ In Wumpus both character names and character codes can--- be embedded in strings - (e.g. @ &\#egrave; or &\#232; @).------ Character codes can be also be expressed as octal or --- hexadecimal:------ > myst&#0o350;re------ > myst&#0xE8;re------ In the generated PostScript, Wumpus uses the character name, --- e.g.:  ------ > (myst) show /egrave glyphshow (re) show--- --- The generated SVG uses the numeric code, e.g.: ------ > mystère------ To accommodate both, Wumpus defines a TextEncoder record which--- provides a two-way mapping between character codes and glyph --- names for a character set.--------------------------------------------------------------------------------------module Wumpus.Core.TextEncoder-  ( -    GlyphName-  , CharCode-  , PostScriptLookup-  , SVGLookup--  , FontEncoderName(..)-  , TextEncoder(..)-  , FontEncoder(..)--  ) where--import Data.Map-import Data.Word--type GlyphName        = String-type CharCode         = Int --type PostScriptLookup = CharCode -> Maybe GlyphName-type SVGLookup        = GlyphName -> Maybe CharCode------ | Font encoder name - a newtype wrapped /number/.--- --- Ideally this would be an enumerated type, but it has to be --- open - new encoders need to be added, so an enum is out of the--- question.------ A String would be good, but would have slow lookup when used --- as a key. Dealing with multiple encoders was added late to --- Wumpus-Core - it is necessary, but taking a performace hit --- because of it is chagrin. So instead /uniquely/ asssigned--- numbers are used.------ Numbers below 10000 are reserved for Wumpus, though it is --- unlikely to need more than a handful. Numbers above are free --- to use (clearly clashes are possible, but probably unlikely).--- --- Wumpus-Core assigns the following, other Wumpus libraries may --- assign more:------ > 0 - Latin1 (for Helvetica, Times Roman, Courier...)------ > 1 - Symbol Font--- -newtype FontEncoderName = FontEncoderName { getFontEncoderName :: Word16 }-  deriving (Eq,Ord)--instance Show FontEncoderName where-  show = step . getFontEncoderName-    where-      step 0 = "Latin1"-      step 1 = "Symbol-Font"-      step n = show n---- | 'TextEncoder'------ An /instance/ needs: ------ * A map of FontEncoderNames to FontEncoders.------ * The name of the encoding - this is printed in the xml --- prologue of the SVG file as the @encoding@ attribute. Latin --- 1\'s official name is seemingly \"ISO-8859-1\". --- --- * The name of the default encoder - this should naturally be --- in the Font Encoder map.--- --- -data TextEncoder = TextEncoder-      { svg_encoding_name       :: String-      , font_encoder_map        :: Map FontEncoderName FontEncoder-      }---- | 'FontEncoder'.------ * The functions for looking up codes by glyph-name and --- glyph-name by code. --- --- * Fallback glyph-names and char codes in case lookup fails.--- --- "Wumpus.Core.TextLatin1" defines an implementation for Latin 1.----data FontEncoder = FontEncoder  -      { ps_lookup           :: PostScriptLookup-      , svg_lookup          :: SVGLookup-      , ps_fallback         :: GlyphName-      , svg_fallback        :: CharCode-      }-                     ---- no show instance as a TextEncoder contains functions.--

@@ -1,173 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.TextInternal--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Extended character handling.--- -----------------------------------------------------------------------------------module Wumpus.Core.TextInternal-  ( --    EncodedText(..)    -  , TextChunk(..)-  , EncodedChar(..)--  , textLength-  , lookupByCharCode  -  , lookupByGlyphName-  , getSvgFallback-  , getPsFallback-  -  , lexLabel--  ) where--import Wumpus.Core.FormatCombinators-import Wumpus.Core.TextEncoder--import Data.Char-import qualified Data.Map as Map--newtype EncodedText = EncodedText { getEncodedText :: [TextChunk] }-  deriving (Eq,Show)---- | Wumpus supports both escaped names e.g. @egrave@ and escaped--- (numeric decimal) character codes in the input string for a --- TextLabel.--- -data TextChunk = TextSpan    String-               | TextEscInt  Int-               | TextEscName GlyphName-  deriving (Eq,Show)---- | For KernLabels Wumpus needs a Char version of TextChunk.----data EncodedChar = CharLiteral Char-                 | CharEscInt  Int-                 | CharEscName GlyphName-  deriving (Eq,Show)-------------------------------------------------------------------------------------instance Format EncodedText where-  format = hcat . map format . getEncodedText--instance Format TextChunk where-  format (TextSpan s)    = text s-  format (TextEscInt i)  = text "&#" <> int i  <> semicolon-  format (TextEscName s) = text "&#" <> text s <> semicolon--instance Format EncodedChar where-  format (CharLiteral c) = char c-  format (CharEscInt i)  = text "&#" <> int i  <> semicolon-  format (CharEscName s) = text "&#" <> text s <> semicolon--------------------------------------------------------------------------------------textLength :: EncodedText -> Int-textLength = foldr add 0 . getEncodedText where -    add (TextSpan s) n = n + length s-    add _            n = n + 1---lookupByCharCode :: FontEncoderName -> CharCode -> TextEncoder -> Maybe GlyphName-lookupByCharCode name i enc = -    Map.lookup name (font_encoder_map enc) >>= \a -> (ps_lookup a) i--lookupByGlyphName :: FontEncoderName -> GlyphName -> TextEncoder -> Maybe CharCode-lookupByGlyphName name i enc = -    Map.lookup name (font_encoder_map enc) >>= \a -> (svg_lookup a) i---getSvgFallback :: FontEncoderName -> TextEncoder -> CharCode-getSvgFallback name enc = case Map.lookup name (font_encoder_map enc) of-   Just fe -> svg_fallback fe -   Nothing -> 0o040                     -- wild guess--getPsFallback :: FontEncoderName -> TextEncoder -> GlyphName-getPsFallback name enc = case Map.lookup name (font_encoder_map enc) of-   Just fe -> ps_fallback fe -   Nothing -> "space"                    -- wild guess----- | 'lexLabel' input is regular text and escaped glyph names or--- decimal character codes. Escaping follows the SVG convention,--- start with @&#@ (ampersand hash) end with @;@ (semicolon).------ Special chars are output to PostScript as:------ > /egrave glyphshow------ Special chars are output to SVG as an escaped decimal, e.g.:------ > &#232;------ Note, HTML entity names do not seem to be supported in SVG,--- @ &egrave; @ does not work in FireFox or Chrome.----lexLabel :: String -> EncodedText-lexLabel = EncodedText . lexer---- Note - the lexer reads number spans with isDigit, so reads --- decimals only.--- -lexer :: String -> [TextChunk]-lexer []            = []-lexer ('&':'#':cs)  = escStart cs-lexer (c:cs)        = let (ss,rest) = span (/= '&') cs -                      in TextSpan (c:ss) : lexer rest--escStart :: String -> [TextChunk]-escStart ('0':'o':cs)           = escOct cs-escStart ('0':'O':cs)           = escOct cs-escStart ('0':'x':cs)           = escHex cs-escStart ('0':'X':cs)           = escHex cs-escStart (c:cs) | isDigit c     = escDec (digitToInt c) cs-escStart (c:cs)                 = let (ss,rest) = span isAlphaNum cs -                                  in TextEscName (c:ss) : chompToSemi rest-escStart []                     = [] ---- | One digit consumed already...----escDec :: Int -> String -> [TextChunk]-escDec n (c:cs) | isDigit c = escDec (n*10 + digitToInt c) cs-escDec n cs     | n > 0     = TextEscInt n : chompToSemi cs-                | otherwise = chompToSemi cs--escHex :: String -> [TextChunk]-escHex = step 0-  where-    step n (c:cs) | isHexDigit c = step (n*16 + digitToInt c) cs-    step n cs     | n > 0        = TextEscInt n : chompToSemi cs-                  | otherwise    = chompToSemi cs ---escOct :: String -> [TextChunk]-escOct = step 0-  where-    step n (c:cs) | isHexDigit c = step (n*8 + digitToInt c) cs-    step n cs     | n > 0        = TextEscInt n : chompToSemi cs-                  | otherwise    = chompToSemi cs ------ The last two conditions both indicate ill-formed input, but it--- is /best/ if the lexer does not throw errors.--- -chompToSemi :: String -> [TextChunk]-chompToSemi (';':cs) = lexer cs-chompToSemi (_:cs)   = chompToSemi cs           -chompToSemi []       = []-

@@ -1,257 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.TextLatin1--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ A TextEncoder record instance for Latin1 characters.--- -----------------------------------------------------------------------------------module Wumpus.Core.TextLatin1-  ( -  -    latin1_font_encoder-  , latin1FontEncoder-  , latin1FontAll--  ) where--import Wumpus.Core.TextEncoder--import qualified Data.Map as Map----- | Latin1 Font Encoder name ---  --- (Number 0) ----latin1_font_encoder :: FontEncoderName-latin1_font_encoder = FontEncoderName 0---- | Latin1 FontEncoder instance.-latin1FontEncoder :: FontEncoder-latin1FontEncoder = FontEncoder -    { ps_lookup         = Map.lookup `flip` codeToName-    , svg_lookup        = Map.lookup `flip` nameToCode-    , ps_fallback       = "space"-    , svg_fallback      = 0o040-    }--nameToCode :: Map.Map GlyphName CharCode-nameToCode = Map.fromList latin1FontAll--codeToName :: Map.Map CharCode GlyphName-codeToName = foldr fn Map.empty latin1FontAll where-  fn (s,i) a = Map.insert i s a ---- | A lookup list of Latin 1 names to their octal code.-latin1FontAll :: [(GlyphName, CharCode)]-latin1FontAll = -    [ ("A",                     0o101)-    , ("AE",                    0o306)-    , ("Aacute",                0o301)-    , ("Acircumflex",           0o302)-    , ("Adieresis",             0o304)-    , ("Agrave",                0o300)-    , ("Aring",                 0o305)-    , ("Atilde",                0o303)-    , ("B",                     0o102)-    , ("C",                     0o103)-    , ("Ccedilla",              0o307)-    , ("D",                     0o104)-    , ("E",                     0o105)-    , ("Eacute",                0o311)-    , ("Ecircumflex",           0o312)-    , ("Edieresis",             0o313)-    , ("Egrave",                0o310)-    , ("Eth",                   0o320)-    , ("F",                     0o106)-    , ("G",                     0o107)-    , ("H",                     0o110)-    , ("I",                     0o111)-    , ("Iacute",                0o315)-    , ("Icircumflex",           0o316)-    , ("Idieresis",             0o317)-    , ("Igrave",                0o314)-    , ("J",                     0o112)-    , ("K",                     0o113)-    , ("L",                     0o114)-    , ("M",                     0o115)-    , ("N",                     0o116)-    , ("Ntilde",                0o321)-    , ("O",                     0o117)-    , ("Oacute",                0o323)-    , ("Ocircumflex",           0o324)-    , ("Odieresis",             0o326)-    , ("Ograve",                0o322)-    , ("Oslash",                0o351)-    , ("Otilde",                0o325)-    , ("P",                     0o120)-    , ("Q",                     0o121)-    , ("R",                     0o122)-    , ("S",                     0o123)-    , ("T",                     0o124)-    , ("Thorn",                 0o336)-    , ("U",                     0o125)-    , ("Uacute",                0o332)-    , ("Ucircumflex",           0o333)-    , ("Udieresis",             0o334)-    , ("Ugrave",                0o331)-    , ("V",                     0o126)-    , ("W",                     0o127)-    , ("X",                     0o130)-    , ("Y",                     0o131)-    , ("Yacute",                0o335)-    , ("Z",                     0o132)-    , ("a",                     0o141)-    , ("aacute",                0o341)-    , ("acircumflex",           0o342)-    , ("acute2",                0o264)-    , ("adieresis",             0o344)-    , ("ae",                    0o346)-    , ("agrave",                0o340)-    , ("ampersand",             0o046)-    , ("aring",                 0o345)-    , ("asciicircum",           0o136)-    , ("asciitilde",            0o176)-    , ("asterisk",              0o052)-    , ("at",                    0o100)-    , ("atilde",                0o343)-    , ("b",                     0o142)-    , ("backslash",             0o134)-    , ("bar",                   0o174)-    , ("braceleft",             0o173)-    , ("braceright",            0o175)-    , ("bracketleft",           0o133)-    , ("bracketright",          0o135)-    , ("breve",                 0o226)-    , ("brokenbar",             0o246)-    , ("c",                     0o143)-    , ("caron",                 0o237)-    , ("ccedilla",              0o347)-    , ("cedilla",               0o270)-    , ("cent",                  0o242)-    , ("circumflex",            0o223)-    , ("colon",                 0o072)-    , ("comma",                 0o054)-    , ("copyright",             0o251)-    , ("currency",              0o244)-    , ("d",                     0o144)-    , ("degree",                0o260)-    , ("dieresis",              0o250)-    , ("divide",                0o367)-    , ("dollar",                0o044)-    , ("dotaccent",             0o227)-    , ("dotlessi",              0o220)-    , ("e",                     0o145)-    , ("eacute",                0o351)-    , ("ecircumflex",           0o352)-    , ("edieresis",             0o353)-    , ("egrave",                0o350)-    , ("eight",                 0o070)-    , ("equal",                 0o075)-    , ("eth",                   0o360)-    , ("exclam",                0o041)-    , ("exclamdown",            0o241)-    , ("f",                     0o146)-    , ("five",                  0o065)-    , ("four",                  0o064)-    , ("g",                     0o147)-    , ("germandbls",            0o337)-    , ("grave",                 0o221)-    , ("greater",               0o076)-    , ("guillemotleft",         0o253)-    , ("guillemotright",        0o273)-    , ("h",                     0o150)-    , ("hungarumlaut",          0o235)-    , ("hyphen",                0o255)-    , ("i",                     0o151)-    , ("iacute",                0o355)-    , ("icircumflex",           0o356)-    , ("idieresis",             0o357)-    , ("igrave",                0o354)-    , ("j",                     0o152)-    , ("k",                     0o153)-    , ("l",                     0o154)-    , ("less",                  0o074)-    , ("logicalnot",            0o254)-    , ("m",                     0o155)-    , ("macron",                0o257)-    , ("minus",                 0o055)-    , ("mu",                    0o265)-    , ("multiply",              0o327)-    , ("n",                     0o156)-    , ("nine",                  0o071)-    , ("ntilde",                0o361)-    , ("numbersign",            0o043)-    , ("o",                     0o157)-    , ("oacute",                0o363)-    , ("ocircumflex",           0o364)-    , ("odieresis",             0o366)-    , ("ogonek",                0o236)-    , ("ograve",                0o362)-    , ("one",                   0o061)-    , ("onehalf",               0o275)-    , ("onequarter",            0o274)-    , ("onesuperior",           0o271)-    , ("ordfeminine",           0o252)-    , ("ordmasculine",          0o272)-    , ("oslash",                0o370)-    , ("otilde",                0o365)-    , ("p",                     0o160)-    , ("paragraph",             0o266)-    , ("parenleft",             0o050)-    , ("parenright",            0o051)-    , ("percent",               0o045)-    , ("period",                0o056)-    , ("periodcentered",        0o267)-    , ("plus",                  0o053)-    , ("plusminus",             0o261)-    , ("q",                     0o161)-    , ("question",              0o077)-    , ("questiondown",          0o277)-    , ("quotedbl",              0o042)-    , ("quoteleft",             0o140)-    , ("quoteright",            0o047)-    , ("r",                     0o162)-    , ("registered",            0o256)-    , ("ring",                  0o232)-    , ("s",                     0o163)-    , ("section",               0o247)-    , ("semicolon",             0o073)-    , ("seven",                 0o067)-    , ("six",                   0o066)-    , ("slash",                 0o057)-    , ("space",                 0o040)-    , ("sterling",              0o243)-    , ("t",                     0o164)-    , ("thorn",                 0o376)-    , ("three",                 0o063)-    , ("threequarters",         0o276)-    , ("threesuperior",         0o263)-    , ("tilde",                 0o224)-    , ("two",                   0o062)-    , ("twosuperior",           0o262)-    , ("u",                     0o165)-    , ("uacute",                0o372)-    , ("ucircumflex",           0o373)-    , ("udieresis",             0o374)-    , ("ugrave",                0o371)-    , ("underscore",            0o137)-    , ("v",                     0o166)-    , ("w",                     0o167)-    , ("x",                     0o170)-    , ("y",                     0o171)-    , ("yacute",                0o375)-    , ("ydieresis",             0o377)-    , ("yen",                   0o245)-    , ("z",                     0o172)-    , ("zero",                  0o060)-    ]

@@ -1,249 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.TextSymbolFont--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ A TextEncoder record instance for Symbol font characters.--- -----------------------------------------------------------------------------------module Wumpus.Core.TextSymbolFont-  ( -  -    symbol_font_encoder-  , symbolFontEncoder-  , symbolFontAll--  ) where--import Wumpus.Core.TextEncoder--import qualified Data.Map as Map------ | Symbol Font Encoder name ------ (Number 1)--- -symbol_font_encoder :: FontEncoderName-symbol_font_encoder = FontEncoderName 1------ | Latin1 TextEncoder instance.-symbolFontEncoder :: FontEncoder-symbolFontEncoder = FontEncoder -    { ps_lookup         = Map.lookup `flip` codeToName-    , svg_lookup        = Map.lookup `flip` nameToCode-    , ps_fallback       = "space"-    , svg_fallback      = 0o040-    }--nameToCode :: Map.Map GlyphName CharCode-nameToCode = Map.fromList symbolFontAll--codeToName :: Map.Map CharCode GlyphName-codeToName = foldr fn Map.empty symbolFontAll where-  fn (s,i) a = Map.insert i s a ---- | A lookup list of Latin 1 names to their octal code.-symbolFontAll :: [(GlyphName, CharCode)]-symbolFontAll = -    [ ("Alpha",                 0o101)-    , ("Beta",                  0o102)-    , ("Chi",                   0o103)-    , ("Delta",                 0o104)-    , ("Epsilon",               0o105)-    , ("Eta",                   0o110)-    , ("Euro",                  0o240)-    , ("Gamma",                 0o107)-    , ("Ifraktur",              0o301)-    , ("Iota",                  0o111)-    , ("Kappa",                 0o113)-    , ("Lambda",                0o114)-    , ("Mu",                    0o115)-    , ("Nu",                    0o116)-    , ("Omega",                 0o127)-    , ("Omicron",               0o117)-    , ("Phi",                   0o106)-    , ("Pi",                    0o120)-    , ("Psi",                   0o131)-    , ("Rfraktur",              0o302)-    , ("Rho",                   0o122)-    , ("Sigma",                 0o123)-    , ("Tau",                   0o124)-    , ("Theta",                 0o121)-    , ("Upsilon",               0o125)-    , ("Upsilon1",              0o241)-    , ("Xi",                    0o130)-    , ("Zeta",                  0o132)-    , ("aleph",                 0o300)-    , ("alpha",                 0o141)-    , ("ampersand",             0o046)-    , ("angle",                 0o320)-    , ("angleleft",             0o341)-    , ("angleright",            0o361)-    , ("approxequal",           0o273)-    , ("arrowboth",             0o253)-    , ("arrowdblboth",          0o333)-    , ("arrowdbldown",          0o337)-    , ("arrowdblleft",          0o334)-    , ("arrowdblright",         0o336)-    , ("arrowdblup",            0o335)-    , ("arrowdown",             0o257)-    , ("arrowhorizex",          0o276)-    , ("arrowleft",             0o254)-    , ("arrowright",            0o256)-    , ("arrowup",               0o255)-    , ("arrowvertex",           0o275)-    , ("asteriskmath",          0o052)-    , ("bar",                   0o174)-    , ("beta",                  0o142)-    , ("braceleft",             0o173)-    , ("braceright",            0o175)-    , ("bracelefttp",           0o354)-    , ("braceleftmid",          0o355)-    , ("braceleftbt",           0o356)-    , ("bracerighttp",          0o374)-    , ("bracerightmid",         0o375)-    , ("bracerightbt",          0o376)-    , ("braceex",               0o357)-    , ("bracketleft",           0o133)-    , ("bracketright",          0o135)-    , ("bracketlefttp",         0o351)-    , ("bracketleftex",         0o352)-    , ("bracketleftbt",         0o353)-    , ("bracketrighttp",        0o371)-    , ("bracketrightex",        0o372)-    , ("bracketrightbt",        0o373)-    , ("bullet",                0o267)-    , ("carriagereturn",        0o277)-    , ("chi",                   0o143)-    , ("circlemultiply",        0o304)-    , ("circleplus",            0o305)-    , ("club",                  0o247)-    , ("colon",                 0o072)-    , ("comma",                 0o054)-    , ("congruent",             0o100)-    , ("copyrightsans",         0o343)-    , ("copyrightserif",        0o323)-    , ("degree",                0o260)-    , ("delta",                 0o144)-    , ("diamond",               0o250)-    , ("divide",                0o270)-    , ("dotmath",               0o327)-    , ("eight",                 0o070)-    , ("element",               0o316)-    , ("ellipsis",              0o274)-    , ("emptyset",              0o306)-    , ("epsilon",               0o145)-    , ("equal",                 0o075)-    , ("equivalence",           0o272)-    , ("eta",                   0o150)-    , ("exclam",                0o041)-    , ("existential",           0o044)-    , ("five",                  0o065)-    , ("florin",                0o246)-    , ("four",                  0o064)-    , ("fraction",              0o244)-    , ("gamma",                 0o147)-    , ("gradient",              0o321)-    , ("greater",               0o076)-    , ("greaterequal",          0o263)-    , ("heart",                 0o251)-    , ("infinity",              0o245)-    , ("integral",              0o362)-    , ("integraltp",            0o363)-    , ("integralex",            0o364)-    , ("integralbt",            0o365)-    , ("intersection",          0o307)-    , ("iota",                  0o151)-    , ("kappa",                 0o153)-    , ("lambda",                0o154)-    , ("less",                  0o074)-    , ("lessequal",             0o243)-    , ("logicaland",            0o331)-    , ("logicalnot",            0o330)-    , ("logicalor",             0o332)-    , ("lozenge",               0o340)-    , ("minus",                 0o055)-    , ("minute",                0o242)-    , ("mu",                    0o155)-    , ("multiply",              0o264)-    , ("nine",                  0o071)-    , ("notelement",            0o317)-    , ("notequal",              0o271)-    , ("notsubset",             0o313)-    , ("nu",                    0o156)-    , ("numbersign",            0o043)-    , ("omega",                 0o167)-    , ("omega1",                0o166)-    , ("omicron",               0o157)-    , ("one",                   0o061)-    , ("parenleft",             0o050)-    , ("parenright",            0o051)-    , ("parenlefttp",           0o346)-    , ("parenleftex",           0o347)-    , ("parenleftbt",           0o350)-    , ("parenrighttp",          0o366)-    , ("parenrightex",          0o367)-    , ("parenrightbt",          0o370)-    , ("partialdiff",           0o266)-    , ("percent",               0o045)-    , ("period",                0o056)-    , ("perpendicular",         0o136)-    , ("phi",                   0o146)-    , ("phi1",                  0o152)-    , ("pi",                    0o160)-    , ("plus",                  0o053)-    , ("plusminus",             0o261)-    , ("product",               0o325)-    , ("propersubset",          0o314)-    , ("propersuperset",        0o311)-    , ("proportional",          0o265)-    , ("psi",                   0o171)-    , ("question",              0o077)-    , ("radical",               0o326)-    , ("radicalex",             0o140)-    , ("reflexsubset",          0o315)-    , ("reflexsuperset",        0o312)-    , ("registersans",          0o342)-    , ("registerserif",         0o322)-    , ("rho",                   0o162)-    , ("second",                0o262)-    , ("semicolon",             0o073)-    , ("seven",                 0o067)-    , ("sigma",                 0o163)-    , ("sigma1",                0o126)-    , ("similar",               0o176)-    , ("six",                   0o066)-    , ("slash",                 0o057)-    , ("space",                 0o040)-    , ("spade",                 0o252)-    , ("suchthat",              0o047)-    , ("summation",             0o345)-    , ("tau",                   0o164)-    , ("therefore",             0o134)-    , ("theta",                 0o161)-    , ("theta1",                0o112)-    , ("three",                 0o063)-    , ("trademarksans",         0o344)-    , ("trademarkserif",        0o324)-    , ("two",                   0o062)-    , ("underscore",            0o137)-    , ("union",                 0o310)-    , ("universal",             0o042)-    , ("upsilon",               0o165)-    , ("weierstrass",           0o303)-    , ("xi",                    0o170)-    , ("zero",                  0o060)-    , ("zeta",                  0o172)-    ]

@@ -0,0 +1,138 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.TrafoInternal+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  unstable +-- Portability :  GHC+--+-- Transformations on (Path) Primtives in Wumpus-Core are +-- performed on the control points rather than transmitted to +-- PostScript. +-- +-- However because text labels are opaque to Wumpus, the corner+-- start point is manipulated in Wumpus, but transformations on +-- the actual text are communicated to PostScript as matrix +-- transformations. +-- +--------------------------------------------------------------------------------+++module Wumpus.Core.TrafoInternal+  (++  -- * Types+    PrimCTM(..)+  , AffineTrafo(..) ++  -- * CTM operations+  , identityCTM+  , thetaCTM++  , scaleCTM+  , rotateCTM+  , matrixRepCTM+  , translMatrixRepCTM++  -- * AffineTrafo operations+  , concatTrafos+  , matrixRepr+  +  ) where+++import Wumpus.Core.Geometry+import Wumpus.Core.Utils.Common+import Wumpus.Core.Utils.FormatCombinators+++-- Primitives support affine transformations.+--+-- The control points of a path, baseline-left of text or center+-- of ellipse are transformed as points; scaling and rotation +-- or text and ellipses are transmitted to PostScript and SVG.+-- +-- Note - line thickness of a stroked path will not be scaled.+--+data PrimCTM u = PrimCTM +      { ctm_scale_x     :: u+      , ctm_scale_y     :: u+      , ctm_rotation    :: Radian +      }+  deriving (Eq,Show)+++++-- | 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+  deriving (Eq,Show)                 +++++instance PSUnit u => Format (PrimCTM u) where+  format (PrimCTM x y ang) = +      parens (text "CTM" <+> text "sx="   <> dtruncFmt x +                         <+> text "sy="   <> dtruncFmt y +                         <+> text "ang="  <> format ang  )+++++--------------------------------------------------------------------------------+-- Manipulating the PrimCTM++identityCTM :: Num u => PrimCTM u+identityCTM = PrimCTM { ctm_scale_x = 1, ctm_scale_y = 1, ctm_rotation = 0 }++thetaCTM :: Num u => Radian -> PrimCTM u+thetaCTM ang = PrimCTM { ctm_scale_x = 1, ctm_scale_y = 1, ctm_rotation = ang }++scaleCTM :: Num u => u -> u -> PrimCTM u -> PrimCTM u+scaleCTM x1 y1 (PrimCTM sx sy ang) = PrimCTM (x1*sx) (y1*sy) ang++rotateCTM :: Radian -> PrimCTM u -> PrimCTM u+rotateCTM ang1 (PrimCTM sx sy ang) = PrimCTM sx sy (circularModulo $ ang1+ang)++matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u+matrixRepCTM (PrimCTM sx sy ang) = +    rotationMatrix (circularModulo ang) * scalingMatrix sx sy+++-- Note - the order of combining a translation (i.e. the location +-- of a point) and the CTM is crucial as matrix multiplication is +-- not commutative.+--+-- This function encapsulates the correct order.+--+translMatrixRepCTM :: (Floating u, Real u) +                   => u -> u -> PrimCTM u -> Matrix3'3 u+translMatrixRepCTM x y ctm = translationMatrix x y * matrixRepCTM ctm+++--------------------------------------------------------------------------------+-- AffineTrafo operations++++concatTrafos :: (Floating u, Real u) => [AffineTrafo u] -> Matrix3'3 u+concatTrafos = foldr (\e ac -> matrixRepr e * ac) identityMatrix++matrixRepr :: (Floating u, Real u) => AffineTrafo u -> Matrix3'3 u+matrixRepr (Matrix mtrx)        = mtrx+matrixRepr (Rotate theta)       = rotationMatrix theta+matrixRepr (RotAbout theta pt)  = originatedRotationMatrix theta pt+matrixRepr (Scale sx sy)        = scalingMatrix sx sy +matrixRepr (Translate dx dy)    = translationMatrix dx dy+

@@ -1,192 +0,0 @@-{-# LANGUAGE FlexibleInstances          #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.Utils--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Utility functions and a Hughes list.---------------------------------------------------------------------------------------module Wumpus.Core.Utils-  ( --  -- | Opt - maybe strict in Some-    Opt(..)-  , some--  -- | Conditional application-  , applyIf--  , rescale--  -- * Truncate / print a double-  , PSUnit(..)-  , dtruncFmt--  , truncateDouble-  , roundup-  ---  -- * PostScript time stamp-  , psTimeStamp--  -- * Hughes list-  , H-  , emptyH-  , wrapH-  , consH-  , snocH  -  , appendH-  , toListH--  ) where---import qualified Wumpus.Core.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----- | Truncate the printed decimal representation of a Double.--- The is prefered to 'showFFloat' from Numeric as it produces--- shorter representations where appropriate.--- --- 0.000000000 becomes 0.0 rather than however many digs are --- specified.---  -truncateDouble :: Double -> String-truncateDouble d | abs d < 0.0001  = "0.0"-                 | d < 0.0         = '-' :  show (abs tx)-                 | otherwise       = show tx-  where-    tx :: Double-    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0--roundi :: RealFrac a => a -> Integer-roundi = round---- | Take 'ceilingi' and show.-roundup :: Double -> String-roundup = show . ceilingi---- Avoid those annoying 'Defaulting ...' warnings...-ceilingi :: RealFrac a => a -> Integer-ceilingi = ceiling------------------------------------------------------------------------------------------ | To be used with getZonedTime--psTimeStamp :: ZonedTime -> ShowS-psTimeStamp zt = localTimeS . showChar ' ' . localDayS-  where-    local_tim   = zonedTimeToLocalTime zt-    localTimeS  = timeOfDay  $ localTimeOfDay $ local_tim-    localDayS   = showString $ showGregorian  $ localDay local_tim--timeOfDay :: TimeOfDay -> ShowS-timeOfDay t = -    fn todHour . showChar ':' . fn todMin . showChar ':' . fn (floori . todSec)-  where-    fn f = pad2 (f t) ---pad2 :: Int -> ShowS-pad2 i | i < 10    = ('0':) . shows i-       | otherwise = shows i  ---floori :: RealFrac a => a -> Int-floori = floor--------------------------------------------------------------------------------------- Hughes list--type H a = [a] -> [a]--emptyH :: H a-emptyH = id---wrapH :: a -> H a-wrapH a = consH a id --consH :: a -> H a -> H a-consH a f = (a:) . f--snocH :: H a -> a -> H a-snocH hl a = hl . (a:)--appendH :: H a -> H a -> H a-appendH f g = f . g--toListH :: H a -> [a]-toListH = ($ [])--

@@ -0,0 +1,192 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Utils.Common+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Utility functions and a Hughes list.+--+--------------------------------------------------------------------------------+++module Wumpus.Core.Utils.Common+  ( ++  -- | Opt - maybe strict in Some+    Opt(..)+  , some++  -- | Conditional application+  , applyIf++  , rescale++  -- * Truncate / print a double+  , PSUnit(..)+  , dtruncFmt++  , truncateDouble+  , roundup+  +++  -- * PostScript time stamp+  , psTimeStamp++  -- * Hughes list+  , H+  , emptyH+  , wrapH+  , consH+  , snocH  +  , appendH+  , toListH++  ) where+++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+++-- | Truncate the printed decimal representation of a Double.+-- The is prefered to 'showFFloat' from Numeric as it produces+-- shorter representations where appropriate.+-- +-- 0.000000000 becomes 0.0 rather than however many digs are +-- specified.+--  +truncateDouble :: Double -> String+truncateDouble d | abs d < 0.0001  = "0.0"+                 | d < 0.0         = '-' :  show (abs tx)+                 | otherwise       = show tx+  where+    tx :: Double+    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0++roundi :: RealFrac a => a -> Integer+roundi = round++-- | Take 'ceilingi' and show.+roundup :: Double -> String+roundup = show . ceilingi++-- Avoid those annoying 'Defaulting ...' warnings...+ceilingi :: RealFrac a => a -> Integer+ceilingi = ceiling+++++--------------------------------------------------------------------------------+++-- | To be used with getZonedTime++psTimeStamp :: ZonedTime -> ShowS+psTimeStamp zt = localTimeS . showChar ' ' . localDayS+  where+    local_tim   = zonedTimeToLocalTime zt+    localTimeS  = timeOfDay  $ localTimeOfDay $ local_tim+    localDayS   = showString $ showGregorian  $ localDay local_tim++timeOfDay :: TimeOfDay -> ShowS+timeOfDay t = +    fn todHour . showChar ':' . fn todMin . showChar ':' . fn (floori . todSec)+  where+    fn f = pad2 (f t) +++pad2 :: Int -> ShowS+pad2 i | i < 10    = ('0':) . shows i+       | otherwise = shows i  +++floori :: RealFrac a => a -> Int+floori = floor++++--------------------------------------------------------------------------------+-- Hughes list++type H a = [a] -> [a]++emptyH :: H a+emptyH = id+++wrapH :: a -> H a+wrapH a = consH a id ++consH :: a -> H a -> H a+consH a f = (a:) . f++snocH :: H a -> a -> H a+snocH hl a = hl . (a:)++appendH :: H a -> H a -> H a+appendH f g = f . g++toListH :: H a -> [a]+toListH = ($ [])++

@@ -0,0 +1,384 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Utils.FormatCombinators+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Formatting combinators - pretty printers without the fitting.+--+--------------------------------------------------------------------------------++module Wumpus.Core.Utils.FormatCombinators+  (+    Doc+  , DocS+  , Format(..)+  , empty+  , showsDoc+  , (<>)+  , (<+>)  +  , vconcat+  , separate+  , hcat+  , hsep+  , vcat++  , text+  , char+  , int+  , integer+  , integral+  , float+  , double++  , space+  , comma+  , semicolon+  , line++  , fill++  , punctuate+  , enclose+  , squotes+  , dquotes+  , parens+  , brackets+  , braces+  , angles++  , lparen+  , rparen+  , lbracket+  , rbracket+  , lbrace+  , rbrace+  , langle+  , rangle++  , list+  , tupled+  , semiBraces++  , indent+    +  ) where++import Data.Monoid+import Numeric++-- | Doc is a Join List ...+--+data Doc = Doc1   ShowS +         | Join   Doc   Doc+         | Line+         | Indent !Int  Doc +++type DocS = Doc -> Doc+++-- Join could be improved...+--+unDoc :: Doc -> ShowS+unDoc = step 0 id+  where+   step _ acc (Doc1 sf)    = acc . sf+   step n acc (Join a b)   = let acc' = step n acc a in step n acc' b+   step n acc Line         = acc . showChar '\n' . indentS n+   step n acc (Indent i d) = step (n+i) (acc . (indentS i)) d+++indentS :: Int -> ShowS+indentS i | i < 1     = id+          | otherwise = showString $ replicate i ' '++runDoc :: Doc -> String+runDoc = ($ "") . unDoc+++instance Show Doc where+  show = runDoc++instance Monoid Doc where+  mempty = empty+  mappend = (<>)+++class Format a where format :: a -> Doc++--------------------------------------------------------------------------------+        +infixr 6 <>, <+>++++-- | Create an empty, zero length document.+--+empty :: Doc+empty = Doc1 id++-- | Create a document from a ShowS function.+--+showsDoc :: ShowS -> Doc+showsDoc = Doc1+++-- | Horizontally concatenate two documents with no space +-- between them.+-- +(<>) :: Doc -> Doc -> Doc+a <> b = Join a b +++-- | Horizontally concatenate two documents with a single space +-- between them.+-- +(<+>) :: Doc -> Doc -> Doc+a <+> b = Join a (Join space b)++-- | Vertical concatenate two documents with a line break.+-- +vconcat :: Doc -> Doc -> Doc+vconcat a b = a <> Line <> b++++separate :: Doc -> [Doc] -> Doc+separate _   []     = empty+separate sep (a:as) = step a as+  where+    step acc []     = acc+    step acc (x:xs) = step (acc <> sep <> x) xs++-- | Horizontally concatenate a list of documents with @(\<\>)@.+--+hcat :: [Doc] -> Doc+hcat = foldr (<>) empty++-- | Horizontally concatenate a list of documents with @(\<+\>)@.+--+hsep :: [Doc] -> Doc+hsep = separate space++-- | Vertically concatenate a list of documents, with a line +-- break between each doc.+--+vcat :: [Doc] -> Doc+vcat []     = empty+vcat (x:xs) = step x xs +  where+    step acc (z:zs) = step (acc `vconcat` z) zs+    step acc []     = acc++-- | Create a document from a literal string.+-- +-- The string should not contain newlines (though this is not +-- enforced). +--+text :: String -> Doc+text = Doc1 . showString+++-- | Create a document from a literal character.+--+-- The char should not be a tab or newline. +--+char :: Char -> Doc+char = Doc1 . showChar++-- | Show the Int as a Doc.+--+-- > int  = text . show+--+int :: Int -> Doc+int  = Doc1 . showInt++-- | Show the Integer as a Doc.+--+integer :: Integer -> Doc+integer = Doc1 . showInt++-- | Show an \"integral value\" as a Doc via 'fromIntegral'.+--+integral :: Integral a => a -> Doc+integral = Doc1 . showInt++-- | Show the Float as a Doc.+--+float :: Double -> Doc+float = Doc1 . showFloat++-- | Show the Double as a Doc.+--+double :: Double -> Doc+double = Doc1 . showFloat+ +-- | Create a Doc containing a single space character.+--+space :: Doc+space = char ' '++-- | Create a Doc containing a comma, \",\".+--+comma :: Doc+comma = char ','++-- | Create a Doc containing a semi colon, \";\".+--+semicolon :: Doc+semicolon = char ';'++-- | Create a Doc containing newline, \"\\n\".+--+line :: Doc +line = char '\n'+++--------------------------------------------------------------------------------++-- | Fill a doc to the supplied length, padding the right-hand+-- side with spaces.+--+-- Note - this function is expensive - it unrolls the functional+-- representation of the String. +-- +-- Also it should only be used for single line Doc\'s.+-- +fill :: Int -> Doc -> Doc+fill i d = Doc1 (padr i ' ' $ unDoc d) ++padr :: Int -> Char -> ShowS -> ShowS+padr i c df = step (length $ df []) +  where+    step len | len >= i  = df+             | otherwise = df . showString (replicate (i-len) c)++--------------------------------------------------------------------------------++-- | Punctuate the Doc list with the separator, producing a Doc. +--+punctuate :: Doc -> [Doc] -> Doc+punctuate _ []     = empty+punctuate _ [x]    = x+punctuate s (x:xs) = x <> s <> punctuate s xs+++-- | Enclose the final Doc within the first two.+--+-- There are no spaces between the documents:+--+-- > enclose l r d = l <> d <> r+--+enclose :: Doc -> Doc -> Doc -> Doc+enclose l r d = l <> d <> r++++-- | Enclose the Doc within single quotes.+--+squotes :: Doc -> Doc+squotes = enclose (char '\'') (char '\'')++-- | Enclose the Doc within double quotes.+--+dquotes :: Doc -> Doc+dquotes = enclose (char '"') (char '"')++-- | Enclose the Doc within parens @()@.+--+parens :: Doc -> Doc+parens = enclose lparen rparen++-- | Enclose the Doc within square brackets @[]@.+--+brackets :: Doc -> Doc+brackets = enclose lbracket rbracket++-- | Enclose the Doc within curly braces @{}@.+--+braces :: Doc -> Doc+braces = enclose lbrace rbrace++-- | Enclose the Doc within angle brackets @\<\>@.+--+angles :: Doc -> Doc+angles = enclose langle rangle++++-- | Create a Doc containing a left paren, \'(\'.+--+lparen :: Doc+lparen = char '('++-- | Create a Doc containing a right paren, \')\'.+--+rparen :: Doc+rparen = char ')'++-- | Create a Doc containing a left square bracket, \'[\'.+--+lbracket :: Doc+lbracket = char '['++-- | Create a Doc containing a right square bracket, \']\'.+--+rbracket :: Doc+rbracket = char ']'++-- | Create a Doc containing a left curly brace, \'{\'.+--+lbrace :: Doc+lbrace = char '{'++-- | Create a Doc containing a right curly brace, \'}\'.+--+rbrace :: Doc+rbrace = char '}'++-- | Create a Doc containing a left angle bracket, \'\<\'.+--+langle :: Doc+langle = char '<'++-- | Create a Doc containing a right angle bracket, \'\>\'.+--+rangle :: Doc+rangle = char '>'++-- | Comma separate the list of documents and enclose in square+-- brackets.+--+list :: [Doc] -> Doc+list = brackets . punctuate comma++-- | Comma separate the list of documents and enclose in parens.+--+tupled :: [Doc] -> Doc+tupled = parens . punctuate comma++-- | Separate the list with a semicolon and enclose in curly +-- braces.+--+semiBraces :: [Doc] -> Doc+semiBraces = braces . punctuate semicolon+++-- | Horizontally indent a Doc.+--+-- Note - this space-prefixes the Doc on /the current line/. It+-- does not indent subsequent lines if the Doc spans multiple +-- lines.+--+indent :: Int -> Doc -> Doc+indent i d | i < 1     = d+           | otherwise = Indent i d++

@@ -0,0 +1,133 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.Utils.OneList+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Data type for non-empty lists.+-- +--------------------------------------------------------------------------------++module Wumpus.Core.Utils.OneList+  (+   -- OneMany+    OneList+  , ViewL(..)++  , one+  , cons+  , head+  , viewl++  , fromList++  , toListF+  , accumMapL+  , isOne+  , isMany+   +  ) where++++import Control.Applicative+import Data.Foldable+import Data.Monoid+import Data.Traversable++import Prelude hiding ( head )+++data OneList a = One a | Many a (OneList a)+  deriving (Eq)++data ViewL a = OneL a | a :< (OneList a)+  deriving (Eq)++++--------------------------------------------------------------------------------+-- Instances++instance Show a => Show (OneList a) where+  show = ('{':) . ($ []) . step where+     step (One a)     = shows a . showChar '}'+     step (Many a as) = shows a . showChar ',' . step as+++instance Functor OneList where+  fmap f (One a)        = One $ f a+  fmap f (Many a as)    = Many (f a) (fmap f as)++instance Foldable OneList where+  foldMap f (One a)     = f a+  foldMap f (Many a as) = f a `mappend` foldMap f as++  foldr f b0 = step b0 where+    step b (One a)      = f a b+    step b (Many a as)  = f a (step b as)++  foldl f b0 = step b0 where+    step b (One a)      = f b a+    step b (Many a as)  = step (f b a) as+++instance Traversable OneList where+  traverse f (One a)      = One  <$> f a+  traverse f (Many a as)  = Many <$> f a <*> traverse f as++++--------------------------------------------------------------------------------+-- | Construct One.+one :: a -> OneList a+one = One+++-- | Prepend an element. Obviously this transforms a One to a Many.+cons :: a -> OneList a -> OneList a+cons a as   = Many a as++-- | 'head' is total of course.+head :: OneList a -> a+head (One a)    = a+head (Many a _) = a++viewl :: OneList a -> ViewL a+viewl (One a)     = OneL a+viewl (Many a as) = a :< as++-- | Construct Many. Not this function throws a error if the list has+-- zero or one elements+fromList :: [a] -> OneList a+fromList []     = error "OneList.fromList: cannot build Many from empty list"+fromList [a]    = One a+fromList (a:as) = Many a (fromList as)+++toListF :: (a -> b) -> OneList a -> [b]+toListF f = step where+  step (One x)     = [f x]+  step (Many x xs) = f x : step xs+++accumMapL :: (x -> st -> (y,st)) -> OneList x -> st -> (OneList y,st)+accumMapL f (One x)     st = let (y,st') = f x st in (One y,st')+accumMapL f (Many x xs) st = (Many y ys,st'')+                             where (y, st')  = f x st+                                   (ys,st'') = accumMapL f xs st'++isMany :: OneList a -> Bool+isMany (Many _ _) = True+isMany _          = False++isOne :: OneList a -> Bool+isOne (One _)     = True+isOne _           = False+

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

@@ -29,8 +29,6 @@   -- * Picture types     Picture   , DPicture-  , PrimElement-  , DPrimElement   , FontCtx   , Primitive   , DPrimitive@@ -44,20 +42,6 @@   , KerningChar   , DKerningChar -  -- * Drawing styles-  , PathProps       -  , LabelProps-  , EllipseProps----  -- * Transformations on PrimElements-  , rotatePrim-  , scalePrim-  , uniformScalePrim-  , translatePrim--   -- * Printable unit for PostScript   , PSUnit(..) @@ -65,5 +49,5 @@   import Wumpus.Core.PictureInternal-import Wumpus.Core.Utils ( PSUnit(..) )+import Wumpus.Core.Utils.Common ( PSUnit(..) ) 

@@ -1,5 +1,5 @@ name:             wumpus-core-version:          0.35.0+version:          0.36.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -44,17 +44,78 @@   to convert EPS files generated by Wumpus to many other formats    (bitmaps).    .+  VERSION 0.36.0 UPGRADE NOTES+  .+  There are two major changes between 0.35.0 and 0.36.0. +  .+  @PrimElement@ has been removed and the grouping constructor it +  provided has been moved into the @Primitive@ type. As both +  types are opaque, definitions in client code will work without +  change, /but all/ type signatures referencing @PrimElement@ will +  need to replace @PrimElement@ with @Primitive@.+  .+  Rotations and scalings on Primitives have changed again.+  Primitives are now instances of the affine classes so support - +  @rotate@, @rotateAbout@, @scale@, @translate@. Primitives are +  now considered to be in the implicit affine frame with origin at +  (0,0). Previously rotatation on Primitives (via the function +  @rotatePrim@) was really a special case to allow slanted text, +  the rotation was about the text\'s baseline origin and not the +  affine frame. As rotation now works differently there is a +  special constructor for slanted text @rtextlabel@.+  .   Changelog:   .-  0.34.0 to 0.35.0:+  0.35.0 to 0.36.0:   .-  * Bug fix - PostScript output - when more than one stroke -    property changed the changes were concatenated without -    a separator. This generated invalid PostScript. Now fixed.+  * API / behaviour change - rotation on primitives changed. New +    functions have been added to create rotated text labels and +    ellipses (@rtextlabel@, @rstrokeEllipse@, etc.), and +    Primitives have been made instances of the Affine classes+    except for the general matrix Transform class. The old+    functions for transforming Primitives (@rotatePrim@, +    @scalePrim@, etc.) have been removed. The demos (Rotated.hs,+    Scaled.hs, Translated.hs) have been removed as they pertain +    to the old behaviour, there are new demos highlighting the+    new behaviour (TransformEllipse.hs, etc.).   .-  * Documentation updates to the guide and the Haddock docs.+  * Major change - removed the PrimElement type. The (opaque) +    Primitive type has been changed to incorporate a grouping +    constructor equivalent to PrimElement\'s @XLinkGroup@ +    contructor. The change has made the implementation of SVG +    hyperlinks more efficient, but has forced various type +    signatures to change in @Core.Picture@. Client code will +    also have to change type signatures - @PrimElement@ becomes+    @Primitive@.   .+  * @Core.PtSize@ - the class @FromPtSize@ has been given a @Num@+    superclass constraint. This can shorten type signatures of +    functions that use @fromPtSize@.   .+  * Corrected a bug where textlabels would generate an invalid+    bounding box and cause a runtime error when supplied with an+    empty string. Now there is no runtime error - and /no-ops/ +    are generated in the output.+  .+  * Internal changes - moved @PrimCTM@ from @Core.PictureInternal@+    into separate module. Moved /utility/ modules into their own +    directory @Utils@. Move /text/ modules into their own +    directory @Text@. +  .+  * Removed dependency on @algebra@ for @Semigroup@. The +    equivalent @append@ operation on @BoundingBox@ is +    @boundaryUnion@.+  .+  * Renamed the @Core.GraphicsState@ to @Core.GraphicProps@. +    Moved the property datatypes from @Core.PictureInternal@ into +    @Core.GraphicProps@ (StrokeProps, LabelProps, etc.).+  .+  * Moved @wumpus_default_font@ from @Core.Picture@ into +    @Core.Graphic.Props@.+  .+  * Haddock docs improved.+  .+  . build-type:         Simple stability:          unstable cabal-version:      >= 1.2@@ -72,9 +133,9 @@   demo/LabelPic.hs,   demo/Latin1Pic.hs,   demo/MultiPic.hs,-  demo/Rotated.hs,-  demo/Scaled.hs,-  demo/Translated.hs,+  demo/TransformEllipse.hs,+  demo/TransformPath.hs,+  demo/TransformTextlabel.hs,   demo/ZOrderPic.hs,   doc/Guide.pdf,   doc-src/Guide.lhs,@@ -88,8 +149,7 @@   build-depends:      base            <  5,                        containers      >= 0.3      && <= 0.4,                        time            >= 1.1.3    && < 1.2,-                      vector-space    >= 0.6      && < 1.0,-                      algebra         >= 0.0.0.1+                      vector-space    >= 0.6      && < 1.0                            exposed-modules:     Wumpus.Core,@@ -98,27 +158,28 @@     Wumpus.Core.Colour,     Wumpus.Core.FontSize,     Wumpus.Core.Geometry,-    Wumpus.Core.GraphicsState,+    Wumpus.Core.GraphicProps,     Wumpus.Core.OutputPostScript,     Wumpus.Core.OutputSVG,     Wumpus.Core.Picture,     Wumpus.Core.PtSize,-    Wumpus.Core.TextDefaultEncoder,-    Wumpus.Core.TextEncoder,-    Wumpus.Core.TextLatin1,-    Wumpus.Core.TextSymbolFont,+    Wumpus.Core.Text.DefaultEncoder,+    Wumpus.Core.Text.Encoder,+    Wumpus.Core.Text.Latin1,+    Wumpus.Core.Text.SymbolFont,     Wumpus.Core.VersionNumber,     Wumpus.Core.WumpusTypes    other-modules:-    Wumpus.Core.FormatCombinators,     Wumpus.Core.PageTranslation,     Wumpus.Core.PictureInternal,     Wumpus.Core.PostScriptDoc,     Wumpus.Core.SVGDoc,-    Wumpus.Core.OneList,-    Wumpus.Core.TextInternal,-    Wumpus.Core.Utils+    Wumpus.Core.Text.TextInternal,+    Wumpus.Core.TrafoInternal,+    Wumpus.Core.Utils.Common,+    Wumpus.Core.Utils.OneList,+    Wumpus.Core.Utils.FormatCombinators        extensions: