diff --git a/demo/AffineTest01.hs b/demo/AffineTest01.hs
--- a/demo/AffineTest01.hs
+++ b/demo/AffineTest01.hs
@@ -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
diff --git a/demo/AffineTest02.hs b/demo/AffineTest02.hs
--- a/demo/AffineTest02.hs
+++ b/demo/AffineTest02.hs
@@ -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
diff --git a/demo/AffineTest03.hs b/demo/AffineTest03.hs
--- a/demo/AffineTest03.hs
+++ b/demo/AffineTest03.hs
@@ -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
diff --git a/demo/AffineTestBase.hs b/demo/AffineTestBase.hs
--- a/demo/AffineTestBase.hs
+++ b/demo/AffineTestBase.hs
@@ -39,9 +39,9 @@
{ ata_console_msg :: String
, ata_eps_file :: FilePath
, ata_svg_file :: FilePath
- , ata_prim_constructor :: RGBi -> 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...
diff --git a/demo/DeltaPic.hs b/demo/DeltaPic.hs
--- a/demo/DeltaPic.hs
+++ b/demo/DeltaPic.hs
@@ -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
diff --git a/demo/FontMetrics.hs b/demo/FontMetrics.hs
--- a/demo/FontMetrics.hs
+++ b/demo/FontMetrics.hs
@@ -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
diff --git a/demo/KernPic.hs b/demo/KernPic.hs
--- a/demo/KernPic.hs
+++ b/demo/KernPic.hs
@@ -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
diff --git a/demo/LabelPic.hs b/demo/LabelPic.hs
--- a/demo/LabelPic.hs
+++ b/demo/LabelPic.hs
@@ -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)
+
diff --git a/demo/Latin1Pic.hs b/demo/Latin1Pic.hs
--- a/demo/Latin1Pic.hs
+++ b/demo/Latin1Pic.hs
@@ -29,7 +29,7 @@
-helveticaLabel :: String -> DPoint2 -> DPrimElement
+helveticaLabel :: String -> DPoint2 -> DPrimitive
helveticaLabel ss pt = textlabel black helvetica18 ss pt
helvetica18 :: FontAttr
diff --git a/demo/MultiPic.hs b/demo/MultiPic.hs
--- a/demo/MultiPic.hs
+++ b/demo/MultiPic.hs
@@ -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]
diff --git a/demo/Rotated.hs b/demo/Rotated.hs
deleted file mode 100644
--- a/demo/Rotated.hs
+++ /dev/null
@@ -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
-
-
diff --git a/demo/Scaled.hs b/demo/Scaled.hs
deleted file mode 100644
--- a/demo/Scaled.hs
+++ /dev/null
@@ -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
-
-
diff --git a/demo/TransformEllipse.hs b/demo/TransformEllipse.hs
new file mode 100644
--- /dev/null
+++ b/demo/TransformEllipse.hs
@@ -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]
diff --git a/demo/TransformPath.hs b/demo/TransformPath.hs
new file mode 100644
--- /dev/null
+++ b/demo/TransformPath.hs
@@ -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]
diff --git a/demo/TransformTextlabel.hs b/demo/TransformTextlabel.hs
new file mode 100644
--- /dev/null
+++ b/demo/TransformTextlabel.hs
@@ -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]
diff --git a/demo/Translated.hs b/demo/Translated.hs
deleted file mode 100644
--- a/demo/Translated.hs
+++ /dev/null
@@ -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
-
-
-
diff --git a/demo/ZOrderPic.hs b/demo/ZOrderPic.hs
--- a/demo/ZOrderPic.hs
+++ b/demo/ZOrderPic.hs
@@ -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)
diff --git a/doc-src/Guide.lhs b/doc-src/Guide.lhs
--- a/doc-src/Guide.lhs
+++ b/doc-src/Guide.lhs
@@ -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 @@
...
\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}
diff --git a/doc-src/WorldFrame.hs b/doc-src/WorldFrame.hs
--- a/doc-src/WorldFrame.hs
+++ b/doc-src/WorldFrame.hs
@@ -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}
diff --git a/doc/Guide.pdf b/doc/Guide.pdf
Binary files a/doc/Guide.pdf and b/doc/Guide.pdf differ
diff --git a/src/Wumpus/Core.hs b/src/Wumpus/Core.hs
--- a/src/Wumpus/Core.hs
+++ b/src/Wumpus/Core.hs
@@ -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
diff --git a/src/Wumpus/Core/AffineTrans.hs b/src/Wumpus/Core/AffineTrans.hs
--- a/src/Wumpus/Core/AffineTrans.hs
+++ b/src/Wumpus/Core/AffineTrans.hs
@@ -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.
diff --git a/src/Wumpus/Core/BoundingBox.hs b/src/Wumpus/Core/BoundingBox.hs
--- a/src/Wumpus/Core/BoundingBox.hs
+++ b/src/Wumpus/Core/BoundingBox.hs
@@ -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
diff --git a/src/Wumpus/Core/Colour.hs b/src/Wumpus/Core/Colour.hs
--- a/src/Wumpus/Core/Colour.hs
+++ b/src/Wumpus/Core/Colour.hs
@@ -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
diff --git a/src/Wumpus/Core/FontSize.hs b/src/Wumpus/Core/FontSize.hs
--- a/src/Wumpus/Core/FontSize.hs
+++ b/src/Wumpus/Core/FontSize.hs
@@ -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
diff --git a/src/Wumpus/Core/FormatCombinators.hs b/src/Wumpus/Core/FormatCombinators.hs
deleted file mode 100644
--- a/src/Wumpus/Core/FormatCombinators.hs
+++ /dev/null
@@ -1,384 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module : Wumpus.Core.FormatCombinators
--- Copyright : (c) Stephen Tetley 2010
--- License : BSD3
---
--- Maintainer : Stephen Tetley
--- 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
-
-
diff --git a/src/Wumpus/Core/Geometry.hs b/src/Wumpus/Core/Geometry.hs
--- a/src/Wumpus/Core/Geometry.hs
+++ b/src/Wumpus/Core/Geometry.hs
@@ -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)
diff --git a/src/Wumpus/Core/GraphicProps.hs b/src/Wumpus/Core/GraphicProps.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/GraphicProps.hs
@@ -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
diff --git a/src/Wumpus/Core/GraphicsState.hs b/src/Wumpus/Core/GraphicsState.hs
deleted file mode 100644
--- a/src/Wumpus/Core/GraphicsState.hs
+++ /dev/null
@@ -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
- }
diff --git a/src/Wumpus/Core/OneList.hs b/src/Wumpus/Core/OneList.hs
deleted file mode 100644
--- a/src/Wumpus/Core/OneList.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module : Wumpus.Core.OneList
--- Copyright : (c) Stephen Tetley 2009-2010
--- License : BSD3
---
--- Maintainer : Stephen Tetley
--- 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
-
diff --git a/src/Wumpus/Core/OutputPostScript.hs b/src/Wumpus/Core/OutputPostScript.hs
--- a/src/Wumpus/Core/OutputPostScript.hs
+++ b/src/Wumpus/Core/OutputPostScript.hs
@@ -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
diff --git a/src/Wumpus/Core/OutputSVG.hs b/src/Wumpus/Core/OutputSVG.hs
--- a/src/Wumpus/Core/OutputSVG.hs
+++ b/src/Wumpus/Core/OutputSVG.hs
@@ -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
diff --git a/src/Wumpus/Core/PageTranslation.hs b/src/Wumpus/Core/PageTranslation.hs
--- a/src/Wumpus/Core/PageTranslation.hs
+++ b/src/Wumpus/Core/PageTranslation.hs
@@ -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
diff --git a/src/Wumpus/Core/Picture.hs b/src/Wumpus/Core/Picture.hs
--- a/src/Wumpus/Core/Picture.hs
+++ b/src/Wumpus/Core/Picture.hs
@@ -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:
diff --git a/src/Wumpus/Core/PictureInternal.hs b/src/Wumpus/Core/PictureInternal.hs
--- a/src/Wumpus/Core/PictureInternal.hs
+++ b/src/Wumpus/Core/PictureInternal.hs
@@ -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
+
diff --git a/src/Wumpus/Core/PostScriptDoc.hs b/src/Wumpus/Core/PostScriptDoc.hs
--- a/src/Wumpus/Core/PostScriptDoc.hs
+++ b/src/Wumpus/Core/PostScriptDoc.hs
@@ -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
diff --git a/src/Wumpus/Core/PtSize.hs b/src/Wumpus/Core/PtSize.hs
--- a/src/Wumpus/Core/PtSize.hs
+++ b/src/Wumpus/Core/PtSize.hs
@@ -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
diff --git a/src/Wumpus/Core/SVGDoc.hs b/src/Wumpus/Core/SVGDoc.hs
--- a/src/Wumpus/Core/SVGDoc.hs
+++ b/src/Wumpus/Core/SVGDoc.hs
@@ -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
diff --git a/src/Wumpus/Core/Text/DefaultEncoder.hs b/src/Wumpus/Core/Text/DefaultEncoder.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Text/DefaultEncoder.hs
@@ -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
+
+
diff --git a/src/Wumpus/Core/Text/Encoder.hs b/src/Wumpus/Core/Text/Encoder.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Text/Encoder.hs
@@ -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�o350;re
+--
+-- > myst�xE8;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.
+
+
diff --git a/src/Wumpus/Core/Text/Latin1.hs b/src/Wumpus/Core/Text/Latin1.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Text/Latin1.hs
@@ -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)
+ ]
diff --git a/src/Wumpus/Core/Text/SymbolFont.hs b/src/Wumpus/Core/Text/SymbolFont.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Text/SymbolFont.hs
@@ -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)
+ ]
diff --git a/src/Wumpus/Core/Text/TextInternal.hs b/src/Wumpus/Core/Text/TextInternal.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Text/TextInternal.hs
@@ -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.:
+--
+-- > è
+--
+-- Note, HTML entity names do not seem to be supported in SVG,
+-- @ è @ does not work in FireFox or Chrome.
+--
+lexLabel :: String -> EncodedText
+lexLabel = EncodedText . lexer
+
+-- Note - the lexer reads number spans with isDigit, so reads
+-- decimals only.
+--
+lexer :: String -> [TextChunk]
+lexer [] = []
+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 [] = []
+
diff --git a/src/Wumpus/Core/TextDefaultEncoder.hs b/src/Wumpus/Core/TextDefaultEncoder.hs
deleted file mode 100644
--- a/src/Wumpus/Core/TextDefaultEncoder.hs
+++ /dev/null
@@ -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
-
-
diff --git a/src/Wumpus/Core/TextEncoder.hs b/src/Wumpus/Core/TextEncoder.hs
deleted file mode 100644
--- a/src/Wumpus/Core/TextEncoder.hs
+++ /dev/null
@@ -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�o350;re
---
--- > myst�xE8;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.
-
-
diff --git a/src/Wumpus/Core/TextInternal.hs b/src/Wumpus/Core/TextInternal.hs
deleted file mode 100644
--- a/src/Wumpus/Core/TextInternal.hs
+++ /dev/null
@@ -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.:
---
--- > è
---
--- Note, HTML entity names do not seem to be supported in SVG,
--- @ è @ does not work in FireFox or Chrome.
---
-lexLabel :: String -> EncodedText
-lexLabel = EncodedText . lexer
-
--- Note - the lexer reads number spans with isDigit, so reads
--- decimals only.
---
-lexer :: String -> [TextChunk]
-lexer [] = []
-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 [] = []
-
diff --git a/src/Wumpus/Core/TextLatin1.hs b/src/Wumpus/Core/TextLatin1.hs
deleted file mode 100644
--- a/src/Wumpus/Core/TextLatin1.hs
+++ /dev/null
@@ -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)
- ]
diff --git a/src/Wumpus/Core/TextSymbolFont.hs b/src/Wumpus/Core/TextSymbolFont.hs
deleted file mode 100644
--- a/src/Wumpus/Core/TextSymbolFont.hs
+++ /dev/null
@@ -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)
- ]
diff --git a/src/Wumpus/Core/TrafoInternal.hs b/src/Wumpus/Core/TrafoInternal.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/TrafoInternal.hs
@@ -0,0 +1,138 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : Wumpus.Core.TrafoInternal
+-- Copyright : (c) Stephen Tetley 2010
+-- License : BSD3
+--
+-- Maintainer : Stephen Tetley
+-- 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
+
diff --git a/src/Wumpus/Core/Utils.hs b/src/Wumpus/Core/Utils.hs
deleted file mode 100644
--- a/src/Wumpus/Core/Utils.hs
+++ /dev/null
@@ -1,192 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module : Wumpus.Core.Utils
--- Copyright : (c) Stephen Tetley 2009-2010
--- License : BSD3
---
--- Maintainer : Stephen Tetley
--- 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 = ($ [])
-
-
diff --git a/src/Wumpus/Core/Utils/Common.hs b/src/Wumpus/Core/Utils/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Utils/Common.hs
@@ -0,0 +1,192 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : Wumpus.Core.Utils.Common
+-- Copyright : (c) Stephen Tetley 2009-2010
+-- License : BSD3
+--
+-- Maintainer : Stephen Tetley
+-- 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 = ($ [])
+
+
diff --git a/src/Wumpus/Core/Utils/FormatCombinators.hs b/src/Wumpus/Core/Utils/FormatCombinators.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Utils/FormatCombinators.hs
@@ -0,0 +1,384 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : Wumpus.Core.Utils.FormatCombinators
+-- Copyright : (c) Stephen Tetley 2010
+-- License : BSD3
+--
+-- Maintainer : Stephen Tetley
+-- 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
+
+
diff --git a/src/Wumpus/Core/Utils/OneList.hs b/src/Wumpus/Core/Utils/OneList.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Core/Utils/OneList.hs
@@ -0,0 +1,133 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : Wumpus.Core.Utils.OneList
+-- Copyright : (c) Stephen Tetley 2009-2010
+-- License : BSD3
+--
+-- Maintainer : Stephen Tetley
+-- 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
+
diff --git a/src/Wumpus/Core/VersionNumber.hs b/src/Wumpus/Core/VersionNumber.hs
--- a/src/Wumpus/Core/VersionNumber.hs
+++ b/src/Wumpus/Core/VersionNumber.hs
@@ -22,7 +22,7 @@
-- | Version number.
--
--- > (0,35,0)
+-- > (0,36,0)
--
wumpus_core_version :: (Int,Int,Int)
-wumpus_core_version = (0,35,0)
+wumpus_core_version = (0,36,0)
diff --git a/src/Wumpus/Core/WumpusTypes.hs b/src/Wumpus/Core/WumpusTypes.hs
--- a/src/Wumpus/Core/WumpusTypes.hs
+++ b/src/Wumpus/Core/WumpusTypes.hs
@@ -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(..) )
diff --git a/wumpus-core.cabal b/wumpus-core.cabal
--- a/wumpus-core.cabal
+++ b/wumpus-core.cabal
@@ -1,5 +1,5 @@
name: wumpus-core
-version: 0.35.0
+version: 0.36.0
license: BSD3
license-file: LICENSE
copyright: Stephen Tetley
@@ -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: