wumpus-core 0.23.0 → 0.30.0

raw patch · 40 files changed

+3129/−3270 lines, 40 filesdep −monadLibdep −wl-pprintdep −xmldep ~algebradep ~containersdep ~vector-spacePVP ok

version bump matches the API change (PVP)

Dependencies removed: monadLib, wl-pprint, xml

Dependency ranges changed: algebra, containers, vector-space

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• demo/AffineTestBase.hs +24/−80
• demo/FontMetrics.hs +10/−11
• demo/LabelPic.hs +12/−13
• demo/MultiPic.hs +2/−2
• demo/Rotated.hs +8/−8
• demo/Scaled.hs +8/−8
• demo/Translated.hs +8/−8
• demo/ZOrderPic.hs +35/−0
• doc-src/Guide.lhs +25/−26
• doc-src/Makefile +2/−0
• doc-src/WorldFrame.hs +4/−4
• doc/Guide.pdf binary
• src/Wumpus/Core.hs +2/−2
• src/Wumpus/Core/AffineTrans.hs +29/−9
• src/Wumpus/Core/BoundingBox.hs +51/−89
• src/Wumpus/Core/Colour.hs +43/−245
• src/Wumpus/Core/FontSize.hs +1/−1
• src/Wumpus/Core/FormatCombinators.hs +384/−0
• src/Wumpus/Core/Geometry.hs +80/−215
• src/Wumpus/Core/GraphicsState.hs +38/−110
• src/Wumpus/Core/OneList.hs +8/−10
• src/Wumpus/Core/OutputPostScript.hs +379/−237
• src/Wumpus/Core/OutputSVG.hs +258/−232
• src/Wumpus/Core/PageTranslation.hs +65/−0
• src/Wumpus/Core/Picture.hs +254/−273
• src/Wumpus/Core/PictureInternal.hs +416/−396
• src/Wumpus/Core/PostScript.hs +0/−544
• src/Wumpus/Core/PostScriptDoc.hs +350/−0
• src/Wumpus/Core/PtSize.hs +4/−2
• src/Wumpus/Core/SVG.hs +0/−436
• src/Wumpus/Core/SVGDoc.hs +382/−0
• src/Wumpus/Core/TextEncoder.hs +3/−3
• src/Wumpus/Core/TextEncodingInternal.hs +0/−101
• src/Wumpus/Core/TextInternal.hs +100/−0
• src/Wumpus/Core/TextLatin1.hs +1/−1
• src/Wumpus/Core/Utils.hs +65/−165
• src/Wumpus/Core/VersionNumber.hs +5/−5
• src/Wumpus/Core/WumpusTypes.hs +12/−11
• wumpus-core.cabal +60/−22

@@ -1,4 +1,4 @@-Copyright (c) 2008 Stephen Peter Tetley+Copyright (c) 2009-2010 Stephen Peter Tetley  All rights reserved. 

@@ -25,8 +25,8 @@ import System.Directory
 
 
-light_blue :: DRGB
-light_blue = iRGB3 176 224 231
+light_blue :: RGBi
+light_blue = RGBi 176 224 231
 
 
 runAlgs :: [AffineTrafoAlg] -> [ControlPointAlg] -> IO ()
@@ -39,7 +39,7 @@       { ata_console_msg         :: String
       , ata_eps_file            :: FilePath
       , ata_svg_file            :: FilePath
-      , ata_prim_constructor    :: DRGB -> DPrimitive
+      , ata_prim_constructor    :: RGBi -> DPrimitive
       , ata_pic_transformer     :: DPicture -> DPicture
       , ata_prim_transformer    :: DPrimitive -> DPrimitive
       }
@@ -56,7 +56,7 @@                           (ata_prim_transformer ata)
 
 
-buildPictureATA :: (DRGB -> DPrimitive) 
+buildPictureATA :: (RGBi -> DPrimitive) 
          -> (DPicture -> DPicture) 
          -> (DPrimitive -> DPrimitive) 
          -> DPicture
@@ -64,10 +64,10 @@     picture1 `picBeside` picture2 `picBeside` picture3
   where
     picture1 :: DPicture
-    picture1 = illustrateBounds light_blue $ frame $ (mk black)
+    picture1 = illustrateBounds light_blue $ frame [mk black]
   
     picture2 :: DPicture
-    picture2 = illustrateBounds light_blue $ picF $ frame $ (mk blue)
+    picture2 = illustrateBounds light_blue $ picF $ frame [mk blue]
 
     picture3 :: DPicture
     picture3 = illustrateBoundsPrim light_blue $ prim
@@ -85,7 +85,7 @@       { cpa_console_msg         :: String
       , cpa_eps_file            :: FilePath
       , cpa_svg_file            :: FilePath
-      , cpa_prim_constructor    :: DRGB -> DPrimitive
+      , cpa_prim_constructor    :: RGBi -> DPrimitive
       , cpa_prim_transformer    :: DPrimitive -> DPrimitive 
       }
 
@@ -98,7 +98,7 @@   where
     pic = cpPicture (cpa_prim_constructor cpa) (cpa_prim_transformer cpa)
 
-cpPicture :: (DRGB -> DPrimitive) -> (DPrimitive -> DPrimitive) -> DPicture
+cpPicture :: (RGBi -> DPrimitive) -> (DPrimitive -> DPrimitive) -> DPicture
 cpPicture constr trafo = 
     illustrateBounds light_blue $ illustrateControlPoints black 
                                 $ transformed_prim
@@ -109,85 +109,29 @@ 
 --------------------------------------------------------------------------------
 
-rgbLabel :: DRGB -> DPrimitive
+rgbLabel :: RGBi -> DPrimitive
 rgbLabel rgb = textlabel rgb "Wumpus!" zeroPt
 
-rgbCircle :: DRGB -> DPrimitive
+rgbCircle :: RGBi -> DPrimitive
 rgbCircle rgb = ellipse rgb 60 60 zeroPt
 
-rgbEllipse :: DRGB -> DPrimitive
+rgbEllipse :: RGBi -> DPrimitive
 rgbEllipse rgb = ellipse rgb 60 30 zeroPt
 
-rgbPath :: DRGB -> DPrimitive
+rgbPath :: RGBi -> DPrimitive
 rgbPath rgb = ostroke rgb $ dog_kennel
-
-
 --------------------------------------------------------------------------------
--- Hughes Lists for Hughes Paths
-
--- At some point /wumpus-extra/ will have code along these lines...
-
-type H a = [a] -> [a]
-
-emptyH :: H a
-emptyH = id
-
-
--- NOTE - this is redundant if we want consH 
--- rather than snocH.
--- 
--- Some of the drawings do appear to have problems with 
--- Z-order so we'll keep it for now.
---
-consH :: a -> H a -> H a
-consH a hf = hf . (a:)
-
-toListH :: H a -> [a]
-toListH = ($ [])
-
-
-
---------------------------------------------------------------------------------
--- /Hughes/ paths
-
-
-type HPath u = (Point2 u, H (PathSegment u))
-
-makePath :: HPath u -> Path u
-makePath (s,hf) = path s (toListH hf)
-
-
-start_path :: (u,u) -> HPath u
-start_path (x,y) = (P2 x y, emptyH)
-
-infixl 6 `line_to`, `curve_to`
-
-line_to :: HPath u -> (u,u) -> HPath u
-line_to (s,f) (x,y) = (s, lineTo (P2 x y) `consH` f)
-
-curve_to :: HPath u -> ((u,u),(u,u),(u,u)) -> HPath u
-curve_to (s,f) ((c1x,c1y),(c2x,c2y),(ex,ey)) = 
-    (s, curveTo (P2 c1x c1y) (P2 c2x c2y) (P2 ex ey) `consH` f)
-
-
---
--- vertical (length) & horizontal (length) might
--- be handy...
--- 
--- But we would need to track current position, vis-a-vis a 
--- state monad, so this is taking things towards a big module.
---
---
-
---------------------------------------------------------------------------------
 -- Demo - draw a dog kennel...
 
-dog_kennel :: DPath
-dog_kennel = makePath $ 
-    start_path (0,0) `line_to`  (0,60)   `line_to` (40,100)
-                     `line_to`  (80,60)  `line_to` (80,0)
-                     `line_to`  (60,0)   `line_to` (60,30)
-                     `curve_to` ((60,50), (50,60), (40,60))
-                     `curve_to` ((30,60), (20,50), (20,30))
-                     `line_to`  (20,0)
-                        
+
+dog_kennel :: DPrimPath
+dog_kennel = path zeroPt [ lineTo  (P2 0 60) 
+                         , lineTo  (P2 40 100)
+                         , lineTo  (P2 80 60)
+                         , lineTo  (P2 80 0)
+                         , lineTo  (P2 60 0)  
+                         , lineTo  (P2 60 30)
+                         , curveTo (P2 60 50) (P2 50 60) (P2 40 60)
+                         , curveTo (P2 30 60) (P2 20 50) (P2 20 30)
+                         , lineTo  (P2 20 0)
+                         ]

@@ -17,15 +17,14 @@     writeSVG_latin1 "./out/font_metrics.svg" metrics_pic  --peru :: PSRgb-peru = RGB3 0.804  0.522  0.247+peru :: RGBi+peru = RGBi 205  133  63 -plum :: PSRgb-plum = RGB3 0.867  0.627  0.867+plum :: RGBi+plum = RGBi 221  160  221 -black :: PSRgb-black = RGB3 0 0 0 +black :: RGBi+black = RGBi 0 0 0   courier_attr :: FontAttr courier_attr = FontAttr 48 (FontFace "Courier" "Courier New" SVG_REGULAR)@@ -34,7 +33,7 @@ metrics_pic = char_pic `picOver` lines_pic  lines_pic   :: DPicture-lines_pic   = frameMulti $ +lines_pic   = frame $      [ ascender_line, numeral_line, xheight_line, baseline, descender_line ]   where     descender_pos   = 0 - courier48_descender_depth@@ -48,7 +47,7 @@   char_pic :: Picture Double-char_pic = frameMulti $ zipWith ($) chars (iterate (.+^ hvec 32) zeroPt)+char_pic = frame $ zipWith ($) chars (iterate (.+^ hvec 32) zeroPt)   where     chars = (map letter "ABXabdgjxy12") ++ [agraveU] @@ -64,10 +63,10 @@ letter ch pt = textlabel (black, courier_attr) [ch] pt  -vertLine :: DRGB -> Double -> DPoint2 -> DPrimitive+vertLine :: RGBi -> Double -> DPoint2 -> DPrimitive vertLine rgb height pt = ostroke rgb $ vertexPath [pt, pt .+^ vvec height] -haxis :: DRGB -> PtSize -> DPrimitive+haxis :: RGBi -> PtSize -> DPrimitive haxis rgb ypos =      ostroke (rgb, dash_attr) $ vertexPath [ pt, pt .+^ hvec 440 ]   where

@@ -12,10 +12,10 @@   drawBounds :: (Floating u, Real u, FromPtSize u) => Picture u -> Picture u-drawBounds p        = p `picOver` (frame $ cstroke () ph) +drawBounds p        = p `picOver` (frame [cstroke () ph])   where     ph            = vertexPath $ [bl,br,tr,tl]-    (bl,br,tr,tl) = corners $ boundary p+    (bl,br,tr,tl) = boundaryCorners $ boundary p   -- | The center of a picture.@@ -28,22 +28,21 @@  -------------------------------------------------------------------------------- --peru :: PSRgb-peru = RGB3 0.804  0.522  0.247+peru :: RGBi+peru = RGBi 205  133  63 -plum :: PSRgb-plum = RGB3 0.867  0.627  0.867+plum :: RGBi+plum = RGBi 221  160  221 -black :: PSRgb-black = RGB3 0 0 0 +black :: RGBi+black = RGBi 0 0 0     lbl1 :: Picture Double lbl1 = line1 `picBeside` line2 where-  line1 = frame (textlabel attrs "Hello" zeroPt)-  line2 = frame (textlabel attrs "World" zeroPt)+  line1 = frame [textlabel attrs "Hello" zeroPt]+  line2 = frame [textlabel attrs "World" zeroPt]   attrs = (peru, FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR))   @@ -90,8 +89,8 @@ bigB = bigLetter peru  'B' bigT = bigLetter plum  'T' -bigLetter :: PSRgb -> Char -> Picture Double-bigLetter col ch = uniformScale 5 $ frame $ textlabel attrs [ch] zeroPt+bigLetter :: RGBi -> Char -> Picture Double+bigLetter col ch = uniformScale 5 $ frame [textlabel attrs [ch] zeroPt]   where     attrs = (col, FontAttr 12 (FontFace "Helvetica" "Helvetica" SVG_REGULAR))  

@@ -18,7 +18,7 @@   pic1 :: DPicture-pic1 = uniformScale 2 $ frameMulti $ +pic1 = uniformScale 2 $ frame $      [ ellipse blue 10 10 zeroPt     , ellipse red 10 10 (P2 40 40)     , ztextlabel "Wumpus!" (P2 40 20)@@ -26,7 +26,7 @@     ]  -square :: (Num u, Ord u) => DRGB -> u -> Point2 u -> Primitive 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] 

@@ -28,7 +28,7 @@   pic1 :: DPicture-pic1 = illustrateBounds grey $ frameMulti $ +pic1 = illustrateBounds grey $ frame $      [ rotatePrimitive deg45 $ square blue 50 (P2 100 100)     , square red 50 (P2 100 100)     ]@@ -37,7 +37,7 @@  -- both ellipses should share the same center pic2 :: DPicture-pic2 = illustrateBounds grey $ frameMulti $ +pic2 = illustrateBounds grey $ frame $      [ rotatePrimitive deg45 $ ellipseHH blue 25 (P2 100 100)     , ellipseHH red 25 (P2 100 100)     ]@@ -45,26 +45,26 @@  -- both labels should share the same bottom left corner pic3 :: DPicture-pic3 = illustrateBounds grey $ frameMulti $ +pic3 = illustrateBounds grey $ frame $      [ rotatePrimitive deg45 $  label blue (P2 100 100)     , label red (P2 100 100)     ]  -square :: (Num u, Ord u) => DRGB -> u -> Point2 u -> Primitive 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]   -ellipseHH :: Fractional u => DRGB -> u -> Point2 u -> Primitive u+ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr  -label :: Num u => DRGB -> Point2 u -> Primitive u+label :: Num u => RGBi -> Point2 u -> Primitive u label rgb bl = textlabel rgb "Wumpus" bl  -grey :: DRGB-grey = iRGB3 176 197 223+grey :: RGBi+grey = RGBi 176 197 223  

@@ -23,7 +23,7 @@ -- both squares should share the bottom left corner  pic1 :: DPicture-pic1 = illustrateBounds grey $ frameMulti $ +pic1 = illustrateBounds grey $ frame $      [ uniformScalePrimitive 0.5 $ square blue 50 (P2 100 100)     , square red 50 (P2 100 100)     ]@@ -31,7 +31,7 @@  -- both ellipses should share the same center pic2 :: DPicture-pic2 = illustrateBounds grey $ frameMulti $ +pic2 = illustrateBounds grey $ frame $      [ uniformScalePrimitive 0.5 $ ellipseHH blue 25 (P2 100 100)     , ellipseHH red 25 (P2 100 100)     ]@@ -39,25 +39,25 @@  -- both labels should share the same bottom left corner pic3 :: DPicture-pic3 = illustrateBounds grey $ frameMulti $+pic3 = illustrateBounds grey $ frame $     [ uniformScalePrimitive 0.5 $ label blue (P2 100 100)     , label red (P2 100 100)     ]   -square :: (Num u, Ord u) => DRGB -> u -> Point2 u -> Primitive 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] -ellipseHH :: Fractional u => DRGB -> u -> Point2 u -> Primitive u+ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr  -label :: Num u => DRGB -> Point2 u -> Primitive u+label :: Num u => RGBi -> Point2 u -> Primitive u label rgb bl = textlabel rgb "Wumpus" bl  -grey :: DRGB-grey = iRGB3 176 197 223+grey :: RGBi+grey = RGBi 176 197 223  

@@ -22,38 +22,38 @@  -- both squares should share the bottom left coord... pic1 :: DPicture-pic1 = illustrateBounds grey $ frameMulti $ +pic1 = illustrateBounds grey $ frame $      [ translatePrimitive 100 10 $ square blue 50 (P2 100 100)     , square red 50 (P2 100 100)     ]  pic2 :: DPicture-pic2 = illustrateBounds grey $ frameMulti $ +pic2 = illustrateBounds grey $ frame $      [ translatePrimitive 100 10 $ ellipseHH blue 25 (P2 100 100)     , ellipseHH red 25 (P2 100 100)     ]  pic3 :: DPicture-pic3 = illustrateBounds grey $ frameMulti $ +pic3 = illustrateBounds grey $ frame $      [ translatePrimitive 100 10 $ label blue (P2 100 100)     , label red (P2 100 100)     ]   -square :: (Num u, Ord u) => DRGB -> u -> Point2 u -> Primitive 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] -ellipseHH :: Fractional u => DRGB -> u -> Point2 u -> Primitive u+ellipseHH :: Fractional u => RGBi -> u -> Point2 u -> Primitive u ellipseHH rgb radius ctr = ellipse rgb radius (0.5*radius) ctr  -label :: Num u => DRGB -> Point2 u -> Primitive u+label :: Num u => RGBi -> Point2 u -> Primitive u label rgb bl = textlabel rgb "Wumpus" bl  -grey :: DRGB-grey = iRGB3 176 197 223+grey :: RGBi+grey = RGBi 176 197 223   

@@ -0,0 +1,35 @@+{-# OPTIONS -Wall #-}++module ZOrderPic 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/zorder01.eps" combined_pic+    writeSVG_latin1 "./out/zorder01.svg" combined_pic+++combined_pic :: DPicture+combined_pic = multi [pic1,pic2]++pic1 :: DPicture+pic1 = frame $ prim_list zeroPt++pic2 :: DPicture +pic2 = multi $ map (\a -> frame [a]) $ prim_list (P2 200 0)++++prim_list :: DPoint2 -> [DPrimitive]+prim_list = sequence [ ellipse red   20 20+                     , \p -> ellipse green 20 20 (p .+^ hvec 20)+                     , \p -> ellipse blue  20 20 (p .+^ hvec 40)+                     ]+

@@ -164,25 +164,22 @@ 
 Once labels and paths are assembled as a \emph{Picture} they are
 transformable with the usual affine transformations (scaling, 
-rotation, translation) and multiple pictures can be composed with
-the operations provided by the \texttt{PictureLanguage} module.
-The operations should be largely familiar from pretty-printing 
-libraries although here they are extended to 2 dimensions.
+rotation, translation).
 
 Once assembled into pictures graphics properties (e.g. colour) 
 are opaque - it is not possible to write a transformation function
 that turns a picture blue. In some ways this is a limitation - 
 for instance, the \texttt{Diagrams} library appears to support 
-some notion of attribute overriding; however it is conceptually 
-simple. If one wanted to make blue arrows or red arrows with 
-\wumpuscore one would make colour a parameter of the arrow 
-creating function.
+some notion of attribute overriding; however it does keep 
+\wumpuscore conceptually simple. If one wanted to draw blue or red 
+arrows with \wumpuscore, one would make drawing colour a parameter 
+of the arrow creation function.
 
 %-----------------------------------------------------------------
 \section{Affine transformations}
 %-----------------------------------------------------------------
 
-For affine transformations Wumpus uses the \texttt{Matrix3} data 
+For affine transformations Wumpus uses the \texttt{Matrix3'3} data 
 type to represent 3x3 matrices in row-major form. The constructor
  \texttt{(M3'3 a b c  d e f  g h i)} builds this matrix:
 
@@ -220,7 +217,7 @@ not be very helpful in practice. Internally \wumpuscore only 
 performs the transformation on the pictures bounding box - it 
 needs to do this so transformed pictures can still be composed 
-with the picture language operations.
+with the \texttt{picBeside} combinator.
 
 PostScript uses column-major form and uses a six element matrix
 rather than a nine element one. The translation matrix above 
@@ -231,7 +228,7 @@ \end{verbatim}
 
 Similarly, it would be communicated to SVG via a 
-\texttt{<g ...> </g>} element:
+\texttt{group} element:
 
 \begin{verbatim}
 <g transform="matrix(1.0, 0.0, 0.0, 1.0, 10.0, 20.0)"> ... </g>
@@ -239,11 +236,12 @@ 
 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.
-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.
+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.
 
 
 %-----------------------------------------------------------------
@@ -255,20 +253,21 @@ label's string rather than the metrics of the individual letters 
 encoded in the font. Accessing the glyph metrics in a font would 
 require a font loader to read TrueType font files. This would be 
-a significant effort, probably larger than the effort put into 
-\wumpuscore itself; for \wumpuscore's intended use - producing 
-diagrams and pictures rather than high quality text - its 
-primitive font handling is not such a draw back.
+a significant development effort, probably larger than the effort 
+put into \wumpuscore itself; for \wumpuscore's intended use - 
+producing diagrams and pictures rather than high quality text - 
+its primitive font handling is not such a draw back.
 
 
 In both PostScript and SVG mis-named fonts can cause somewhat
 inscrutable printing anomalies - usually falling back to a default 
-font but not always. PostScript may do no subsequent drawing after
-a font load error. \wumpuscore uses @scalefont@ in the generated
-PostScript, this semingly works for any integer size and not just
-the regular font sizes (10, 12, 18, 24, 36). Older versions of
-\wumpuscore mention that using non-standard sizes may cause font
-loading problems, however this does not appear to be the case.
+font but not always. At worst, PostScript may do no subsequent 
+drawing after a font load error. \wumpuscore uses @scalefont@ in 
+the generated PostScript, this semingly works for any integer size 
+and not just the regular font sizes (10, 12, 18, 24, 36). Older 
+versions of \wumpuscore mention that using non-standard sizes may 
+cause font loading problems, however this does not appear to be 
+the case.
 
 
 The following table lists PostScript fonts and their SVG 

@@ -9,3 +9,5 @@ 	dvipdfm -o ./out/Guide.pdf ./out/Guide.dvi  	cp ./out/Guide.pdf ../doc +worldframe: WorldFrame.hs+	runhaskell -i../src WorldFrame.hs

@@ -11,9 +11,9 @@  world_frame :: DPicture world_frame = uniformScale 0.75 $ -    frameMulti [ ogin, btm_right, top_left, top_right-               , x_axis, y_axis, line1-               ]+    frame [ ogin, btm_right, top_left, top_right+          , x_axis, y_axis, line1+          ]   where     ogin      = makeLabelPrim "(0,0)"     (P2 0  0)     btm_right = makeLabelPrim "(100,0)"   (P2 96 0)@@ -29,7 +29,7 @@ makeLabelPrim :: String -> DPoint2 -> DPrimitive makeLabelPrim = textlabel attrs    where-    attrs     = (black, FontAttr "Helvetica" "Helvetica" SVG_REGULAR 10)+    attrs     = (black, FontAttr 10 (FontFace "Helvetica" "Helvetica" SVG_REGULAR))  makeLinePrim :: Double -> DPoint2 -> DPoint2 -> DPrimitive makeLinePrim lw a b = ostroke attrs $ path a [lineTo b]

binary file changed (57135 → 56990 bytes)

@@ -8,7 +8,7 @@ -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  unstable --- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Common interface to Wumpus.Core. --@@ -75,7 +75,7 @@ import Wumpus.Core.Colour hiding ( black, white, red, green, blue ) import Wumpus.Core.FontSize import Wumpus.Core.Geometry-import Wumpus.Core.GraphicsState hiding ( CTM, ToCTM )+import Wumpus.Core.GraphicsState hiding ( GraphicsState ) import Wumpus.Core.OutputPostScript import Wumpus.Core.OutputSVG import Wumpus.Core.Picture

@@ -11,7 +11,7 @@ -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Affine transformations. -- @@ -31,7 +31,7 @@ --  -- To generate efficient PostScript, Wumpus relies on the matrix -- representations of the affine transformations being invertible.--- Please do not scale elements by zero.+-- Do not scale elements by zero! -- -------------------------------------------------------------------------------- @@ -77,7 +77,8 @@ -------------------------------------------------------------------------------- -- Affine transformations  --- | Apply a matrix trasnformation directly.+-- | Apply a matrix transformation directly.+-- class Transform t where   transform :: u ~ DUnit t => Matrix3'3 u -> t -> t @@ -103,6 +104,7 @@   -- | Type class for rotation about a point.+-- class RotateAbout t where   rotateAbout :: u ~ DUnit t =>  Radian -> Point2 u -> t -> t  @@ -118,27 +120,29 @@ -- Scale  -- | Type class for scaling.+-- class Scale t where   scale :: u ~ DUnit t => u -> u -> t -> t  instance Num u => Scale (Point2 u) where-  scale x y = ((scalingMatrix x y) *#) +  scale sx sy = ((scalingMatrix sx sy) *#)   instance Num u => Scale (Vec2 u) where-  scale x y = ((scalingMatrix x y) *#) +  scale sx sy = ((scalingMatrix sx sy) *#)   -------------------------------------------------------------------------------- -- Translate --- | Type class for translations.+-- | Type class for translation.+-- class Translate t where   translate :: DUnit t -> DUnit t -> t -> t  instance Num u => Translate (Point2 u) where-  translate x y = ((translationMatrix x y) *#)+  translate dx dy (P2 x y) = P2 (x+dx) (y+dy)  instance Num u => Translate (Vec2 u) where-  translate x y = ((translationMatrix x y) *#)+  translate dx dy (V2 x y) = V2 (x+dx) (y+dy)   -------------------------------------------------------------------------------- @@ -147,42 +151,52 @@   -- | Rotate by 30 degrees about the origin. +-- rotate30 :: Rotate t => t -> t  rotate30 = rotate (pi/6)   -- | Rotate by 30 degrees about the supplied point.+-- rotate30About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate30About = rotateAbout (pi/6)  -- | Rotate by 45 degrees about the origin. +-- rotate45 :: Rotate t => t -> t  rotate45 = rotate (pi/4)   -- | Rotate by 45 degrees about the supplied point.+-- rotate45About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate45About = rotateAbout (pi/4)  -- | Rotate by 60 degrees about the origin. +-- rotate60 :: Rotate t => t -> t  rotate60 = rotate (2*pi/3)   -- | Rotate by 60 degrees about the supplied point.+-- rotate60About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate60About = rotateAbout (2*pi/3)  -- | Rotate by 90 degrees about the origin. +-- rotate90 :: Rotate t => t -> t  rotate90 = rotate (pi/2)   -- | Rotate by 90 degrees about the supplied point.+-- rotate90About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate90About = rotateAbout (pi/2)  -- | Rotate by 120 degrees about the origin. +-- rotate120 :: Rotate t => t -> t  rotate120 = rotate (4*pi/3)   -- | Rotate by 120 degrees about the supplied point.+-- rotate120About :: (RotateAbout t, DUnit t ~ u) => Point2 u -> t -> t  rotate120About = rotateAbout (4*pi/3) @@ -192,21 +206,25 @@ -- Common scalings  -- | Scale both x and y dimensions by the same amount.+-- uniformScale :: (Scale t, DUnit t ~ u) => u -> t -> t  uniformScale a = scale a a   -- | Reflect in the X-plane about the origin.+-- reflectX :: (Num u, Scale t, DUnit t ~ u) => t -> t reflectX = scale (-1) 1  -- | Reflect in the Y-plane about the origin.+-- reflectY :: (Num u, Scale t, DUnit t ~ u) => t -> t reflectY = scale 1 (-1)  ----------------------------------------------------------------------------------- translations+-- Translations  -- | Translate by the x and y components of a vector.+-- translateBy :: (Translate t, DUnit t ~ u) => Vec2 u -> t -> t  translateBy (V2 x y) = translate x y @@ -215,11 +233,13 @@ -- Translation and scaling  -- | Reflect in the X plane that intersects the supplied point. +-- reflectXPlane :: (Num u, Scale t, Translate t, u ~ DUnit t)                => Point2 u -> t -> t reflectXPlane (P2 x y) = translate x y . scale (-1) 1 . translate (-x) (-y)  -- | Reflect in the Y plane that intersects the supplied point.+-- reflectYPlane :: (Num u, Scale t, Translate t, u ~ DUnit t)                => Point2 u -> t -> t reflectYPlane (P2 x y) = translate x y . scale 1 (-1) . translate (-x) (-y)

@@ -9,7 +9,7 @@ -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Bounding box with no notion of \'empty\'. --@@ -17,10 +17,6 @@ -- simplifies the implementation of pictures themselves and -- bounding boxes. -- --- WARNING - this module is no so tightly designed, with some --- of the functions seeming superfluous in hindsight. It is--- likely to change in the future.---  --------------------------------------------------------------------------------  module Wumpus.Core.BoundingBox @@ -35,32 +31,26 @@   -- * Operations   , bbox   , obbox-  , union +  , destBoundingBox+  , boundaryUnion    , traceBoundary   , retraceBoundary -  , corners-  , within+  , boundaryCorners+  , withinBoundary   , boundaryWidth   , boundaryHeight-  , boundaryBottomLeft-  , boundaryTopRight-  , boundaryTopLeft-  , boundaryBottomRight -  , leftPlane-  , rightPlane-  , lowerPlane-  , upperPlane +   ) where  import Wumpus.Core.AffineTrans+import Wumpus.Core.FormatCombinators import Wumpus.Core.Geometry--import Data.Semigroup+import Wumpus.Core.Utils ( PSUnit(..) ) -import Text.PrettyPrint.Leijen hiding ( width )+import Data.Semigroup                               -- package: algebra   @@ -87,11 +77,12 @@ -- BBox is NOT monoidal - it\'s much simpler that way.  instance Ord u => Semigroup (BoundingBox u) where-  append = union+  append = boundaryUnion  -instance Pretty u => Pretty (BoundingBox u) where-  pretty (BBox p0 p1) = text "|_" <+> pretty p0 <+> pretty p1 <+> text "_|" +instance PSUnit u => Format (BoundingBox u) where+  format (BBox p0 p1) = parens (text "BBox" <+> text "ll=" <> format p0 +                                            <+> text "ur=" <> format p1)    --------------------------------------------------------------------------------@@ -99,10 +90,27 @@  type instance DUnit (BoundingBox u) = u +pointTransform :: (Num u , Ord u)+               => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u+pointTransform fn bb = traceBoundary $ map fn $ [bl,br,tr,tl]+    where +      (bl,br,tr,tl) = boundaryCorners bb+++instance (Num u, Ord u) => Transform (BoundingBox u) where+  transform mtrx = pointTransform  (mtrx *#)++instance (Real u, Floating u) => Rotate (BoundingBox u) where+  rotate theta = pointTransform (rotate theta)++instance (Real u, Floating u) => RotateAbout (BoundingBox u) where+  rotateAbout theta pt = pointTransform (rotateAbout theta pt)+ instance (Num u, Ord u) => Scale (BoundingBox u) where-  scale x y bb     = traceBoundary $ map (scale x y) $ [bl,br,tr,tl]-    where (bl,br,tr,tl) = corners bb+  scale sx sy = pointTransform (scale sx sy) +instance (Num u, Ord u) => Translate (BoundingBox u) where+  translate dx dy = pointTransform (translate dx dy)   --------------------------------------------------------------------------------@@ -111,16 +119,8 @@ -- | Type class extracting the bounding box of an object -  -- Picture, Path etc. ---class Boundary a where-  boundary :: DUnit a ~ u => a -> BoundingBox u --------------------------------------------------------------------------------------instance Pointwise (BoundingBox u) where-  type Pt (BoundingBox u) = Point2 u-  pointwise f (BBox bl tr) = BBox (f bl) (f tr)+class Boundary t where+  boundary :: u ~ DUnit t => t -> BoundingBox u    --------------------------------------------------------------------------------@@ -143,12 +143,22 @@ obbox :: Num u => u -> u -> BoundingBox u obbox w h = BBox zeroPt (P2 w h) +-- | Destructor for BoundingBox.+--+-- Assembles a four-tuple @ (ll_x, ll_y, ur_x, ur_y) @.+-- +-- 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. ---union :: Ord u => BoundingBox u -> BoundingBox u -> BoundingBox u-BBox ll ur `union` BBox ll' ur' = BBox (minPt ll ll') (maxPt ur ur')+boundaryUnion :: Ord u => BoundingBox u -> BoundingBox u -> BoundingBox u+BBox ll ur `boundaryUnion` BBox ll' ur' = BBox (minPt ll ll') (maxPt ur ur')  -- | Trace a list of points, retuning the BoundingBox that  -- includes them.@@ -170,22 +180,22 @@ -- retraceBoundary :: (Num u, Ord u)          => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u-retraceBoundary f = traceBoundary . map f . fromCorners . corners+retraceBoundary f = traceBoundary . map f . fromCorners . boundaryCorners   where     fromCorners (bl,br,tr,tl) = [bl,br,tr,tl]   -- | Generate all the corners of a bounding box, counter-clock  -- wise from the bottom left, i.e. @(bl, br, tr, tl)@.-corners :: BoundingBox u -> (Point2 u, Point2 u, Point2 u, Point2 u)-corners (BBox bl@(P2 x0 y0) tr@(P2 x1 y1)) = (bl, br, tr, tl) where+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     tl = P2 x0 y1  -- | Within test - is the supplied point within the bounding box? ---within :: Ord u => Point2 u -> BoundingBox u -> Bool-within p (BBox ll ur) = (minPt p ll) == ll && (maxPt p ur) == ur+withinBoundary :: Ord u => Point2 u -> BoundingBox u -> Bool+withinBoundary p (BBox ll ur) = (minPt p ll) == ll && (maxPt p ur) == ur  -- | Extract the width of a bounding box. --@@ -196,54 +206,6 @@ -- boundaryHeight :: Num u => BoundingBox u -> u boundaryHeight (BBox (P2 _ ymin) (P2 _ ymax)) = ymax - ymin--------------------------------------------------------------------------------------- Points on the boundary---- | Extract the bottom-left corner of the bounding box.-boundaryBottomLeft  :: BoundingBox u -> Point2 u-boundaryBottomLeft (BBox p0 _ ) = p0---- | Extract the top-right corner of the bounding box.-boundaryTopRight :: BoundingBox u -> Point2 u-boundaryTopRight (BBox _ p1) = p1---- | Extract the top-left corner of the bounding box.-boundaryTopLeft :: BoundingBox u -> Point2 u-boundaryTopLeft (BBox (P2 x _) (P2 _ y)) = P2 x y---- | Extract the bottom-right corner of the bounding box.-boundaryBottomRight :: BoundingBox u -> Point2 u-boundaryBottomRight (BBox (P2 _ y) (P2 x _)) = P2 x y----------------------------------------------------------------------------------------- /planes/ on the bounding box---- Are these really worthwhile ? ...---- | Extract the unit of the left vertical plane.-leftPlane :: BoundingBox u -> u-leftPlane (BBox (P2 l _) _) = l---- | Extract the unit of the right vertical plane.-rightPlane :: BoundingBox u -> u-rightPlane (BBox _ (P2 r _)) = r---- | Extract the unit of the lower horizontal plane.-lowerPlane :: BoundingBox u -> u-lowerPlane (BBox (P2 _ l) _) = l---- | Extract the unit of the upper horizontal plane.-upperPlane :: BoundingBox u -> u-upperPlane (BBox _ (P2 _ u)) = u--   

@@ -1,5 +1,3 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -8,288 +6,88 @@ -- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 ----- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more--------- RGB, HSB, Gray colour types, and conversions between them.------ Internally Wumpus uses @RGB3 Double@ with range [0.0, 1..0] --- as the colour type. All colour values in the generated SVG or --- PostScript files will be RGB.+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC ----- Colour have Num instances for convenience, though the --- operations of @Data.VectorSpace@ (instances also defined) --- seem more approriate.+-- Colour represented as RGB with each component in the range +-- [0..255].+-- +-- Note - the predifined colours are hidden when importing the+-- /top-level/ module @Wumpus.Core@, import this module directly+-- to use them. -- --------------------------------------------------------------------------------  -module Wumpus.Core.Colour -  (-  -- * Colour types-    RGB3(..)-  , DRGB-  , HSB3(..)-  , DHSB-  , Gray(..)-  , DGray--  -- * Utility constructor-  , iRGB3-  , iHSB3-  , iGray-  -  -- * Operations-  , rgb2hsb-  , hsb2rgb+module Wumpus.Core.Colour+  (  -  , rgb2gray-  , gray2rgb+  -- * RGB colour type  +    RGBi(..) -  , hsb2gray-  , gray2hsb-     -- * Predefined colours   , black   , white   , red   , green   , blue-+       ) where -import Wumpus.Core.Utils---import Data.VectorSpace+import Wumpus.Core.FormatCombinators --- | Red-Green-Blue - no alpha.----data RGB3 a = RGB3 !a !a !a-  deriving (Eq,Show)+import Data.Word --- | RGB representated by Double - values should be in the range--- 0.0 to 1.0. +-- | Colours levels are in the range [0..255] -- --- 1.0 represents full saturation, for instance red is --- 1.0, 0.0, 0.0.----type DRGB = RGB3 Double----- | Hue-Saturation-Brightness.+-- Note - this is the format used by SVG, whereas PostScript uses +-- [0..1].  ---data HSB3 a = HSB3 !a !a !a -  deriving (Eq,Show)---- | HSB represented by Double - values should be in the range--- 0.0 to 1.0.+-- It is more efficient to prefer SVG here. ---type DHSB = HSB3 Double ---- | Gray scale.--- -newtype Gray a = Gray a-  deriving (Eq,Num,Fractional,Ord,Show)---- | Gray represented by a Double - values should be in the range--- 0.0 (black) to 1.0 (white).-type DGray = Gray Double+data RGBi = RGBi !Word8 !Word8 !Word8+  deriving (Eq,Ord,Show)   ----------------------------------------------------------------------------------- Num instances--instance Num a => Num (RGB3 a) where-  (+) (RGB3 a b c) (RGB3 x y z) = RGB3 (a+x) (b+y) (c+z)-  (-) (RGB3 a b c) (RGB3 x y z) = RGB3 (a-x) (b-y) (c-z)-  (*) (RGB3 a b c) (RGB3 x y z) = RGB3 (a*x) (b*y) (c*z)-  abs (RGB3 a b c)            = RGB3 (abs a) (abs b) (abs c)-  negate (RGB3 a b c)         = RGB3 (negate a) (negate b) (negate c)-  signum (RGB3 a b c)         = RGB3 (signum a) (signum b) (signum c)-  fromInteger i = RGB3 (fromInteger i) (fromInteger i) (fromInteger i)---instance Num a => Num (HSB3 a) where-  (+) (HSB3 a b c) (HSB3 x y z) = HSB3 (a+x) (b+y) (c+z)-  (-) (HSB3 a b c) (HSB3 x y z) = HSB3 (a-x) (b-y) (c-z)-  (*) (HSB3 a b c) (HSB3 x y z) = HSB3 (a*x) (b*y) (c*z)-  abs (HSB3 a b c)            = HSB3 (abs a) (abs b) (abs c)-  negate (HSB3 a b c)         = HSB3 (negate a) (negate b) (negate c)-  signum (HSB3 a b c)         = HSB3 (signum a) (signum b) (signum c)-  fromInteger i = HSB3 (fromInteger i) (fromInteger i) (fromInteger i)---- Num (Gray a) derived---instance Fractional a => Fractional (RGB3 a) where-  (/) (RGB3 a b c) (RGB3 x y z) = RGB3 (a/x) (b/y) (c/z)-  recip (RGB3 a b c)            = RGB3 (recip a) (recip b) (recip c)-  fromRational a = RGB3 (fromRational a) (fromRational a) (fromRational a)+-- instances -instance Fractional a => Fractional (HSB3 a) where-  (/) (HSB3 a b c) (HSB3 x y z) = HSB3 (a/x) (b/y) (c/z)-  recip (HSB3 a b c)            = HSB3 (recip a) (recip b) (recip c)-  fromRational a = HSB3 (fromRational a) (fromRational a) (fromRational a)+instance Format RGBi where+  format (RGBi 0   0   0)    = text "*black*"+  format (RGBi 255 255 255)  = text "*white*"+  format (RGBi r   g   b)    = integral r <> comma <> integral g +                                            <> comma <> integral b  --- Fractional (Gray a) derived- ----------------------------------------------------------------------------------- Instances for VectorSpace - -instance Num a => AdditiveGroup (RGB3 a) where-  zeroV = RGB3 0 0 0-  (^+^) = (+)-  negateV = negate- -instance Num a => AdditiveGroup (HSB3 a) where-  zeroV = HSB3 0 0 0-  (^+^) = (+)-  negateV = negate -instance Num a => AdditiveGroup (Gray a) where-  zeroV = Gray 0                -- black-  (^+^) = (+)-  negateV = negate---instance Num a => VectorSpace (RGB3 a) where-  type Scalar (RGB3 a) = a-  s *^ (RGB3 a b c) = RGB3 (s*a) (s*b) (s*c)--instance Num a => VectorSpace (HSB3 a) where-  type Scalar (HSB3 a) = a-  s *^ (HSB3 a b c) = HSB3 (s*a) (s*b) (s*c)--instance Num a => VectorSpace (Gray a) where-  type Scalar (Gray a) = a-  s *^ (Gray a) = Gray (s*a)-------------------------------------------------------------------------------------- Utility constructors---- | 'iRGB3' : @ red -> green -> blue -> rgb @--- --- Create an RGB colour with intergers in the range [0..255].--- --- 255 represents full sturation so red will be @ 255 0 0 @.------ Integer values above 255 will be clamped to 255, similarly--- values below 0 will be clamped to 0.--- -iRGB3 :: (Fractional a, Ord a) => Int -> Int -> Int -> RGB3 a-iRGB3 r g b = RGB3 (rescaleZeroOne r) (rescaleZeroOne g) (rescaleZeroOne b)--iHSB3 :: (Fractional a, Ord a) => Int -> Int -> Int -> HSB3 a-iHSB3 h s b = HSB3 (rescaleZeroOne h) (rescaleZeroOne s) (rescaleZeroOne b)--iGray :: (Fractional a, Ord a) => Int -> Gray a-iGray i = Gray $ rescaleZeroOne i--rescaleZeroOne :: (Fractional a, Ord a) => Int -> a-rescaleZeroOne a = rescale (0,255.0) (0,1.0) (clamp 0 255 $ fromIntegral a)------------------------------------------------------------------------------------- Operations---vE :: DRGB-vE = RGB3 1 1 1---- Acknowledgment - the conversion functions are derived from--- the documentation to Dr. Uwe Kern's xcolor LaTeX package----- | Covert RGB \[0,1\] to HSB \[0,1\].-rgb2hsb :: DRGB -> DHSB-rgb2hsb (RGB3 r g b) = HSB3 hue sat bri-  where-    x     = max3 r g b-    y     = med3 r g b-    z     = min3 r g b--    bri   = x--    (sat,hue) = if x==z then (0,0) else ((x-z)/x, f $ (x-y)/(x-z))-    -    f n | r >= g && g >= b    = (1/6) * (1-n) -        | g >= r && r >= b    = (1/6) * (1+n)-        | g >= b && b >= r    = (1/6) * (3-n)-        | b >= g && g >= r    = (1/6) * (3+n)-        | b >= r && r >= g    = (1/6) * (5-n)-        | otherwise           = (1/6) * (5+n)----- | Covert HSB \[0,1\] to RGB \[0,1\].-hsb2rgb :: DHSB -> DRGB-hsb2rgb (HSB3 hue sat bri) = bri *^ (vE - (sat *^ fV))-  where-    i     :: Int-    i     = floor $ (6 * hue)-    f     = (6 * hue) - fromIntegral i-    fV    | i == 0    = RGB3  0     (1-f) 1 -          | i == 1    = RGB3  f     0     1-          | i == 2    = RGB3  1     0     (1-f)-          | i == 3    = RGB3  1     f     0-          | i == 4    = RGB3  (1-f) 1     0-          | i == 5    = RGB3  0     1     f-          | otherwise = RGB3  0     1     1-          --- | Covert RGB \[0,1\] to Gray \[0,1\].-rgb2gray :: DRGB -> DGray-rgb2gray (RGB3 r g b) = Gray $ 0.3 * r + 0.59 * g + 0.11 * b ----- | Covert Gray \[0,1\] to RGB \[0,1\].-gray2rgb :: DGray -> DRGB-gray2rgb (Gray a) = a *^ vE----- | Covert HSB \[0,1\] to Gray \[0,1\].-hsb2gray :: DHSB -> DGray-hsb2gray (HSB3 _ _ b) = Gray b ----- | Covert Gray \[0,1\] to HSB \[0,1\].-gray2hsb :: DGray -> DHSB-gray2hsb (Gray a) = HSB3 0 0 a-------------------------------------------------------------------------------------- -- Some colours  -- There will be name clashes with the X11Colours / SVGColours. --- | Black - 0.0, 0.0, 0.0.+-- | Black - 0, 0, 0. ---black :: DRGB-black = RGB3 0 0 0+black :: RGBi+black = RGBi 0 0 0 --- | White - 1.0, 1.0, 1.0.+-- | White - 255, 255, 255. ---white :: DRGB-white = RGB3 1 1 1+white :: RGBi+white = RGBi 255 255 255 --- | Red - 1.0, 0.0, 0.0.+-- | Red - 255, 0, 0. ---red :: DRGB-red = RGB3 1 0 0+red :: RGBi+red = RGBi 255 0 0 --- | Green - 0.0, 1.0, 0.0.+-- | Green - 0, 255, 0. ---green :: DRGB -green = RGB3 0 1 0+green :: RGBi +green = RGBi 0 255 0 --- | Blue - 0.0, 0.0, 1.0.+-- | Blue - 0, 0, 255. ---blue :: DRGB-blue = RGB3 0 0 1-+blue :: RGBi+blue = RGBi 0 0 255

@@ -8,7 +8,7 @@ -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Font size calculation for Label\'s and their bounding boxes. -- 

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

@@ -1,32 +1,31 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------+-------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Core.Geometry -- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 ----- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC -- -- Objects and operations for 2D geometry. -- --- Vector, point, affine frame, 3x3 matrix, and radian --- representations, plus a type family @DUnit@ for parameterizing--- type classes with some /dimension/.+-- Vector, point, 3x3 matrix, and radian representations, +-- plus a type family @DUnit@ for parameterizing type classes +-- with some /dimension/. -- -------------------------------------------------------------------------------- -module Wumpus.Core.Geometry ++module Wumpus.Core.Geometry   ( +   -- * Type family      DUnit   @@ -35,17 +34,11 @@   , DVec2   , Point2(..)   , DPoint2-  , Frame2(..)-  , DFrame2   , Matrix3'3(..)   , DMatrix3'3-  , Radian --  -- * Pointwise type class-  , Pointwise(..)+  , Radian -  -- * Matrix multiply type class   , MatrixMult(..)    -- * Vector operations@@ -60,18 +53,9 @@    -- * Point operations   , zeroPt-  , minPt   , maxPt-  , langle--  -- * Frame operations-  , ortho-  , displaceOrigin-  , pointInFrame-  , frame2Matrix-  , matrix2Frame-  , frameProduct-  , standardFrame+  , minPt+  , lineDirection    -- * Matrix contruction   , identityMatrix@@ -86,79 +70,71 @@   , transpose    -- * Radian operations-  , req   , toRadian   , fromRadian   , d2r   , r2d   , circularModulo -  -- * Bezier curves   , bezierArc   , bezierCircle    ) where -import Wumpus.Core.Utils ( PSUnit(..), oo ) +import Wumpus.Core.FormatCombinators+import Wumpus.Core.Utils -import Data.AffineSpace+import Data.AffineSpace                         -- package: vector-space import Data.VectorSpace -import Text.PrettyPrint.Leijen hiding ( langle ) -import Data.Function ( on )-import Data.Monoid  + --------------------------------------------------------------------------------  -- | Some unit of dimension usually double.-+--+-- This very useful for reducing the kind of type classes to *.+-- +-- Doing this then allows constraints on the Unit type on the +-- instances rather than in the class declaration.+--  type family DUnit a :: *   + -- Datatypes   -- | 2D Vector - both components are strict. ---data Vec2 u = V2 !u !u+data Vec2 u = V2 +      { vector_x :: !u +      , vector_y :: !u+      }   deriving (Eq,Show)  type DVec2 = Vec2 Double ++ -- | 2D Point - both components are strict. --  -- Note - Point2 derives Ord so it can be used as a key in  -- Data.Map etc. ---data Point2 u = P2 !u !u+data Point2 u = P2 +      { point_x    :: !u+      , point_y    :: !u+      }   deriving (Eq,Ord,Show)  type DPoint2 = Point2 Double   --- | A two dimensional frame.--- --- The components are the two basis vectors @e0@ and @e1@ and --- the origin @o@.------ Typically these names for the elements will be used:------ > Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)--- --data Frame2 u = Frame2 (Vec2 u) (Vec2 u) (Point2 u)-  deriving (Eq,Show)--type DFrame2 = Frame2 Double----- -- | 3x3 matrix, considered to be in row-major form. --  -- > (M3'3 a b c@@ -199,22 +175,20 @@ type DMatrix3'3 = Matrix3'3 Double  - -- | Radian is represented with a distinct type.  -- Equality and ordering are approximate where the epsilon  -- is 0.0001. newtype Radian = Radian { getRadian :: Double }   deriving (Num,Real,Fractional,Floating,RealFrac,RealFloat) - -------------------------------------------------------------------------------- -- Family instances  type instance DUnit (Point2 u)    = u type instance DUnit (Vec2 u)      = u-type instance DUnit (Frame2 u)    = u type instance DUnit (Matrix3'3 u) = u + -------------------------------------------------------------------------------- -- lifters / convertors @@ -222,7 +196,6 @@ lift2Vec2 op (V2 x y) (V2 x' y') = V2 (x `op` x') (y `op` y')  - lift2Matrix3'3 :: (u -> u -> u) -> Matrix3'3 u -> Matrix3'3 u -> Matrix3'3 u lift2Matrix3'3 op (M3'3 a b c d e f g h i) (M3'3 m n o p q r s t u) =        M3'3 (a `op` m) (b `op` n) (c `op` o)  @@ -230,7 +203,6 @@            (g `op` s) (h `op` t) (i `op` u)  - -------------------------------------------------------------------------------- -- instances @@ -245,24 +217,8 @@   instance Functor Matrix3'3 where-  fmap f (M3'3 m n o p q r s t u) = -    M3'3 (f m) (f n) (f o) (f p) (f q) (f r) (f s) (f t) (f u)----- Monoid---- Vectors have a sensible Monoid instance as addition, points don't--instance Num u => Monoid (Vec2 u) where-  mempty  = V2 0 0-  mappend = lift2Vec2 (+) ----- Affine frames also have a sensible Monoid instance--instance (Num u, InnerSpace (Vec2 u)) => Monoid (Frame2 u) where-  mempty = ortho zeroPt-  mappend = frameProduct+  fmap f (M3'3 m n o   p q r   s t u) = +    M3'3 (f m) (f n) (f o)   (f p) (f q) (f r)   (f s) (f t) (f u)   -- Show@@ -289,6 +245,7 @@   signum = fmap signum   fromInteger a = M3'3 a' a' a'  a' a' a'  a' a' a' where a' = fromInteger a  +-------------------------------------------------------------------------------- -- Instances for Radian which are 'special'.  instance Show Radian where@@ -300,32 +257,28 @@   compare a b | a `req` b = EQ               | otherwise = getRadian a `compare` getRadian b ++ -------------------------------------------------------------------------------- -- Pretty printing -instance Pretty u => Pretty (Vec2 u) where-  pretty (V2 a b) = angles (char '|' <+> pretty a <+> pretty b <+> char '|')--instance Pretty u => Pretty (Point2 u) where-  pretty (P2 a b) = brackets (char '|' <+> pretty a <+> pretty b <+> char '|')+instance PSUnit u => Format (Vec2 u) where+  format (V2 a b) = parens (text "Vec" <+> dtruncFmt a <+> dtruncFmt b) -instance Pretty u => Pretty (Frame2 u) where-  pretty (Frame2 e0 e1 o) = braces $-        text "e0:" <> pretty e0-    <+> text "e1:" <> pretty e1-    <+> text "o:" <> pretty o+instance PSUnit u => Format (Point2 u) where+  format (P2 a b) = parens (dtruncFmt a <> comma <+> dtruncFmt b) -instance PSUnit u => Pretty (Matrix3'3 u) where-  pretty (M3'3 a b c  d e f  g h i) = -      matline a b c <$> matline d e f <$> matline g h i+instance PSUnit u => Format (Matrix3'3 u) where+  format (M3'3 a b c  d e f  g h i) = +      vcat [matline a b c, matline d e f, matline g h i]     where       matline x y z = char '|' -         <+> (hcat $ map (fill 12 . text . dtrunc) [x,y,z]) +         <+> (hcat $ map (fill 12 . dtruncFmt) [x,y,z])           <+> char '|'     -instance Pretty Radian where-  pretty (Radian d) = double d <> text ":rad"+instance Format Radian where+  format (Radian d) = double d <> text ":rad"  -------------------------------------------------------------------------------- -- Vector space instances@@ -342,12 +295,12 @@   -- scalar (dot / inner) product via the class InnerSpace-+-- -- This definition mandates UndecidableInstances, but this seems -- in line with Data.VectorSpace... -- -instance (Num u, InnerSpace u, Scalar u ~ u) +instance (Num u, InnerSpace u, u ~ Scalar u)      => InnerSpace (Vec2 u) where   (V2 a b) <.> (V2 a' b') = (a <.> a') ^+^ (b <.> b') @@ -368,38 +321,11 @@   type Scalar (Matrix3'3 u) = u   s *^ m = fmap (s*) m  --------------------------------------------------------------------------------- --- | Pointwise is a Functor like type class, except that the --- container/element relationship is defined via an associated --- type rather than a type parameter. This means that applied --- function must be type preserving.----class Pointwise sh where-  type Pt sh :: *-  pointwise :: (Pt sh -> Pt sh) -> sh -> sh---instance Pointwise (a -> a) where-  type Pt (a->a) = a-  pointwise f pf = \a -> pf (f a)--instance Pointwise a => Pointwise [a] where -  type Pt [a] = Pt a-  pointwise f pts = map (pointwise f) pts --instance Pointwise (Vec2 u) where-  type Pt (Vec2 u) = Vec2 u-  pointwise f v = f v--instance Pointwise (Point2 u) where-  type Pt (Point2 u) = Point2 u-  pointwise f pt = f pt-- -------------------------------------------------------------------------------- -- Matrix multiply + infixr 7 *#   -- | Matrix multiplication - typically of points and vectors @@ -416,11 +342,13 @@ instance Num u => MatrixMult (Point2 u) where   (M3'3 a b c d e f _ _ _) *# (P2 m n) = P2 (a*m+b*n+c*1) (d*m+e*n+f*1) + -------------------------------------------------------------------------------- -- Vectors --- | A synonym for the constructor 'V2' with a Num constraint on --- the arguments.++-- | 'vec' - a synonym for the constructor 'V2' with a Num +-- constraint on the arguments. -- -- Essentially superfluous, but it can be slightly more  -- typographically pleasant when used in lists of vectors:@@ -445,14 +373,15 @@ vvec :: Num u => u -> Vec2 u vvec d = V2 0 d + -- | Construct a vector from an angle and magnitude. -- avec :: Floating u => Radian -> u -> Vec2 u-avec theta d = V2 x y where-  ang = fromRadian theta-  x   = d * cos ang-  y   = d * sin ang-+avec theta d = V2 x y +  where+    ang = fromRadian theta+    x   = d * cos ang+    y   = d * sin ang  -- | The vector between two points --@@ -465,7 +394,7 @@ -- from the x-axis. -- direction :: (Floating u, Real u) => Vec2 u -> Radian-direction (V2 x y) = langle (P2 0 0) (P2 x y)+direction (V2 x y) = lineDirection (P2 0 0) (P2 x y)  -- | Length of a vector. --@@ -476,8 +405,9 @@ -- vangle :: (Floating u, Real u, InnerSpace (Vec2 u))         => Vec2 u -> Vec2 u -> Radian-vangle u v = realToFrac $ acos $ (u <.> v) / (on (*) magnitude u v)+vangle u v = realToFrac $ acos $ (u <.> v) / (magnitude u * magnitude v) + -------------------------------------------------------------------------------- -- Points @@ -508,12 +438,11 @@ maxPt :: Ord u => Point2 u -> Point2 u -> Point2 u maxPt (P2 x y) (P2 x' y') = P2 (max x x') (max y y') - -- | Calculate the counter-clockwise angle between two points  -- and the x-axis. ---langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian-langle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1)+lineDirection :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian+lineDirection (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1)   where     -- north-east quadrant      step x y | pve x && pve y = toRadian $ atan (y/x)          @@ -530,81 +459,7 @@     pve a = signum a >= 0  - ----------------------------------------------------------------------------------- Frame operations---- | Create a frame with standard (orthonormal bases) at the --- supplied point.----ortho :: Num u => Point2 u -> Frame2 u-ortho o = Frame2 (V2 1 0) (V2 0 1) o---- | Displace the origin of the frame by the supplied vector.----displaceOrigin :: Num u => Vec2 u -> Frame2 u -> Frame2 u-displaceOrigin v (Frame2 e0 e1 o) = Frame2 e0 e1 (o.+^v)---- | \'World coordinate\' calculation of a point in the supplied--- frame.----pointInFrame :: Num u => Point2 u -> Frame2 u -> Point2 u-pointInFrame (P2 x y) (Frame2 vx vy o) = (o .+^ (vx ^* x)) .+^ (vy ^* y)  ---- | Concatenate the elements of the frame as columns forming a--- 3x3 matrix. Points and vectors are considered homogeneous --- coordinates - triples where the least element is either 0 --- indicating a vector or 1 indicating a point:------ > Frame (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)--- --- becomes------ > (M3'3 e0x e1x ox--- >       e0y e1y oy--- >        0   0   1  )-----frame2Matrix :: Num u =>  Frame2 u -> Matrix3'3 u-frame2Matrix (Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)) = -    M3'3 e0x e1x ox  -         e0y e1y oy -         0   0   1----- | Interpret the matrix as columns forming a frame.------ > (M3'3 e0x e1x ox--- >       e0y e1y oy--- >        0   0   1  )------ becomes------ > Frame (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)--- -matrix2Frame :: Matrix3'3 u -> Frame2 u-matrix2Frame (M3'3 e0x e1x ox -                   e0y e1y oy-                   _   _   _ ) = Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)----- | /Multiplication/ of frames to form their product.----frameProduct :: (Num u, InnerSpace (Vec2 u)) -             => Frame2 u -> Frame2 u -> Frame2 u-frameProduct = matrix2Frame `oo` on (*) frame2Matrix------ | Is the origin at (0,0) and are the basis vectors orthogonal --- with unit length?----standardFrame :: Num u => Frame2 u -> Bool-standardFrame (Frame2 (V2 1 0) (V2 0 1) (P2 0 0)) = True-standardFrame _                                   = False----------------------------------------------------------------------------------- -- Matrix construction  -- | Construct the identity matrix:@@ -743,36 +598,44 @@   ++ -------------------------------------------------------------------------------- -- Radians   -- | The epislion used for floating point equality on radians.+-- radian_epsilon :: Double radian_epsilon = 0.0001  -- | Equality on radians, this is the operation used for (==) in -- Radian\'s Eq instance.+-- req :: Radian -> Radian -> Bool req a b = (fromRadian $ abs (a-b)) < radian_epsilon    -- | Convert to radians.+-- toRadian :: Real a => a -> Radian  toRadian = Radian . realToFrac   -- | Convert from radians.+-- fromRadian :: Fractional a => Radian -> a fromRadian = realToFrac . getRadian   -- | Degrees to radians.+-- d2r :: (Floating a, Real a) => a -> Radian d2r = Radian . realToFrac . (*) (pi/180)  -- | Radians to degrees.+-- r2d :: (Floating a, Real a) => Radian -> a r2d = (*) (180/pi) . fromRadian @@ -785,6 +648,8 @@     i       :: Integer     dec     :: Double     (i,dec) = properFraction $ r2d r++   --------------------------------------------------------------------------------

@@ -1,5 +1,3 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -10,8 +8,7 @@ -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more---+-- Portability :  GHC -- -- Data types for stroke and label attributes and type classes  -- for conversion to PostScript\'s colour and matrix @@ -39,7 +36,6 @@ -- @findfont@ operations in the generated PostScript if  -- subsequent elements share the same values. -- ---  --    -------------------------------------------------------------------------------- @@ -47,9 +43,10 @@ module Wumpus.Core.GraphicsState    (   -- * Data types  +    GraphicsState(..)      -- ** Stroke attributes-    StrokeAttr(..)+  , StrokeAttr(..)   , LineCap(..)   , LineJoin(..)   , DashPattern(..)@@ -59,26 +56,32 @@   , FontFace(..)   , SVGFontStyle(..) -  -- ** Colour-  , PSRgb--  -- ** Current Translation Matrix-  , CTM(..)--  -- * Convert to CTM-  , ToCTM(..)--  -- * Convert to PSColour-  , PSColour(..)+  -- ** Default graphic state+  , zeroGS    ) where  import Wumpus.Core.Colour-import Wumpus.Core.Geometry-import Wumpus.Core.Utils  -- 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_line_width   :: Double+      , gs_miter_limit  :: Double+      , gs_line_cap     :: LineCap+      , gs_line_join    :: LineJoin+      , gs_dash_pattern :: DashPattern +      }+  deriving (Eq,Show)++ -- | Stroke attributes are an algebriac type rather than a  -- record type. This is for convenience when attributing paths - -- paths can be attibuted with just the differences from the @@ -94,15 +97,18 @@   -- | 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) @@ -146,96 +152,18 @@                   | SVG_OBLIQUE | SVG_BOLD_OBLIQUE   deriving (Eq,Ord,Show) -type PSRgb = RGB3 Double ----- | PostScript's current transformation matrix.--- --- PostScript and its documentation considers the matrix to be --- in this form:------ > | a  b  0 |--- > | c  d  0 | --- > | tx ty 1 |--- --- i.e it considers the homogeneous coordinates of an affine --- frame as /rows/ rather than /columns/ (Wumpus uses rows, as --- they were the usual representation in the geometry --- presentations that inspired it).--- --- Using the component names that we have used in the --- description of 'Frame2', the CTM is:------ > | e0x  e0y  0 |--- > | e1x  e1y  0 | --- > | ox   oy   1 |--- --- The CTM is represented in PostScript as an array, using our --- names its layout is------ > [ e0x e0y e1x e1y ox oy ] ------ Some examples, the scaling matrix:------ > | sx 0  0 |--- > | 0  sy 0 |  = [ sx 0 0 sy 0 0 ]--- > | 0  0  1 |--- --- Translation (displacement) :------ > | 1  0  0 |--- > | 0  1  0 |  = [ 1 0 0 1 tx ty ]--- > | tx ty 1 |--- --- Rotation:--- --- > |  cos(a)  sin(a)  0 |--- > | -sin(a)  cos(a)  0 |  = [ cos(a) sin(a) -sin(a) cos(a) 0 0 ]--- > |    0       0     1 |--data CTM u = CTM !u !u  !u !u  !u !u-  deriving (Eq,Show)--type instance DUnit (CTM u) = u------------------------------------------------------------------------------------- Conversion to CTM---- | Convert to the CTM. Wumpus offshores affine transformations --- to PostScript as @concat@ commands. So frames and matrices --- must support being represented as the CTM.----class ToCTM a where -  toCTM :: u ~ DUnit a => a -> CTM u--instance ToCTM (Frame2 a) where-  toCTM (Frame2 (V2 e0x e0y) (V2 e1x e1y) (P2 ox oy)) -    = CTM e0x e0y  e1x e1y  ox oy- --instance ToCTM (Matrix3'3 a) where-  toCTM (M3'3 e0x e1x ox  -              e0y e1y oy  -              _   _   _  ) -    = CTM e0x e0y  e1x e1y  ox oy-------------------------------------------------------------------------------------- Conversion to PSColour---- | Convert to RGB [0,1] for PostScript rendering.-class PSColour a where psColour :: a -> RGB3 Double--instance PSColour (RGB3 Double) where-  psColour (RGB3 r g b) = RGB3 (ramp r) (ramp g) (ramp b)--instance PSColour (HSB3 Double) where-  psColour = psColour . hsb2rgb--instance PSColour (Gray Double) where-  psColour = psColour . gray2rgb---+-- | The initial graphics state +zeroGS ::  GraphicsState +zeroGS = GraphicsState { gs_draw_colour  = black+                       , gs_font_size    = (-1)+                       , gs_font_face    = unmatchable_face+                       , gs_line_width   = 1+                       , gs_miter_limit  = 1+                       , gs_line_cap     = CapButt+                       , gs_line_join    = JoinMiter+                       , gs_dash_pattern = Solid+                       }+  where+    unmatchable_face = FontFace "DONT_MATCH" "" SVG_BOLD_OBLIQUE

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Core.OneList--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -12,16 +12,13 @@ -- -- Data type for non-empty lists. -- --- Structurally the same as OneMany - but used for a different--- purpose.--- --------------------------------------------------------------------------------  module Wumpus.Core.OneList   (    -- OneMany     OneList-  , ViewOL(..)+  , ViewL(..)    , one   , cons@@ -38,7 +35,7 @@   ) where  -import Data.Semigroup           -- package: algebra+import Data.Semigroup                           -- package: algebra  import Control.Applicative import Data.Foldable@@ -47,14 +44,15 @@  import Prelude hiding ( head ) --- type OneMany a = OneList a  data OneList a = One a | Many a (OneList a)   deriving (Eq) -data ViewOL a = OneL a | a :<< (OneList a)+data ViewL a = OneL a | a :< (OneList a)   deriving (Eq) ++ -------------------------------------------------------------------------------- -- Instances @@ -105,9 +103,9 @@ head (One a)    = a head (Many a _) = a -viewl :: OneList a -> ViewOL a+viewl :: OneList a -> ViewL a viewl (One a)     = OneL a-viewl (Many a as) = a :<< as+viewl (Many a as) = a :< as  -- | Construct Many. Not this function throws a error if the list has -- zero or one elements

@@ -1,22 +1,22 @@+{-# LANGUAGE ScopedTypeVariables        #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- |--- Module      :  Wumpus.Core.OutputPostScript+-- Module      :  Wumpus.Core.PostScript -- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 ----- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC -- -- Output PostScript - either PostScript (PS) files or  -- EPS (Encapusulated PostScript) files can be generated.  ----- -------------------------------------------------------------------------------- -module Wumpus.Core.OutputPostScript +module Wumpus.Core.OutputPostScript   (    -- * Output PostScript     writePS@@ -29,22 +29,118 @@  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.PictureInternal-import Wumpus.Core.PostScript+import Wumpus.Core.PostScriptDoc import Wumpus.Core.TextEncoder-import Wumpus.Core.TextEncodingInternal+import Wumpus.Core.TextInternal import Wumpus.Core.TextLatin1 import Wumpus.Core.Utils +import Control.Applicative hiding ( empty, some )+import Control.Monad -import MonadLib hiding ( Label )+import qualified Data.Foldable          as F+import Data.Maybe +import Data.Time -import qualified Data.Foldable as F +--------------------------------------------------------------------------------+-- PsMonad +-- PsMonad is at least a Reader and a State...+--+-- Graphics state works differently to SVG - PostScript has no +-- nesting (at least not in the code Wumpus generates) so there+-- are no /savings/ by diffing from an outer environment, instead+-- the diff is with the last drawn object.+--+newtype PsMonad a = PsMonad { +            getPsMonad :: TextEncoder -> GraphicsState -> (a,GraphicsState) } ++instance Functor PsMonad where+  fmap f mf = PsMonad $ \r s -> let (a,s1) = getPsMonad mf r s in (f a,s1)++instance Applicative PsMonad where+  pure a    = PsMonad $ \_ s -> (a,s)+  mf <*> ma = PsMonad $ \r s -> let (f,s1) = getPsMonad mf r s+                                    (a,s2) = getPsMonad ma r s1+                                  in (f a,s2)++instance Monad PsMonad where+  return a  = PsMonad $ \_ s  -> (a,s)+  m >>= k   = PsMonad $ \r s -> let (a,s1) = getPsMonad m r s+                                in (getPsMonad . k) a r s1+                              ++runPsMonad :: TextEncoder -> PsMonad a -> a+runPsMonad enc mf = fst $ getPsMonad mf enc zeroGS++askCharCode :: Int -> PsMonad (Either GlyphName GlyphName)+askCharCode i = PsMonad $ \r s -> case lookupByCharCode i r of+    Just n  -> (Right n,s)+    Nothing -> (Left $ ps_fallback r,s)++runLocalGS :: GSUpdate -> PsMonad a -> PsMonad a+runLocalGS upd mf = +    PsMonad $ \r s -> let (a,_) = getPsMonad mf r (getGSU upd s) in (a,s)++getDrawColour       :: PsMonad RGBi+getDrawColour       = PsMonad $ \_ s -> (gs_draw_colour s, s)++setDrawColour       :: RGBi -> PsMonad ()+setDrawColour a     = PsMonad $ \_ s -> ((), s {gs_draw_colour=a})+++getFontAttr         :: PsMonad FontAttr+getFontAttr         = PsMonad $ \_ s -> let sz = gs_font_size s +                                            ff = gs_font_face s+                                        in (FontAttr sz ff, s)++setFontAttr         :: FontAttr -> PsMonad ()+setFontAttr (FontAttr sz ff) = +    PsMonad $ \_ s -> ((), s { gs_font_size=sz,gs_font_face=ff })++  +getLineWidth        :: PsMonad Double+getLineWidth        = PsMonad $ \_ s -> (gs_line_width s, s)++setLineWidth        :: Double -> PsMonad ()+setLineWidth a      = PsMonad $ \_ s -> ((), s { gs_line_width=a })+++getMiterLimit       :: PsMonad Double+getMiterLimit       = PsMonad $ \_ s -> (gs_miter_limit s,s)++setMiterLimit       :: Double -> PsMonad ()+setMiterLimit a     = PsMonad $ \_ s -> ((), s { gs_miter_limit=a })+++getLineCap          :: PsMonad LineCap+getLineCap          = PsMonad $ \_ s -> (gs_line_cap s,s)++setLineCap          :: LineCap -> PsMonad ()+setLineCap a        = PsMonad $ \_ s -> ((), s { gs_line_cap=a })+++getLineJoin         :: PsMonad LineJoin+getLineJoin         = PsMonad $ \_ s -> (gs_line_join s,s)++setLineJoin         :: LineJoin -> PsMonad ()+setLineJoin a       = PsMonad $ \_ s -> ((), s { gs_line_join=a })+++getDashPattern      :: PsMonad DashPattern+getDashPattern      = PsMonad $ \_ s -> (gs_dash_pattern s,s)++setDashPattern      :: DashPattern -> PsMonad ()+setDashPattern a    = PsMonad $ \_ s -> ((), s { gs_dash_pattern=a })++ -------------------------------------------------------------------------------- -- Render to PostScript @@ -53,9 +149,8 @@ -- writePS :: (Real u, Floating u, PSUnit u)          => FilePath -> TextEncoder -> [Picture u] -> IO ()-writePS filepath enc pic = do -    timestamp <- mkTimeStamp-    writeFile filepath $ psDraw timestamp enc pic+writePS filepath enc pic = +    getZonedTime >>= \ztim -> writeFile filepath (show $ psDraw ztim enc pic)  -- | Output a picture to an EPS (Encapsulated PostScript) file.  -- The .eps file can then be imported or embedded in another @@ -63,301 +158,348 @@ -- writeEPS :: (Real u, Floating u, PSUnit u)            => FilePath -> TextEncoder -> Picture u -> IO ()-writeEPS filepath enc pic = do-    timestamp <- mkTimeStamp-    writeFile filepath $ epsDraw timestamp enc pic+writeEPS filepath enc pic =+    getZonedTime >>= \ztim -> writeFile filepath (show $ epsDraw ztim enc pic)  --- | Version of 'writePS' - using Latin1 encoding. +-- | Version of 'writePS' - using Latin1 encoding.+--  writePS_latin1 :: (Real u, Floating u, PSUnit u) -        => FilePath -> [Picture u] -> IO ()-writePS_latin1 filepath = writePS filepath latin1Encoder +               => FilePath -> [Picture u] -> IO ()+writePS_latin1 filepath = writePS filepath latin1Encoder  -- | Version of 'writeEPS' - using Latin1 encoding. +-- writeEPS_latin1 :: (Real u, Floating u, PSUnit u)  -         => FilePath -> Picture u -> IO ()+                => FilePath -> Picture u -> IO () writeEPS_latin1 filepath = writeEPS filepath latin1Encoder -- -------------------------------------------------------------------------------- -- Internals   -- | Draw a picture, generating PostScript output.+--+-- Note - the bounding box may /below the origin/ - if it is, it+-- will need translating.+--+ psDraw :: (Real u, Floating u, PSUnit u) -       => String -> TextEncoder -> [Picture u] -> PostScript-psDraw timestamp enc pics = runWumpus enc $ do-    psHeader 1 timestamp-    zipWithM_ psDrawPage pages pics-    psFooter+       => ZonedTime -> TextEncoder -> [Picture u] -> Doc+psDraw timestamp enc pics = +    let body = vcat $ runPsMonad enc $ zipWithM psDrawPage pages pics+    in vcat [ psHeader 1 timestamp+            , body+            , psFooter +            ]   where     pages = map (\i -> (show i,i)) [1..] --psDrawPage :: (Real u, Floating u, PSUnit u) -           => (String,Int) -> Picture u -> WumpusM ()-psDrawPage (lbl,ordinal) pic = do-    dsc_Page lbl ordinal-    ps_gsave-    cmdtrans-    outputPicture pic-    ps_grestore-    ps_showpage-  where-    (_,mbv)   = repositionProperties pic-    cmdtrans  = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv-  +-- | Note the bounding box may /below the origin/ - if it is, it+-- will need translating.+--+psDrawPage :: (Real u, Floating u, PSUnit u)+           => (String,Int) -> Picture u -> PsMonad Doc+psDrawPage (lbl,ordinal) pic = +    let (_,cmdtrans) = imageTranslation pic in +    (\doc -> vcat [ dsc_Page lbl ordinal+                  , ps_gsave+                  , cmdtrans+                  , doc+                  , ps_grestore+                  , ps_showpage+                  ]) +      <$> picture pic  --- | Note the bounding box may /below the origin/ - if it is, it +-- | Note the bounding box may /below the origin/ - if it is, it -- will need translating. ---epsDraw :: (Real u, Floating u, PSUnit u) -        => String -> TextEncoder -> Picture u -> PostScript-epsDraw timestamp enc pic = runWumpus enc $ do -    epsHeader bb timestamp      -    ps_gsave-    cmdtrans-    outputPicture pic-    ps_grestore-    epsFooter  -  where-    (bb,mbv)  = repositionProperties pic-    cmdtrans  = maybe (return ()) (\(V2 x y) -> ps_translate x y) mbv-     +epsDraw :: (Real u, Floating u, PSUnit u)+        => ZonedTime -> TextEncoder -> Picture u -> Doc+epsDraw timestamp enc pic =+    let (bb,cmdtrans) = imageTranslation pic +        body          = runPsMonad enc (picture pic) +    in vcat [ epsHeader bb timestamp+            , ps_gsave+            , cmdtrans+            , body+            , ps_grestore+            , epsFooter+            ] -psHeader :: Int -> String -> WumpusM ()-psHeader pagecount timestamp = do-    bang_PS-    dsc_Pages pagecount-    dsc_CreationDate $ parens timestamp-    dsc_EndComments +imageTranslation :: (Ord u, PSUnit u) => Picture u -> (BoundingBox u, Doc)+imageTranslation pic = case repositionDeltas pic of+  (bb, Nothing) -> (bb, empty)+  (bb, Just v)  -> (bb, ps_translate v) -epsHeader :: PSUnit u => BoundingBox u -> String -> WumpusM ()-epsHeader bb timestamp = do-    bang_EPS-    dsc_BoundingBox llx lly urx ury-    dsc_CreationDate $ parens timestamp-    dsc_EndComments++--------------------------------------------------------------------------------+++picture :: (Real u, Floating u, PSUnit u) => Picture u -> PsMonad Doc+picture (Leaf    (_,xs) ones)   = bracketTrafos xs $ revConcat primitive ones+picture (Picture (_,xs) ones)   = bracketTrafos xs $ revConcat picture ones+picture (Clip    (_,xs) cp pic) = bracketTrafos xs $+                                    (vconcat <$> clipPath cp <*> picture pic)+picture (Group   (_,xs) fn pic) = bracketTrafos xs (runLocalGS fn (picture pic))+++revConcat :: (a -> PsMonad Doc) -> OneList a -> PsMonad Doc+revConcat fn ones = some empty <$> F.foldrM step None ones   where-    (llx,lly,urx,ury) = getBounds bb+    step e ac = (\d -> d `conc` ac) <$> fn e+    conc d None      = Some d+    conc d (Some ac) = Some $ ac `vconcat` d -getBounds :: Num u => BoundingBox u -> (u,u,u,u)-getBounds (BBox (P2 llx lly) (P2 urx ury)) = (llx,lly,urx,ury) -psFooter :: WumpusM ()-psFooter = dsc_EOF+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  -epsFooter :: WumpusM ()-epsFooter = do-    ps_showpage-    dsc_EOF+primPath :: PSUnit u+         => PathProps -> PrimPath u -> PsMonad Doc+primPath (CFill rgb)     p = +    (\rgbd -> vcat [rgbd, makeStartPath p, ps_closepath, ps_fill]) +      <$> deltaDrawColour rgb   --- Create margins at the left and bottom of 4 points...+primPath (CStroke attrs rgb) p = +    (\rgbd attrd -> vcat [ rgbd, attrd, makeStartPath p+                         , ps_closepath, ps_stroke ])+      <$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs+ +primPath (OStroke attrs rgb) p = +    (\rgbd attrd -> vcat [rgbd, attrd, makeStartPath p, ps_stroke]) +      <$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs +primPath (CFillStroke fc attrs sc) p = +    (\d1 d2 -> vcat [d1,d2])+      <$> primPath (CFill fc) p <*> primPath (CStroke attrs sc) p --- | outputPicture --- Frame changes, representing scalings translation, rotations...--- are drawn when they are encountered as a @concat@ statement in a --- block of @gsave ... grestore@.----outputPicture :: (Real u, Floating u, PSUnit u) => Picture u -> WumpusM ()-outputPicture (PicBlank  _)             = return ()-outputPicture (Single (fr,_) prim)      = -    updateFrame fr $ outputPrimitive prim-outputPicture (Picture (fr,_) ones)     =-    updateFrame fr $ F.foldrM (\p _ -> outputPicture p) () ones-outputPicture (Clip (fr,_) cp p)        = -    updateFrame fr $ do { clipPath cp ; outputPicture p } +clipPath :: PSUnit u => PrimPath u -> PsMonad Doc+clipPath p = pure $ vcat [makeStartPath p , ps_closepath, ps_clip] --- | @updateFrame@ relies on the current frame, when translated--- to a matrix being invertible.++makeStartPath :: PSUnit u => PrimPath u -> Doc+makeStartPath (PrimPath start xs) = +    vcat $ ps_newpath : ps_moveto start : map makePathSegment xs++++makePathSegment :: PSUnit u => PrimPathSegment u -> Doc+makePathSegment (PLineTo p1)        = ps_lineto p1 +makePathSegment (PCurveTo p1 p2 p3) = ps_curveto p1 p2 p3 +++-- | Drawing stroked ellipse has an unfortunate - but (probably) +-- unavoidable deficiency. ----- This is an allowable optimization because the current frame--- is only manipulated with the affine transformations (scalings, --- rotations...) which are invertible. --- --- It also performs another optimization:+-- The use of PostScript\'s @concat@ operator to alter the arc +-- hw/hh will vary the line width during the drawing of a stroked +-- ellipse. ----- If the frame is the standard frame @ [1 0 0 1 0 0] @ then --- the monadic action is run as-is rather than being nested--- in a block:--- --- > [1 0 0 1 0 0] concat--- > ...--- > [1 0 0 1 0 0] concat+-- For good stroked ellipses, Bezier curves constructed from +-- PrimPaths should be used. --+primEllipse :: (Real u, Floating u, PSUnit u) +            => EllipseProps -> PrimEllipse u -> PsMonad Doc+primEllipse props (PrimEllipse center hw hh ctm) =+    bracketPrimCTM center (scaleCTM 1 (hh/hw) ctm) (drawF props)+  where+    drawF (EFill rgb)               pt = fillArcPath rgb hw pt+    drawF (EStroke attrs rgb)       pt = strokeArcPath rgb attrs hw pt+    drawF (EFillStroke fc attrs sc) pt = +        vconcat <$> fillArcPath fc hw pt <*>  strokeArcPath sc attrs hw pt+                        -updateFrame :: (Fractional u, PSUnit u) => Frame2 u -> WumpusM () -> WumpusM ()-updateFrame frm ma -  | standardFrame frm = ma-  | otherwise         = let m1 = frame2Matrix frm in -                        do { ps_concat $ toCTM m1-                           ; ma -                           ; ps_concat $ toCTM $ invert m1-                           } -outputPrimitive :: (Real u, Floating u, PSUnit u) => Primitive u -> WumpusM ()-outputPrimitive (PPath (c,dp) p)    = outputPath dp c p -outputPrimitive (PLabel props l)    = updateFont props $ outputLabel l-outputPrimitive (PEllipse (c,dp) e) = outputEllipse dp c e+-- This will need to become monadic to handle /colour delta/.+--+fillArcPath :: PSUnit u => RGBi -> u -> Point2 u -> PsMonad Doc+fillArcPath rgb radius pt = +    (\rgbd -> vcat [ rgbd+                   , ps_newpath+                   , ps_arc pt radius 0 360+                   , ps_closepath+                   , ps_fill ])+      <$> deltaDrawColour rgb -updateFont :: LabelProps -> WumpusM () -> WumpusM ()-updateFont (c,fnt) ma = updateColour c $ do -    mb_fnt <- deltaFontAttr fnt-    maybe (return ()) fontCommand mb_fnt-    ma-    +strokeArcPath :: PSUnit u +              => RGBi -> [StrokeAttr] -> u -> Point2 u -> PsMonad Doc+strokeArcPath rgb attrs radius pt =+    (\rgbd attrd -> vcat [ rgbd+                         , attrd+                         , ps_newpath+                         , ps_arc pt radius 0 360+                         , ps_closepath+                         , ps_stroke ])+      <$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs  -updateColour :: PSColour c => c -> WumpusM () -> WumpusM ()-updateColour c ma = let rgbc = psColour c in do -    mb_col  <- deltaRgbColour rgbc-    maybe (return ()) colourCommand mb_col-    ma+-- Note - for the otherwise case, the x-and-y coordinates are +-- encoded in the matrix, hence the @ 0 0 moveto @.+--+primLabel :: (Real u, Floating u, PSUnit u) +          => LabelProps -> PrimLabel u -> PsMonad Doc+primLabel (LabelProps rgb font) (PrimLabel basept txt ctm) = +    bracketPrimCTM basept ctm mf   where-    colourCommand :: DRGB -> WumpusM ()-    colourCommand (RGB3 r g b) = ps_setrgbcolor r g b- -    +    mf pt = (\rgbd fontd showd -> vcat [ rgbd, fontd, ps_moveto pt, showd ]) +              <$> deltaDrawColour rgb <*> deltaFontAttrs font +                                      <*> encodedText txt +encodedText :: EncodedText -> PsMonad Doc +encodedText etext = vcat <$> (mapM textChunk $ getEncodedText etext) -fontCommand :: FontAttr -> WumpusM ()-fontCommand (FontAttr sz face) = do-    ps_findfont (font_name face)-    ps_scalefont sz-    ps_setfont +textChunk :: TextChunk -> PsMonad Doc+textChunk (SText s)  = pure (ps_show $ escapeSpecial s)+textChunk (EscStr s) = pure (ps_glyphshow s)+textChunk (EscInt i) = (either failk ps_glyphshow) <$> askCharCode i +  where+    failk gly_name = missingCharCode i gly_name +--------------------------------------------------------------------------------+-- Stroke, font and drawing colour attribute delta -    -outputPath :: (PSColour c, PSUnit u) -           => DrawPath -> c -> Path u -> WumpusM ()-outputPath CFill        c p = updateColour c $ do  -    startPath p-    ps_closepath-    ps_fill+-- This needs more thought than SVG as there is no natural +-- nesting to benefit from... -outputPath (CStroke xs) c p = updatePen c xs $ do-    startPath p-    ps_closepath-    ps_stroke+-- All graphics are annotated with colour - the graphics state+-- doesn\'t tell us the actual colour of anything, only if we +-- need to write a colour change to the output.+-- +-- So we compare the current colour with the state - if it is+-- different we put the new colour in the state and output a +-- @setrgbcolor@ message.+--+--+-- Note - because these combinators return /empty/ for no +-- difference some extraneous blank lines are produced in the +-- output.+-- -outputPath (OStroke xs) c p = updatePen c xs $ do-    startPath p-    ps_stroke-  +deltaDrawColour :: RGBi -> PsMonad Doc+deltaDrawColour rgb = getDrawColour >>= \inh -> +   if rgb==inh then return empty+               else setDrawColour rgb >> return (ps_setrgbcolor rgb) -startPath :: PSUnit u => Path u -> WumpusM ()-startPath (Path (P2 x y) xs) = do-    ps_newpath-    ps_moveto x y-    mapM_ outputPathSeg xs +-- Note - the current way of handling Stroke Deltas for +-- PostScript uses an awful lot of operations. +-- +-- The GraphicsState data types need some more thought +-- +data StrokeDelta = StrokeDelta+      { sd_line_width   :: Double+      , sd_miter_limit  :: Double+      , sd_line_cap     :: LineCap+      , sd_line_join    :: LineJoin+      , sd_dash_pattern :: DashPattern+      } -clipPath :: PSUnit u => Path u -> WumpusM ()-clipPath p = do -    startPath p-    ps_closepath-    ps_clip+-- | Note - the values here must be in- sync with zeroGS.+--+zeroSD :: StrokeDelta+zeroSD = StrokeDelta { sd_line_width   = 1+                     , sd_miter_limit  = 1+                     , sd_line_cap     = CapButt+                     , sd_line_join    = JoinMiter+                     , sd_dash_pattern = Solid+                     }  +makeStrokeDelta :: [StrokeAttr] -> StrokeDelta+makeStrokeDelta = foldr fn zeroSD+  where+    fn (LineWidth a)    sd = sd { sd_line_width = a }+    fn (MiterLimit a)   sd = sd { sd_miter_limit = a }+    fn (LineCap a)      sd = sd { sd_line_cap = a }+    fn (LineJoin a)     sd = sd { sd_line_join = a }+    fn (DashPattern a)  sd = sd { sd_dash_pattern = a}  -updatePen :: PSColour c => c -> [StrokeAttr] -> WumpusM () -> WumpusM ()-updatePen c xs ma = let (mset, mreset) = strokeSetReset xs in -                    updateColour c $ do { mset ; ma ; mreset } -strokeSetReset :: [StrokeAttr] -> (WumpusM (), WumpusM ())-strokeSetReset = foldr (appro link cmd id) (return (), return ())+deltaStrokeAttrs :: [StrokeAttr] -> PsMonad Doc+deltaStrokeAttrs xs = step $ makeStrokeDelta xs   where-    link Nothing      funs    = funs -    link (Just (f,g)) (fs,gs) = (fs >> f, gs >> g)-    -    mkSetReset mf        = maybe Nothing (\(a,b) -> Just (mf a, mf b))-    -    cmd (LineWidth d)    = mkSetReset ps_setlinewidth  $ deltaStrokeWidth d-    cmd (MiterLimit d)   = mkSetReset ps_setmiterlimit $ deltaMiterLimit d-    cmd (LineCap lc)     = mkSetReset ps_setlinecap    $ deltaLineCap lc-    cmd (LineJoin lj)    = mkSetReset ps_setlinejoin   $ deltaLineJoin lj-    cmd (DashPattern dp) = mkSetReset ps_setdash       $ deltaDashPattern dp+    step sd = (\d1 d2 d3 d4 d5 -> hcat $ catMaybes [d1,d2,d3,d4,d5])  +                <$> lw sd <*> ml sd <*> lc sd <*> lj sd <*> dp sd +    lw sd = let d = sd_line_width sd in +            getLineWidth >>= \inh -> +            if d == inh +              then return Nothing +              else setLineWidth d >> return (Just $ ps_setlinewidth d) -outputPathSeg :: PSUnit u => PathSegment u -> WumpusM ()-outputPathSeg (PLineTo (P2 x y))  = ps_lineto x y-outputPathSeg (PCurveTo p1 p2 p3) = ps_curveto x1 y1 x2 y2 x3 y3 -  where-    P2 x1 y1 = p1-    P2 x2 y2 = p2-    P2 x3 y3 = p3+    ml sd = let d = sd_miter_limit sd in +            getMiterLimit >>= \inh -> +            if d==inh +              then return Nothing +              else setMiterLimit d >> return (Just $ ps_setmiterlimit d)+                            +    lc sd = let d = sd_line_cap sd in+            getLineCap >>= \inh -> +            if d==inh +              then return Nothing+              else setLineCap d >> return (Just $ ps_setlinecap d)+                      +    lj sd = let d = sd_line_join sd in +            getLineJoin >>= \inh -> +            if d==inh +              then return Nothing+              else setLineJoin d >> return (Just $ ps_setlinejoin d) +    dp sd  = let d = sd_dash_pattern sd in+             getDashPattern >>= \inh -> +             if d==inh +               then return Nothing+               else setDashPattern d >> return (Just $ ps_setdash d) --- | This is not very good - the use of PostScript's @concat@ --- operator will vary the line width during the drawing of a --- stroked ellipse.----outputEllipse :: (PSColour c, Real u, Floating u, PSUnit u)-              => DrawEllipse -> c -> PrimEllipse u -> WumpusM ()-outputEllipse dp c (PrimEllipse pt@(P2 x y) hw hh ctm)-    | hw==hh  && ctm == identityCTM = outputArc dp c x y hw-    | otherwise                     = -          let matrix     =  matrixRepCTM $ scaleCTM 1 (hh/hw) ctm-              matrix'    = invert matrix-              (P2 dx dy) = matrix' *# pt -          in do { ps_concat $ toCTM matrix-                ; outputArc dp c dx dy hw-                ; ps_concat $ toCTM $ matrix'-                } -outputArc :: (PSColour c, PSUnit u) -          => DrawEllipse -> c -> u -> u -> u -> WumpusM ()-outputArc EFill        c x y r = updateColour c $ do -    ps_newpath-    ps_arc x y r 0 360 -    ps_closepath-    ps_fill -outputArc (EStroke xs) c x y r = updatePen c xs $ do -    ps_newpath-    ps_arc x y r 0 360 -    ps_closepath-    ps_stroke+deltaFontAttrs :: FontAttr -> PsMonad Doc+deltaFontAttrs fa  = getFontAttr >>= \inh ->+    if fa==inh then return empty +               else setFontAttr fa >> return (makeFontAttrs fa) +makeFontAttrs :: FontAttr -> Doc+makeFontAttrs (FontAttr sz face) = +    vcat [ ps_findfont (font_name face), ps_scalefont sz, ps_setfont ] --- Note - for the otherwise case the x-and-y coordinates are --- encoded in the matrix, hence the @ 0 0 moveto @.----outputLabel :: (Real u, Floating u, PSUnit u) => Label u -> WumpusM ()-outputLabel (Label (P2 x y) entxt ctm) -    | ctm == identityCTM  = do { ps_moveto x y; outputEncodedText entxt }-    | otherwise           = do { ps_concat $ toCTM matrix-                               ; ps_moveto 0 (0 :: Double)-                               ; outputEncodedText entxt-                               ; ps_concat $ toCTM $ invert matrix-                               }-  where-    matrix = translMatrixRepCTM x y ctm -outputEncodedText :: EncodedText -> WumpusM () -outputEncodedText = mapM_ outputTextChunk . getEncodedText+--------------------------------------------------------------------------------+-- Bracket matrix and PrimCTM trafos -outputTextChunk :: TextChunk -> WumpusM () -outputTextChunk (SText s)  = ps_show $ escapeStringPS s+bracketTrafos :: (Real u, Floating u, PSUnit u) +              => [AffineTrafo u] -> PsMonad Doc -> PsMonad Doc+bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma  -outputTextChunk (EscInt i) = -    ask >>= \env -> maybe (failk env) ps_glyphshow $ lookupByCharCode i env+bracketMatrix :: (Fractional u, PSUnit u) +              => Matrix3'3 u -> PsMonad Doc -> PsMonad Doc+bracketMatrix mtrx ma +    | mtrx == identityMatrix = ma+    | otherwise              = (\doc -> vcat [inn, doc, out]) <$> ma   where-    failk = missingCode i . ps_fallback  +    inn   = ps_concat $ mtrx+    out   = ps_concat $ invert mtrx -outputTextChunk (EscStr s) = ps_glyphshow s  -missingCode :: CharCode -> GlyphName -> WumpusM ()-missingCode i fallback =  do-    ps_comment $ "missing lookup for &#" ++ show i ++ ";" -    ps_glyphshow fallback-            +bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u)+               => Point2 u -> PrimCTM u +               -> (Point2 u -> PsMonad Doc) -> PsMonad Doc+bracketPrimCTM pt@(P2 x y) ctm mf +    | ctm == identityCTM  = mf pt+    | otherwise           = (\doc -> vcat [inn, doc, out]) <$> mf zeroPt'+  where+    zeroPt' :: Point2 u+    zeroPt' = zeroPt++    mtrx  = translMatrixRepCTM x y ctm+    inn   = ps_concat $ mtrx+    out   = ps_concat $ invert mtrx 

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ScopedTypeVariables        #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -7,9 +7,9 @@ -- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 ----- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC -- -- Output SVG.  --@@ -30,42 +30,96 @@ -- -------------------------------------------------------------------------------- -module Wumpus.Core.OutputSVG-  ( -  +module Wumpus.Core.OutputSVG +  (+   -- * Output SVG     writeSVG    , writeSVG_latin1-  +   ) where -import Wumpus.Core.AffineTrans+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.PageTranslation import Wumpus.Core.PictureInternal-import Wumpus.Core.SVG+import Wumpus.Core.SVGDoc import Wumpus.Core.TextEncoder-import Wumpus.Core.TextEncodingInternal+import Wumpus.Core.TextInternal import Wumpus.Core.TextLatin1 import Wumpus.Core.Utils +import Control.Applicative hiding ( empty, some )+import qualified Data.Foldable as F -import MonadLib hiding ( Label )+-- SvgMonad is two Readers plus Int state for clip paths...+--+newtype SvgMonad a = SvgMonad { +            getSvgMonad :: TextEncoder -> GraphicsState -> Int -> (a,Int) } -import Text.XML.Light -import qualified Data.Foldable as F -type Clipped    = Bool+instance Functor SvgMonad where+  fmap f mf = SvgMonad $ \r1 r2 s -> let (a,s1) = getSvgMonad mf r1 r2 s+                                     in (f a,s1) +instance Applicative SvgMonad where+  pure a    = SvgMonad $ \_  _  s -> (a,s)+  mf <*> ma = SvgMonad $ \r1 r2 s -> let (f,s1) = getSvgMonad mf r1 r2 s+                                         (a,s2) = getSvgMonad ma r1 r2 s1+                                   in (f a, s2) -coordChange ::  (Num u, Scale t, u ~ DUnit t) => t -> t-coordChange = scale 1 (-1)+instance Monad SvgMonad where+  return a  = SvgMonad $ \_  _  s -> (a,s)+  m >>= k   = SvgMonad $ \r1 r2 s -> let (a,s1) = getSvgMonad m r1 r2 s+                                     in (getSvgMonad . k) a r1 r2 s1+                             -svg_reflection_matrix :: Num u => Matrix3'3 u-svg_reflection_matrix = scalingMatrix 1 (-1) +runSvgMonad :: TextEncoder -> SvgMonad a -> a+runSvgMonad enc mf = fst $ getSvgMonad mf enc zeroGS 0++newClipLabel :: SvgMonad String+newClipLabel = SvgMonad $ \_ _ s -> ('c':'l':'i':'p':show s, s+1)++askGlyphName :: String -> SvgMonad (Either GlyphName GlyphName)+askGlyphName nm = SvgMonad $ \r1 _ s -> case lookupByGlyphName nm r1 of+    Just a  -> (Right $ escapeSpecial a, s)+    Nothing -> (Left  $ escapeSpecial $ svg_fallback r1, s)++-- This is different to the PsMonad version, as SVG is nested +-- (and /graphics state/ is via a Reader), so it is the same as +-- local with a Reader monad.+--+runLocalGS :: GSUpdate -> SvgMonad a -> SvgMonad a+runLocalGS upd mf = +    SvgMonad $ \r1 r2 s -> getSvgMonad mf r1 (getGSU upd r2) s+++askFontAttr :: SvgMonad FontAttr+askFontAttr = +    SvgMonad $ \_ r2 s -> (FontAttr (gs_font_size r2) (gs_font_face r2), s)++askLineWidth    :: SvgMonad Double+askLineWidth    = SvgMonad $ \_ r2 s -> (gs_line_width r2, s)++askMiterLimit   :: SvgMonad Double+askMiterLimit   = SvgMonad $ \_ r2 s -> (gs_miter_limit r2, s)++askLineCap      :: SvgMonad LineCap+askLineCap      = SvgMonad $ \_ r2 s -> (gs_line_cap r2, s)++askLineJoin     :: SvgMonad LineJoin+askLineJoin     = SvgMonad $ \_ r2 s -> (gs_line_join r2, s)++askDashPattern  :: SvgMonad DashPattern+askDashPattern  = SvgMonad $ \_ r2 s -> (gs_dash_pattern r2, s)+ --------------------------------------------------------------------------------  -- | Output a picture to a SVG file. @@ -73,286 +127,258 @@ writeSVG :: (Real u, Floating u, PSUnit u)           => FilePath -> TextEncoder -> Picture u -> IO () writeSVG filepath enc pic = -    writeFile filepath $ unlines $ map ppContent $ svgDraw enc pic +    writeFile filepath $ show $ svgDraw enc pic   -- | Version of 'writeSVG' - using Latin1 encoding.  -- writeSVG_latin1 :: (Real u, Floating u, PSUnit u)                  => FilePath -> Picture u -> IO ()-writeSVG_latin1 filepath = writeSVG filepath latin1Encoder --+writeSVG_latin1 filepath = writeSVG filepath latin1Encoder  svgDraw :: (Real u, Floating u, PSUnit u) -        => TextEncoder -> Picture u -> [Content]-svgDraw enc pic = runSVG enc $ do-    elem1     <- picture False pic'-    prefixXmlDecls (topLevelPic mbvec elem1)-  where-    pic'      = coordChange pic-    (_,mbvec) = repositionProperties pic'+        => TextEncoder -> Picture u -> Doc+svgDraw enc original_pic = +    let pic          = trivialTranslation original_pic+        (_,imgTrafo) = imageTranslation pic+        body         = runSvgMonad enc $ picture pic+    in vcat [ xml_version, doctype, elem_svg $ imgTrafo body ]  -prefixXmlDecls :: Element -> SvgM [Content]-prefixXmlDecls e = do -    enc <- asks svg_encoding_name-    let xmlv = xmlVersion enc-    return $ [Text xmlv, Text svgDocType, Elem e]     -topLevelPic :: PSUnit u => Maybe (Vec2 u) -> Element -> Element-topLevelPic Nothing         p = svgElement [p]-topLevelPic (Just (V2 x y)) p = svgElement [gElement [trans_attr] [p]] -  where -    trans_attr = attr_transform $ val_translate x y+imageTranslation :: (Ord u, PSUnit u) +                 => Picture u -> (BoundingBox u, Doc -> Doc)+imageTranslation pic = case repositionDeltas pic of+  (bb, Nothing) -> (bb, id)+  (bb, Just v)  -> let attr = attr_transform (val_translate v) +                   in (bb, elem_g attr) +-------------------------------------------------------------------------------- +-- Note - it will be wise to make coordinate remapping and output+-- separate passes (unlike in Wumpus-Core). Then I\'ll at least +-- be able to debug the remapped Picture.+-- -picture :: (Real u, Floating u, PSUnit u) -        => Clipped -> Picture u -> SvgM Element-picture _ (PicBlank _)            = return $ gElement [] []-picture c (Single (fr,_) prim)    = do -    elt <- primitive c prim-    return $ gElement (maybe [] return $ frameChange fr) [elt] -picture c (Picture (fr,_) ones)    = do-    -- Note - list in zorder, so we want to draw the tail first -    es <- liftM toListH $ F.foldrM fn emptyH ones-    return $ gElement (maybe [] return $ frameChange fr) es-  where-    fn e hl = picture c e >>= \a -> return $ hl `snocH` a-  -picture _ (Clip (fr,_) p a) = do -   cp <- clipPath p-   e1 <- picture True a-   return $ gElement (maybe [] return $ frameChange fr) [cp,e1] +picture :: (Real u, Floating u, PSUnit u) => Picture u -> SvgMonad Doc+picture (Leaf    (_,xs) ones)   = bracketTrafos xs $ revConcat primitive ones+picture (Picture (_,xs) ones)   = bracketTrafos xs $ revConcat picture ones+picture (Clip    (_,xs) cp pic) = +    bracketTrafos xs $ do { lbl <- newClipLabel+                          ; d1  <- clipPath lbl cp+                          ; d2  <- picture pic+                          ; return (vconcat d1 (elem_g (attr_clip_path lbl) d2))+                          } +picture (Group   (_,xs) fn pic) = bracketTrafos xs (runLocalGS fn (picture pic)) -primitive :: (Real u, Floating u, PSUnit u) -          => Clipped -> Primitive u -> SvgM Element-primitive c (PPath props p)     = clipAttrib c $ path props p-primitive c (PLabel props l)    = clipAttrib c $ label props l-primitive c (PEllipse props e)  = clipAttrib c $ ellipse props e  +-- This starts with an empty line...+-- --- All clipping paths are closed.-clipPath :: PSUnit u => Path u -> SvgM Element-clipPath p = do-    name <- newClipLabel-    return $ element_clippath ps `rap` add_attr (attr_id name)+revConcat :: (a -> SvgMonad Doc) -> OneList a -> SvgMonad Doc+revConcat fn ones = some empty <$> F.foldrM step None ones   where-    ps = closePath $ pathInstructions p+    step e ac = (\d -> d `conc` ac) <$> fn e+    conc d None      = Some d+    conc d (Some ac) = Some $ ac `vconcat` d   -clipAttrib :: Clipped -> SvgM Element -> SvgM Element-clipAttrib False melt = melt-clipAttrib True  melt = do -    s   <- currentClipLabel-    elt <- melt-    return $ add_attr (attr_clippath s) elt+primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> SvgMonad Doc+primitive (PPath props xl pp)     = drawXLink xl <$> primPath props pp+primitive (PLabel props xl lbl)   = drawXLink xl <$> primLabel props lbl+primitive (PEllipse props xl ell) = drawXLink xl <$> primEllipse props ell+  +drawXLink :: XLink -> Doc -> Doc+drawXLink NoLink           doc = doc+drawXLink (XLinkHRef href) doc = elem_a_xlink href doc --- None of the remaining translation functions need to be in the--- SvgM monad.+clipPath :: PSUnit u => String -> PrimPath u -> SvgMonad Doc+clipPath clip_id pp = (\doc -> elem_clipPath (attr_id clip_id) doc) <$> path pp -path :: PSUnit u => PathProps -> Path u -> SvgM Element-path (c,dp) p = -    return $ element_path ps `snoc_attrs` (fill_a : stroke_a : opts)-  where-    (fill_a,stroke_a,opts) = drawProperties c dp-    ps                     = svgPath dp p  +primPath :: PSUnit u => PathProps -> PrimPath u -> SvgMonad Doc+primPath props pp = (\(a,f) d -> elem_path a (f d)) +                      <$> pathProps props <*> path pp --- Labels need the coordinate system remapping otherwise--- the will be printed upside down. Both the start point and --- the label itself need transforming.--- --- Also rendering coloured text is convoluted (needing the--- tspan element).--- ----label :: (Real u, Floating u, PSUnit u) -      => LabelProps -> Label u -> SvgM Element-label (c,FontAttr sz face) (Label pt entxt ctm) = do -     str <- encodedText entxt-     let tspan_elt = element_tspan str `snoc_attrs` [ attr_fill c ]-     return $ element_text tspan_elt `snoc_attrs` coord_attrs-                                     `snoc_attrs` font_attrs -                                     `snoc_attrs` (fontStyle style)-  where-    style       = svg_font_style  face-    fam         = svg_font_family face-    coord_attrs = if ctm == identityCTM then simpleLabelAttrs pt-                                        else transfLabelAttrs pt ctm-    font_attrs  = [ attr_font_family fam-                  , attr_font_size sz -                  ] -simpleLabelAttrs :: PSUnit u => Point2 u -> [Attr]     -simpleLabelAttrs pt = [ attr_x x, attr_y y, attr_transform mtrx]-  where-    P2 x y    = coordChange pt-    mtrx      = val_matrix 1 0 0 (-1) 0 (0::Double)-    -transfLabelAttrs :: (Real u, Floating u, PSUnit u) -                 => Point2 u -> PrimCTM u -> [Attr]     -transfLabelAttrs (P2 x y) ctm = -    [ attr_x (0::Double), attr_y (0 :: Double), attr_transform vmtrx]+path :: PSUnit u => PrimPath u -> SvgMonad Doc+path (PrimPath start xs) = +    pure $ path_m start <+> hsep (map seg xs)   where-    mtrx      = translMatrixRepCTM x y ctm * svg_reflection_matrix-    vmtrx     = valMatrix mtrx+    seg (PLineTo pt)        = path_l pt+    seg (PCurveTo p1 p2 p3) = path_c p1 p2 p3 +-- Return - drawing props, plus a function to close the path (or not). +--+pathProps :: PathProps -> SvgMonad (Doc, Doc -> Doc)+pathProps props = fn props+  where+    fn (CFill rgb)                = pure (fillNotStroke rgb, close)  -encodedText :: EncodedText -> SvgM String -encodedText entxt = -    let xs = getEncodedText entxt in mapM textChunk  xs >>= return . concat+    fn (CStroke attrs rgb)        = +        (\a -> (strokeNotFill rgb <+> a, close))   <$> deltaStrokeAttrs attrs --- | Unfortunately we can\'t readily put a comment in the --- generated SVG when glyph-name lookup fails. Doing similar in --- PostScript is easy because we are emiting /linear/ PostScript --- as we go along. For SVG we are building an abstract syntax --- tree.--- -textChunk :: TextChunk -> SvgM String-textChunk (SText s)  = return s-textChunk (EscInt i) = return $ escapeCharCode i-textChunk (EscStr s) = -    asks (lookupByGlyphName s) >>= maybe failk (return . escapeCharCode) -  where-    failk = asks svg_fallback >>= return . escapeCharCode +    fn (OStroke attrs rgb)        = +        (\a -> (strokeNotFill rgb <+> a, id))      <$> deltaStrokeAttrs attrs -escapeCharCode :: CharCode -> String-escapeCharCode i = "&#" ++ show i ++ ";"+    fn (CFillStroke fc attrs sc)  =+        (\a -> (fillAndStroke fc sc <+> a, close)) <$> deltaStrokeAttrs attrs +    fillNotStroke rgb             = attr_fill rgb   <+> attr_stroke_none +    strokeNotFill rgb             = attr_stroke rgb <+> attr_fill_none+    fillAndStroke a b             = attr_fill a     <+> attr_stroke b+    close                         = (<+> char 'Z')  -fontStyle :: SVGFontStyle -> [Attr]-fontStyle SVG_REGULAR      = []-fontStyle SVG_BOLD         = [attr_font_weight "bold"]-fontStyle SVG_ITALIC       = [attr_font_style "italic"]-fontStyle SVG_BOLD_ITALIC  = -    [attr_font_weight "bold", attr_font_style "italic"]-fontStyle SVG_OBLIQUE      = [attr_font_style "oblique"]-fontStyle SVG_BOLD_OBLIQUE = -    [attr_font_weight "bold", attr_font_style "oblique"] --- If w==h the draw the ellipse as a circle -ellipse :: (Real u, Floating u, PSUnit u)-        => EllipseProps -> PrimEllipse u -> SvgM Element-ellipse (c,dp) (PrimEllipse pt hw hh ctm) -    | hw == hh  = return $ element_circle  -                            `snoc_attrs` (circle_attrs  ++ style_attrs)-    | otherwise = return $ element_ellipse -                            `snoc_attrs` (ellipse_attrs ++ style_attrs)+++-- Note - if hw==hh then draw the ellipse as a circle.+--+primEllipse :: (Real u, Floating u, PSUnit u)+            => EllipseProps -> PrimEllipse u -> SvgMonad Doc+primEllipse props (PrimEllipse pt hw hh ctm) +    | hw == hh  = (\a b -> elem_circle (a <+> circle_radius <+> b))+                    <$> bracketPrimCTM pt ctm mkCXCY <*> ellipseProps props+    | otherwise = (\a b -> elem_ellipse (a <+> ellipse_radius <+> b))+                    <$> bracketPrimCTM pt ctm mkCXCY <*> ellipseProps props   where-    circle_attrs  = if ctm == identityCTM -                      then simpleCircleAttrs pt hw-                      else transfCircleAttrs pt hw ctm+   mkCXCY (P2 x y) = pure $ attr_cx x <+> attr_cy y+   +   circle_radius   = attr_r hw+   ellipse_radius  = attr_rx hw <+> attr_ry hh -    ellipse_attrs = if ctm == identityCTM -                      then simpleEllipseAttrs pt hw hh -                      else transfEllipseAttrs pt hw hh ctm+  -    style_attrs   = fill_a : stroke_a : opts-                    where (fill_a,stroke_a,opts) = drawEllipse c dp+ellipseProps :: EllipseProps -> SvgMonad Doc+ellipseProps (EFill rgb)                   = +    pure (attr_fill rgb <+> attr_stroke_none) -simpleCircleAttrs :: PSUnit u => Point2 u -> u -> [Attr]-simpleCircleAttrs (P2 x y) radius = [attr_cx x, attr_cy y, attr_r radius]+ellipseProps (EStroke attrs rgb)           = +    (\a -> attr_stroke rgb <+> attr_fill_none <+> a)  <$> deltaStrokeAttrs attrs -simpleEllipseAttrs :: PSUnit u => Point2 u -> u -> u -> [Attr]-simpleEllipseAttrs (P2 x y) hw hh = -    [attr_cx x, attr_cy y, attr_rx hw, attr_ry hh]+ellipseProps (EFillStroke frgb attrs srgb) = +    (\a -> attr_fill frgb <+> attr_stroke srgb <+> a) <$> deltaStrokeAttrs attrs  -transfCircleAttrs :: (Real u, Floating u, PSUnit u)-                  => Point2 u -> u -> PrimCTM u -> [Attr]-transfCircleAttrs (P2 x y) radius ctm = -    [ attr_cx (0::Double), attr_cy (0::Double), attr_r radius-    , attr_transform vmtrx ]++-- Note - Rendering coloured text seemed convoluted +-- (mandating the tspan element). +--+-- TO CHECK - is this really the case?+-- +--++primLabel :: (Real u, Floating u, PSUnit u) +      => LabelProps -> PrimLabel u -> SvgMonad Doc+primLabel (LabelProps rgb attrs) (PrimLabel pt etext ctm) = +    (\fa ca txt -> elem_text (fa <+> ca) txt)+      <$> deltaFontAttrs attrs <*> bracketPrimCTM pt ctm mkXY +                               <*> tspan rgb etext   where-    mtrx      = translMatrixRepCTM x y ctm * svg_reflection_matrix-    vmtrx     = valMatrix mtrx+    mkXY (P2 x y) = pure $ attr_x x <+> attr_y y     +tspan :: RGBi -> EncodedText -> SvgMonad Doc+tspan rgb enctext = +    (\txt -> elem_tspan (attr_fill rgb) txt) +      <$> encodedText enctext -transfEllipseAttrs :: (Real u, Floating u, PSUnit u)-                   => Point2 u -> u -> u -> PrimCTM u -> [Attr]-transfEllipseAttrs (P2 x y) hw hh ctm = -    [ attr_cx (0::Double), attr_cy (0::Double), attr_rx hw, attr_ry hh-    , attr_transform vmtrx ]+encodedText :: EncodedText -> SvgMonad Doc+encodedText enctext = hcat <$> mapM textChunk (getEncodedText enctext)+++textChunk :: TextChunk -> SvgMonad Doc+textChunk (SText s)  = pure $ text s+textChunk (EscInt i) = pure $ text $ escapeSpecial i+textChunk (EscStr s) = either text text <$> askGlyphName s +++--------------------------------------------------------------------------------+-- Stroke and font attribute delta++deltaStrokeAttrs :: [StrokeAttr] -> SvgMonad Doc+deltaStrokeAttrs xs = hsep <$> mapM df xs   where-    mtrx      = translMatrixRepCTM x y ctm * svg_reflection_matrix-    vmtrx     = valMatrix mtrx+    df (LineWidth d)    = (\inh -> if d==inh then empty +                                         else attr_stroke_width d) +                            <$> askLineWidth +    df (MiterLimit d)   = (\inh -> if d==inh then empty +                                         else attr_stroke_miterlimit d)+                            <$> askMiterLimit --- A rule of thumb seems to be that SVG (at least SVG in Firefox)--- will try to fill unless told not to. So always label paths--- with @fill=...@ even if fill is @\"none\"@.------ CFill   ==> stroke="none" fill="..."--- CStroke ==> stroke="..."  fill="none"--- OStroke ==> stroke="..."  fill="none"---+    df (LineCap d)      = (\inh -> if d==inh then empty +                                         else attr_stroke_linecap d)+                            <$> askLineCap -drawProperties :: PSColour c => c -> DrawPath -> (Attr, Attr, [Attr])-drawProperties = fn where-  fn c CFill        = (attr_fill c, attr_stroke_none, [])-  fn c (OStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)-  fn c (CStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)+    df (LineJoin d)     = (\inh -> if d==inh then empty +                                         else attr_stroke_linejoin d)+                            <$> askLineJoin -drawEllipse :: PSColour c => c -> DrawEllipse -> (Attr, Attr, [Attr])-drawEllipse = fn where-  fn c EFill        = (attr_fill c, attr_stroke_none, [])-  fn c (EStroke xs) = (attr_fill_none, attr_stroke c, strokeAttributes xs)- +    df (DashPattern d)  = (\inh -> if d==inh then empty +                                             else makeDashPattern d) +                            <$> askDashPattern -strokeAttributes :: [StrokeAttr] -> [Attr]-strokeAttributes = foldr fn [] where-  fn (LineWidth a)    = (:) (attr_stroke_width a)-  fn (MiterLimit a)   = (:) (attr_stroke_miterlimit a)-  fn (LineCap lc)     = (:) (attr_stroke_linecap lc)-  fn (LineJoin lj)    = (:) (attr_stroke_linejoin lj)-  fn (DashPattern dp) = dash dp where-    dash Solid       = (:) (attr_stroke_dasharray_none)-    dash (Dash _ []) = (:) (attr_stroke_dasharray_none)-    dash (Dash i xs) = (:) (attr_stroke_dashoffset i) . -                       (:) (attr_stroke_dasharray $ conv xs)-    conv = foldr (\(x,y) a -> x:y:a) []  +makeDashPattern :: DashPattern -> Doc+makeDashPattern Solid       = attr_stroke_dasharray_none+makeDashPattern (Dash n xs) = +    attr_stroke_dashoffset n <+> attr_stroke_dasharray xs  -svgPath :: PSUnit u => DrawPath -> Path u -> SvgPath-svgPath (OStroke _) p = pathInstructions p-svgPath _           p = closePath $ pathInstructions p +deltaFontAttrs :: FontAttr -> SvgMonad Doc+deltaFontAttrs fa  = +    (\inh -> if fa ==inh then empty else makeFontAttrs fa) <$> askFontAttr -pathInstructions :: PSUnit u => Path u -> [String]-pathInstructions (Path (P2 x y) xs) = path_m x y : map pathSegment xs+makeFontAttrs :: FontAttr -> Doc+makeFontAttrs (FontAttr sz face) = +    attr_font_family (svg_font_family face) <+> attr_font_size sz +                                            <> suffix (svg_font_style face) +  where  +    suffix SVG_REGULAR      = empty -pathSegment :: PSUnit u => PathSegment u -> String-pathSegment (PLineTo (P2 x1 y1))                        = path_l x1 y1-pathSegment (PCurveTo (P2 x1 y1) (P2 x2 y2) (P2 x3 y3)) = -    path_c x1 y1 x2 y2 x3 y3+    suffix SVG_BOLD         = space <> attr_font_weight "bold" +    suffix SVG_ITALIC       = space <> attr_font_style "italic" +    suffix SVG_BOLD_ITALIC  = +        space <> attr_font_weight "bold" <+> attr_font_style "italic" -frameChange :: PSUnit u => Frame2 u -> Maybe Attr-frameChange fr -    | standardFrame fr = Nothing-    | otherwise        = Just $ attr_transform $ val_matrix a b c d e f -  where-    CTM a b c d e f = toCTM fr+    suffix SVG_OBLIQUE      = space <> attr_font_style "oblique" +    suffix SVG_BOLD_OBLIQUE = +        space <> attr_font_weight "bold" <+> attr_font_style "oblique"  -closePath :: SvgPath -> SvgPath -closePath xs = xs ++ ["Z"] -snoc_attrs :: Element -> [Attr] -> Element-snoc_attrs = flip add_attrs+--------------------------------------------------------------------------------+-- Bracket matrix and PrimCTM trafos +bracketTrafos :: (Real u, Floating u, PSUnit u) +              => [AffineTrafo u] -> SvgMonad Doc -> SvgMonad Doc+bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma  +bracketMatrix :: (Fractional u, PSUnit u) +              => Matrix3'3 u -> SvgMonad Doc -> SvgMonad Doc+bracketMatrix mtrx ma +    | mtrx == identityMatrix = (\doc -> elem_g_no_attrs doc) <$>  ma+    | otherwise              = (\doc -> elem_g trafo doc) <$> ma+  where+    trafo = attr_transform $ val_matrix mtrx -valMatrix :: PSUnit u => Matrix3'3 u -> String-valMatrix m33 = val_matrix a b c d x y++bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u)+               => Point2 u -> PrimCTM u +               -> (Point2 u -> SvgMonad Doc) -> SvgMonad Doc+bracketPrimCTM pt@(P2 x y) ctm pf +    | ctm == identityCTM  = pf pt+    | otherwise           = (\xy -> xy <+> attr_transform mtrx) <$> pf zeroPt'   where-    CTM a b c d x y = toCTM m33+    zeroPt' :: Point2 u+    zeroPt' = zeroPt++    mtrx  = val_matrix $ translMatrixRepCTM x y ctm

@@ -0,0 +1,65 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.PageTranslation+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Core page translation for SVG.+--+--------------------------------------------------------------------------------+++module Wumpus.Core.PageTranslation+  ( ++    trivialTranslation++  ) where++import Wumpus.Core.AffineTrans+import Wumpus.Core.PictureInternal++++--------------------------------------------------------------------------------+-- trivial translation++-- Rescale the entire image (1,-1), rescale the ellipse and +-- label primitives as they are encoutered (1,-1). No need to +-- worry about scaling the BoundingBox+--++trivialTranslation :: (Num u, Ord u) => Picture u -> Picture u+trivialTranslation pic = scale 1 (-1) (trivPic pic)++trivPic :: Num u => Picture u -> Picture u+trivPic (Leaf lc ones)      = Leaf lc $ fmap trivPrim ones+trivPic (Picture lc ones)   = Picture lc $ fmap trivPic ones+trivPic (Clip lc pp pic)    = Clip lc pp $ trivPic pic+trivPic (Group lc upd pic)  = Group lc upd $ trivPic pic++trivPrim :: Num u => Primitive u -> Primitive u+trivPrim (PPath a xl pp)     = PPath a xl pp+trivPrim (PLabel a xl lbl)   = PLabel a xl (trivLabel lbl)+trivPrim (PEllipse a xl ell) = PEllipse a xl (trivEllipse ell)+++trivLabel :: Num u => PrimLabel u -> PrimLabel u+trivLabel (PrimLabel pt txt ctm) = PrimLabel pt txt (trivPrimCTM ctm)++trivEllipse :: Num u => PrimEllipse u -> PrimEllipse u+trivEllipse (PrimEllipse ctr hw hh ctm) = +    PrimEllipse ctr hw hh (trivPrimCTM ctm)++-- Is the translation here just negating the angle with scaling+-- left untouched?+--+trivPrimCTM :: Num u => PrimCTM u -> PrimCTM u+trivPrimCTM (PrimCTM sx sy theta) = PrimCTM sx (-sy) theta+

@@ -8,180 +8,133 @@ -- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 ----- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC -- -- Construction of pictures, paths and text labels.--- +-- -------------------------------------------------------------------------------- -module Wumpus.Core.Picture -  (-  -   -- * Construction-    blankPicture-  , frame-  , frameWithin-  , frameMulti-  , multi +module Wumpus.Core.Picture+  (  +  -- * Construction+    frame+  , multi   , path   , lineTo   , curveTo-  , vertexPath  +  , vertexPath   , curvedPath--  , wumpus_default_font+  , xlinkhref    -- * Constructing primitives   , Stroke(..)   , zostroke   , zcstroke-   , Fill(..)   , zfill-  +  , Ellipse(..)+  , zellipse+   , clip    , TextLabel(..)   , ztextlabel -  , Ellipse(..)-  , zellipse-   -- * Operations-  , extendBoundary-+  , extendBoundary   -  -- * Minimal - picture composition-  , picMoveBy+  -- * Picture composition   , picOver+  , picMoveBy   , picBeside++  -- * Illustrating pictures and primitives+  , printPicture   , illustrateBounds-  , illustrateBoundsPrim +  , illustrateBoundsPrim   , illustrateControlPoints    ) where +import Wumpus.Core.AffineTrans 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.PictureInternal import Wumpus.Core.PtSize-import Wumpus.Core.TextEncodingInternal+import Wumpus.Core.TextInternal+import Wumpus.Core.Utils -import Data.Semigroup+import Data.AffineSpace                         -- package: vector-space+import Data.Semigroup                           -- package: algebra  --------------------------------------------------------------------------------- --- Default attributes -psBlack :: PSRgb-psBlack = RGB3 0 0 0- --- aka the standard frame-stdFrame :: Num u => Frame2 u -stdFrame = ortho zeroPt-- -------------------------------------------------------------------------------- -- Construction  ---- | Create a blank 'Picture' sized to the supplied bounding box.--- This is useful for spacing rows or columns of pictures.----blankPicture :: Num u => BoundingBox u -> Picture u-blankPicture bb = PicBlank (stdFrame, bb)----- | Lift a 'Primitive' to a 'Picture', located in the standard frame.----frame :: (Real u, Floating u, FromPtSize u) => Primitive u -> Picture u-frame p = Single (stdFrame, boundary p) p ---- | Frame a picture within the supplied bounding box--- --- A text label uses the supplied bounding box as is - no --- clipping is performed if the bounding box is --- smaller than the boundary size of the text. This may --- cause strange overlap for subsequent composite pictures, and--- incorrect bounding box annotations in the prologue of the --- generated EPS file. --- --- Paths and ellipses are bound within the union of the supplied --- bounding box and the inherent bounding box or the path or --- ellipse. Thus the bounding box will never reframed to a --- smaller size than the /natural/ bounding box.----frameWithin :: (Real u, Floating u, FromPtSize u) -            => Primitive u -> BoundingBox u -> Picture u-frameWithin p@(PLabel _ _) bb = Single (stdFrame,bb) p-frameWithin p              bb = Single (stdFrame,bb `append` boundary p) p------- | Lift a list of primitives to a composite picture, all --- primitives will be located within the standard frame.+-- | Lift a list of primitives to a composite picture. -- -- The order of the list maps to the zorder - the front of the -- list is drawn at the top. -- -- This function throws an error when supplied the empty list. ---frameMulti :: (Real u, Floating u, FromPtSize u) -           => [Primitive u] -> Picture u-frameMulti [] = error "Wumpus.Core.Picture.frameMulti - empty list"-frameMulti xs = multi $ map frame xs+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 )  --- | Place multiple pictures within the same affine frame.++-- | Place multiple pictures within the standard affine frame. -- -- This function throws an error when supplied the empty list. -- multi :: (Fractional u, Ord u) => [Picture u] -> Picture u-multi ps = Picture (stdFrame, sconcat $ map boundary ps) $ step ps-  where -    sconcat []      = error err_msg-    sconcat (x:xs)  = foldr append x xs--    step [x]        = one x-    step (x:xs)     = x `cons` step xs-    step _          = error err_msg--    err_msg         = "Wumpus.Core.Picture.multi - empty list"+multi []      = error "Wumpus.Core.Picture.multi - empty list"+multi (p:ps)  = let (bb,ones) = step p ps in Picture (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 )   --- | Create a Path from a start point and a list of --- PathSegments.-path :: Point2 u -> [PathSegment u] -> Path u-path = Path +-- | Create a Path from a start point and a list of PathSegments.+--+path :: Point2 u -> [PrimPathSegment u] -> PrimPath u+path = PrimPath   -- | Create a straight-line PathSegment. ---lineTo :: Point2 u -> PathSegment u+lineTo :: Point2 u -> PrimPathSegment u lineTo = PLineTo  -- | Create a curved PathSegment. ---curveTo :: Point2 u -> Point2 u -> Point2 u -> PathSegment u+curveTo :: Point2 u -> Point2 u -> Point2 u -> PrimPathSegment u curveTo = PCurveTo   -- | Convert the list of vertices to a path of straight line  -- segments. ---vertexPath :: [Point2 u] -> Path u+vertexPath :: [Point2 u] -> PrimPath u vertexPath []     = error "Picture.vertexPath - empty point list"-vertexPath (x:xs) = Path x (map PLineTo xs)+vertexPath (x:xs) = PrimPath x (map PLineTo xs)   @@ -190,39 +143,29 @@ -- segment thereafter takes 3 points. /Spare/ points at the end  -- are discarded.  ---curvedPath :: [Point2 u] -> Path u+curvedPath :: [Point2 u] -> PrimPath u curvedPath []     = error "Picture.curvedPath - empty point list"-curvedPath (x:xs) = Path x (fn xs) where-  fn (a:b:c:ys) = PCurveTo a b c : fn ys -  fn _          = []---  ----- | Constant for the default font, which is @Courier@ (aliased --- to @Courier New@ for SVG) at 24 point.-------wumpus_default_font :: FontAttr-wumpus_default_font = FontAttr 24 face +curvedPath (x:xs) = PrimPath x (step xs)    where-    face = FontFace { font_name         = "Courier"-                    , svg_font_family   = "Courier New"-                    , svg_font_style    = SVG_REGULAR-                    }+    step (a:b:c:ys) = PCurveTo a b c : step ys +    step _          = []  +xlinkhref :: String -> XLink+xlinkhref = XLinkHRef  -------------------------------------------------------------------------------- -- Take Paths to Primitives +-- *** Stroke -ostrokePath :: Num u => PSRgb -> [StrokeAttr] -> Path u -> Primitive u-ostrokePath c attrs p = PPath (c, OStroke attrs) p+ostrokePath :: Num u +            => RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u+ostrokePath rgb attrs xlink p = PPath (OStroke attrs rgb) xlink p -cstrokePath :: Num u => PSRgb -> [StrokeAttr] -> Path u -> Primitive u-cstrokePath c attrs p = PPath (c, CStroke attrs) p+cstrokePath :: Num u +            => RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u+cstrokePath rgb attrs xlink p = PPath (CStroke attrs rgb) xlink p  -- | Create a open, stroked path (@ostroke@) or a closed, stroked -- path (@cstroke@).@@ -231,79 +174,74 @@ -- the path more convenient. --  class Stroke t where-  ostroke :: Num u => t -> Path u -> Primitive u-  cstroke :: Num u => t -> Path u -> Primitive u+  ostroke :: Num u => t -> PrimPath u -> Primitive u+  cstroke :: Num u => t -> PrimPath u -> Primitive u  instance Stroke () where-  ostroke () = ostrokePath psBlack []-  cstroke () = cstrokePath psBlack []--instance Stroke (RGB3 Double) where-  ostroke c = ostrokePath (psColour c) []-  cstroke c = cstrokePath (psColour c) []--instance Stroke (HSB3 Double) where-  ostroke c = ostrokePath (psColour c) []-  cstroke c = cstrokePath (psColour c) []--instance Stroke (Gray Double) where-  ostroke c = ostrokePath (psColour c) []-  cstroke c = cstrokePath (psColour c) []+  ostroke () = ostrokePath black [] NoLink+  cstroke () = cstrokePath black [] NoLink +instance Stroke RGBi where+  ostroke rgb = ostrokePath rgb [] NoLink+  cstroke rgb = cstrokePath rgb [] NoLink  instance Stroke StrokeAttr where-  ostroke x = ostrokePath psBlack [x]-  cstroke x = cstrokePath psBlack [x]+  ostroke x = ostrokePath black [x] NoLink+  cstroke x = cstrokePath black [x] NoLink  instance Stroke [StrokeAttr] where-  ostroke xs = ostrokePath psBlack xs-  cstroke xs = cstrokePath psBlack xs+  ostroke xs = ostrokePath black xs NoLink+  cstroke xs = cstrokePath black xs NoLink +instance Stroke XLink where+  ostroke xlink = ostrokePath black [] xlink+  cstroke xlink = cstrokePath black [] xlink  -instance Stroke (RGB3 Double,StrokeAttr) where-  ostroke (c,x) = ostrokePath (psColour c) [x]-  cstroke (c,x) = cstrokePath (psColour c) [x]+instance Stroke (RGBi,StrokeAttr) where+  ostroke (rgb,x) = ostrokePath rgb [x] NoLink+  cstroke (rgb,x) = cstrokePath rgb [x] NoLink -instance Stroke (HSB3 Double,StrokeAttr) where-  ostroke (c,x) = ostrokePath (psColour c) [x]-  cstroke (c,x) = cstrokePath (psColour c) [x]+instance Stroke (RGBi,[StrokeAttr]) where+  ostroke (rgb,xs) = ostrokePath rgb xs NoLink+  cstroke (rgb,xs) = cstrokePath rgb xs NoLink -instance Stroke (Gray Double,StrokeAttr) where-  ostroke (c,x) = ostrokePath (psColour c) [x]-  cstroke (c,x) = cstrokePath (psColour c) [x]+instance Stroke (RGBi,XLink) where+  ostroke (rgb,xlink) = ostrokePath rgb [] xlink+  cstroke (rgb,xlink) = cstrokePath rgb [] xlink -instance Stroke (RGB3 Double,[StrokeAttr]) where-  ostroke (c,xs) = ostrokePath (psColour c) xs-  cstroke (c,xs) = cstrokePath (psColour c) xs+instance Stroke (StrokeAttr,XLink) where+  ostroke (x,xlink) = ostrokePath black [x] xlink+  cstroke (x,xlink) = cstrokePath black [x] xlink -instance Stroke (HSB3 Double,[StrokeAttr]) where-  ostroke (c,xs) = ostrokePath (psColour c) xs-  cstroke (c,xs) = cstrokePath (psColour c) xs+instance Stroke ([StrokeAttr],XLink) where+  ostroke (xs,xlink) = ostrokePath black xs xlink+  cstroke (xs,xlink) = cstrokePath black xs xlink -instance Stroke (Gray Double,[StrokeAttr]) where-  ostroke (c,xs) = ostrokePath (psColour c) xs-  cstroke (c,xs) = cstrokePath (psColour c) xs+instance Stroke (RGBi,StrokeAttr,XLink) where+  ostroke (rgb,x,xlink) = ostrokePath rgb [x] xlink+  cstroke (rgb,x,xlink) = cstrokePath rgb [x] xlink +instance Stroke (RGBi,[StrokeAttr],XLink) where+  ostroke (rgb,xs,xlink) = ostrokePath rgb xs xlink+  cstroke (rgb,xs,xlink) = cstrokePath rgb xs xlink + -- | Create an open stoke coloured black. ---zostroke :: Num u => Path u -> Primitive u-zostroke = ostrokePath psBlack []+zostroke :: Num u => PrimPath u -> Primitive u+zostroke = ostrokePath black [] NoLink   -- | Create a closed stroke coloured black. ---zcstroke :: Num u => Path u -> Primitive u-zcstroke = cstrokePath psBlack []----+zcstroke :: Num u => PrimPath u -> Primitive u+zcstroke = cstrokePath black [] NoLink  +-- *** Fill -fillPath :: Num u => PSRgb -> Path u -> Primitive u-fillPath c p = PPath (c,CFill) p+fillPath :: Num u => RGBi -> XLink -> PrimPath u -> Primitive u+fillPath rgb xlink p = PPath (CFill rgb) xlink p  -- | Create a filled path (@fill@). Fills only have one  -- property - colour. But there are various representations of @@ -312,36 +250,51 @@ -- @ fill () @ will fill with the default colour - black. --  class Fill t where-  fill :: Num u => t -> Path u -> Primitive u+  fill :: Num u => t -> PrimPath u -> Primitive u   -instance Fill ()                where fill () = fillPath psBlack -instance Fill (RGB3 Double)     where fill = fillPath . psColour-instance Fill (HSB3 Double)     where fill = fillPath . psColour-instance Fill (Gray Double)     where fill = fillPath . psColour+instance Fill ()                where fill ()    = fillPath black NoLink+instance Fill RGBi              where fill rgb   = fillPath rgb   NoLink+instance Fill XLink             where fill xlink = fillPath black xlink +instance Fill (RGBi,XLink) where+  fill (rgb,xlink) = fillPath rgb xlink++ -- | Create a filled path coloured black. -zfill :: Num u => Path u -> Primitive u-zfill = fillPath psBlack+zfill :: Num u => PrimPath u -> Primitive u+zfill = fillPath black NoLink  -------------------------------------------------------------------------------- -- Clipping   -- | Clip a picture with respect to the supplied path. ---clip :: (Num u, Ord u) => Path u -> Picture u -> Picture u-clip cp p = Clip (ortho zeroPt, boundary cp) cp p-+clip :: (Num u, Ord u) => PrimPath u -> Picture u -> Picture u+clip cp p = Clip (pathBoundary cp, []) cp p  -------------------------------------------------------------------------------- -- Labels to primitive -mkTextLabel :: Num u => PSRgb -> FontAttr -> String -> Point2 u -> Primitive u-mkTextLabel c attr txt pt = PLabel (c,attr) lbl +mkTextLabel :: Num u +            => RGBi -> FontAttr -> XLink -> String -> Point2 u -> Primitive u+mkTextLabel rgb attr xlink txt pt = PLabel (LabelProps rgb attr) xlink lbl    where-    lbl = Label pt (lexLabel txt) identityCTM+    lbl = PrimLabel pt (lexLabel txt) identityCTM +-- | 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+                    } + -- | Create a text label. The string should not contain newline -- or tab characters. Use 'multilabel' to create text with  -- multiple lines.@@ -349,7 +302,7 @@ -- @textlabel@ is overloaded to make attributing the label more  -- convenient. ----- Unless a 'FontAttr' is specified, the label will use 12pt +-- Unless a 'FontAttr' is specified, the label will use 14pt  -- Courier. -- -- The supplied point is is the bottom left corner.@@ -359,45 +312,47 @@   instance TextLabel () where -    textlabel () = mkTextLabel psBlack wumpus_default_font+    textlabel () = mkTextLabel black wumpus_default_font NoLink -instance TextLabel (RGB3 Double) where-  textlabel c = mkTextLabel (psColour c) wumpus_default_font+instance TextLabel RGBi where+  textlabel rgb = mkTextLabel rgb wumpus_default_font NoLink -instance TextLabel (HSB3 Double) where-  textlabel c = mkTextLabel (psColour c) wumpus_default_font+instance TextLabel FontAttr where+  textlabel a = mkTextLabel black a NoLink -instance TextLabel (Gray Double) where-  textlabel c = mkTextLabel (psColour c) wumpus_default_font+instance TextLabel XLink where+    textlabel xlink = mkTextLabel black wumpus_default_font xlink -instance TextLabel FontAttr where-  textlabel a = mkTextLabel psBlack a -instance TextLabel (RGB3 Double,FontAttr) where-  textlabel (c,a) = mkTextLabel (psColour c) a+instance TextLabel (RGBi,FontAttr) where+  textlabel (rgb,a) = mkTextLabel rgb a NoLink -instance TextLabel (HSB3 Double,FontAttr) where-  textlabel (c,a) = mkTextLabel (psColour c) a+instance TextLabel (RGBi,XLink) where+  textlabel (rgb,xlink) = mkTextLabel rgb wumpus_default_font xlink -instance TextLabel (Gray Double,FontAttr) where-  textlabel (c,a) = mkTextLabel (psColour c) a+instance TextLabel (FontAttr,XLink) where+  textlabel (a,xlink) = mkTextLabel black a xlink --- | Create a label where the font is @Courier@, text size is 24pt+instance TextLabel (RGBi,FontAttr,XLink) where+  textlabel (rgb,a,xlink) = mkTextLabel rgb a xlink++-- | Create a label where the font is @Courier@, text size is 14pt -- and colour is black.+-- ztextlabel :: Num u => String -> Point2 u -> Primitive u-ztextlabel = mkTextLabel psBlack wumpus_default_font-+ztextlabel = mkTextLabel black wumpus_default_font NoLink   --------------------------------------------------------------------------------  mkEllipse :: Num u -          => PSRgb -> DrawEllipse -> u -> u -> Point2 u -> Primitive u-mkEllipse c dp hw hh pt = PEllipse (c,dp) (PrimEllipse pt hw hh identityCTM)+          => EllipseProps -> XLink -> u -> u -> Point2 u -> Primitive u+mkEllipse props xlink hw hh pt = +    PEllipse props xlink (PrimEllipse pt hw hh identityCTM)   ellipseDefault :: EllipseProps-ellipseDefault = (psBlack, EFill)+ellipseDefault = EFill black   -- | Create an ellipse, the ellipse will be filled unless the @@ -420,65 +375,45 @@ class Ellipse t where   ellipse :: Fractional u => t -> u -> u -> Point2 u -> Primitive u -instance Ellipse ()             where ellipse () = zellipse-instance Ellipse DrawEllipse    where ellipse dp = mkEllipse psBlack dp -instance Ellipse StrokeAttr     where -    ellipse = mkEllipse psBlack . EStroke . return--instance Ellipse [StrokeAttr]   where -    ellipse = mkEllipse psBlack . EStroke--instance Ellipse (RGB3 Double) where -    ellipse c = mkEllipse (psColour c) EFill--instance Ellipse (HSB3 Double) where -    ellipse c = mkEllipse (psColour c) EFill--instance Ellipse (Gray Double) where -    ellipse c = mkEllipse (psColour c) EFill---instance Ellipse (RGB3 Double,DrawEllipse) where -    ellipse (c,dp) = mkEllipse (psColour c) dp+instance Ellipse ()             where ellipse () = zellipse -instance Ellipse (HSB3 Double,DrawEllipse) where -    ellipse (c,dp) = mkEllipse (psColour c) dp+instance Ellipse RGBi where +  ellipse rgb = mkEllipse (EFill rgb) NoLink -instance Ellipse (Gray Double,DrawEllipse) where -    ellipse (c,dp) = mkEllipse (psColour c) dp+instance Ellipse StrokeAttr where+  ellipse x = mkEllipse (EStroke [x] black) NoLink +instance Ellipse [StrokeAttr] where+  ellipse xs = mkEllipse (EStroke xs black) NoLink -instance Ellipse (RGB3 Double,StrokeAttr) where -    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])+instance Ellipse XLink where +  ellipse xlink = mkEllipse (EFill black) xlink -instance Ellipse (HSB3 Double,StrokeAttr) where -    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])+instance Ellipse (RGBi,StrokeAttr) where+  ellipse (rgb,x) = mkEllipse (EStroke [x] rgb) NoLink -instance Ellipse (Gray Double,StrokeAttr) where -    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])+instance Ellipse (RGBi,[StrokeAttr]) where+  ellipse (rgb,xs) = mkEllipse (EStroke xs rgb) NoLink -instance Ellipse (RGB3 Double,[StrokeAttr]) where -    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)+instance Ellipse (RGBi,XLink) where+  ellipse (rgb,xlink) = mkEllipse (EFill rgb) xlink -instance Ellipse (HSB3 Double,[StrokeAttr]) where -    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)+instance Ellipse (StrokeAttr,XLink) where+  ellipse (x,xlink) = mkEllipse (EStroke [x] black) xlink -instance Ellipse (Gray Double,[StrokeAttr]) where -    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)+instance Ellipse ([StrokeAttr],XLink) where+  ellipse (xs,xlink) = mkEllipse (EStroke xs black) xlink +instance Ellipse (RGBi,[StrokeAttr],XLink) where+  ellipse (rgb,xs,xlink) = mkEllipse (EStroke xs rgb) xlink  -- | Create a black, filled ellipse.  zellipse :: Num u => u -> u -> Point2 u -> Primitive u-zellipse = uncurry mkEllipse ellipseDefault-+zellipse hw hh pt = mkEllipse ellipseDefault NoLink hw hh pt  ------------------------------------------------------------------------------------ Operations on pictures and paths---+-- Operations  -- | Extend the bounding box of a picture.  --@@ -487,7 +422,7 @@ -- This function cannot be used to shrink a boundary. -- extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u-extendBoundary x y = mapLocale (\(fr,bb) -> (fr, extBB (posve x) (posve y) bb)) +extendBoundary x y = mapLocale (\(bb,xs) -> (extBB (posve x) (posve y) bb, xs))    where     extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where          pt1 = P2 (x0-x') (y0-y')@@ -507,16 +442,16 @@ -- neither picture will be moved. -- picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u-a `picOver` b = Picture (ortho zeroPt, bb) (cons a $ one b) +a `picOver` b = Picture (bb,[]) (cons a $ one b)   where-    bb = union (boundary a) (boundary b)+    bb = boundary a `append` boundary b  -- | 'picMoveBy' : @ picture -> vector -> picture @ --  --  Move a picture by the supplied vector.  ---picMoveBy :: Num u => Picture u -> Vec2 u -> Picture u-p `picMoveBy` v = v `movePic` p +picMoveBy :: (Num u, Ord u) => Picture u -> Vec2 u -> Picture u+p `picMoveBy` (V2 dx dy) = translate dx dy p   -- | 'picBeside' : @ picture -> picture -> picture @ --@@ -526,16 +461,27 @@ picBeside :: (Num u, Ord u) => Picture u -> Picture u -> Picture u a `picBeside` b = a `picOver` (b `picMoveBy` v)    where -    v = hvec $ rightPlane (boundary a) - leftPlane (boundary b) +    (P2 x1 _) = ur_corner $ boundary a+    (P2 x2 _) = ll_corner $ boundary b +    v         = hvec $ x1 - x2  +--------------------------------------------------------------------------------+-- Illustrating pictures and primitives++-- | Print the syntax tree of a Picture to the console.+--+printPicture :: (Num u, PSUnit u) => Picture u -> IO ()+printPicture pic = putStrLn (show $ format pic) >> putStrLn []++ -- | 'illustrateBounds' : @ colour -> 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. -- illustrateBounds :: (Real u, Floating u, FromPtSize u) -                 => DRGB -> Picture u -> Picture u-illustrateBounds rgb p = p `picOver` (frameMulti $ boundsPrims rgb p) +                 => RGBi -> Picture u -> Picture u+illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb p)    -- | 'illustrateBoundsPrim' : @ colour -> primitive -> picture @@@ -546,26 +492,26 @@ -- The result will be lifted from Primitive to Picture. --  illustrateBoundsPrim :: (Real u, Floating u, FromPtSize u) -                     => DRGB -> Primitive u -> Picture u-illustrateBoundsPrim rgb p = frameMulti (boundsPrims rgb p ++ [p])+                     => RGBi -> Primitive u -> Picture u+illustrateBoundsPrim rgb p = frame (p : boundsPrims rgb p) --- Note - above has to use snoc (++ [p]) to get the picture to--- draw above the bounding box image.   -- | Draw a the rectangle of a bounding box, plus cross lines -- joining the corners. -- boundsPrims :: (Num u, Ord u, Boundary t, u ~ DUnit t) -            => DRGB -> t -> [Primitive u]+            => RGBi -> t -> [Primitive u] boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ]   where-    (bl,br,tr,tl) = corners $ boundary a-    bbox_rect     = cstroke rgb $ vertexPath [bl,br,tr,tl]-    bl_to_tr      = ostroke rgb $ vertexPath [bl,tr]-    br_to_tl      = ostroke rgb $ vertexPath [br,tl]+    (bl,br,tr,tl) = boundaryCorners $ boundary a+    bbox_rect     = cstroke (rgb, line_attr) $ vertexPath [bl,br,tr,tl]+    bl_to_tr      = ostroke (rgb, line_attr) $ vertexPath [bl,tr]+    br_to_tl      = ostroke (rgb, line_attr) $ vertexPath [br,tl] +    line_attr     = [LineCap $ CapRound, DashPattern $ Dash 0 [(1,2)]] + -- | Generate the control points illustrating the Bezier  -- curves within a picture. -- @@ -577,12 +523,12 @@ -- @arc@ command.   -- illustrateControlPoints :: (Real u, Floating u, FromPtSize u)-                        => DRGB -> Primitive u -> Picture u+                        => RGBi -> Primitive u -> Picture u illustrateControlPoints rgb prim = step prim   where-    step (PEllipse _ e) = frameMulti (prim : ellipseCtrlLines rgb e)-    step (PPath    _ p) = frameMulti (prim : pathCtrlLines rgb p)-    step _              = frame prim+    step (PEllipse _ _ e) = frame (prim : ellipseCtrlLines rgb e)+    step (PPath    _ _ p) = frame (prim : pathCtrlLines rgb p)+    step _                = frame [prim]  -- Genrate lines illustrating the control points of curves on  -- a Path.@@ -592,15 +538,15 @@ -- -- Nothing is generated for a straight line. ---pathCtrlLines :: (Num u, Ord u) => DRGB -> Path u -> [Primitive u]-pathCtrlLines rgb (Path start ss) = step start ss+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...     step _ []                    = []     step _ (PLineTo e:xs)        = step e xs     step s (PCurveTo c1 c2 e:xs) = mkLine s c1 : mkLine c2 e : step e xs  -    mkLine s e                   = ostroke rgb (Path s [lineTo e]) +    mkLine s e                   = ostroke rgb (PrimPath s [lineTo e])    -- Generate lines illustrating the control points of an @@ -610,7 +556,7 @@ -- start-point to control-point1; control-point2 to end-point -- ellipseCtrlLines :: (Real u, Floating u) -                 => DRGB -> PrimEllipse u -> [Primitive u]+                 => RGBi -> PrimEllipse u -> [Primitive u] ellipseCtrlLines rgb pe = start all_points   where      -- list in order: @@ -624,6 +570,41 @@     rest s (c1:c2:e:xs)  = mkLine s c1 : mkLine c2 e : rest e xs     rest _ _             = [] -    mkLine s e           = ostroke rgb (Path s [lineTo e]) +    mkLine s e           = ostroke rgb (PrimPath s [lineTo e])  +++-- | Get the control points as a list+-- +-- There are no duplicates in the list except for the final +-- /wrap-around/. We take 4 points initially (start,cp1,cp2,end)+-- then (cp1,cp2,end) for the other three quadrants.+--+ellipseControlPoints :: (Floating u, Real u)+                     => PrimEllipse u -> [Point2 u]+ellipseControlPoints (PrimEllipse (P2 x y) hw hh ctm) = +    map (disp . (new_mtrx *#)) circ+  where+    disp             = (.+^ V2 x y)+    (radius,(dx,dy)) = circleScalingProps hw hh+    new_mtrx         = matrixRepCTM $ scaleCTM dx dy ctm+    circ             = bezierCircle 1 radius (P2 0 0)++    -- subdivide the bezierCircle with 1 to get two+    -- control points per quadrant.    +++--+-- I don't know how to calculate bezier arcs (and thus control+-- points) for an ellipse but I know how to do it for a circle...+--+-- So a make a circle with the largest of half-width and +-- half-height then apply a scale to the points+-- +circleScalingProps  :: (Fractional u, Ord u) => u -> u -> (u,(u,u))+circleScalingProps hw hh  = (radius, (dx,dy))+  where+    radius     = max hw hh+    (dx,dy)    = if radius == hw then (1, rescale (0,hw) (0,1) hh)+                                 else (rescale (0,hh) (0,1) hw, 1) 

@@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -8,80 +7,79 @@ -- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 ----- Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC ----- Internal representation of Pictures --- +-- Internal representation of Pictures.+-- -------------------------------------------------------------------------------- -module Wumpus.Core.PictureInternal -  (-  -- * Data types++module Wumpus.Core.PictureInternal+  ( +     Picture(..)   , DPicture+  , Locale+  , AffineTrafo(..)+  , GSUpdate(..)+   , Primitive(..)   , DPrimitive-  , Path(..)-  , DPath-  , PathSegment(..)-  , DPathSegment-  , Label(..)-  , DLabel-  , PrimEllipse(..)-  , DPrimEllipse-  , PrimCTM--  , PathProps                   -- hide in Wumpus.Core export?-  , LabelProps                  -- hide in Wumpus.Core export?-  , EllipseProps                -- -  , DrawPath(..)                -- hide in Wumpus.Core export?-  , DrawEllipse(..)-  , Locale  - -  -- * Type class--  , PSUnit(..)+  , XLink(..) +  , PrimPath(..)+  , DPrimPath+  , PathProps(..)+  , PrimPathSegment(..)+  , DPrimPathSegment+  , PrimLabel(..)+  , DPrimLabel+  , LabelProps(..)+  , PrimEllipse(..)+  , EllipseProps(..)+  , PrimCTM(..) -  -- * Transformations on Primitives-  , translatePrimitive-  , rotatePrimitive-  , scalePrimitive-  , uniformScalePrimitive+  , pathBoundary+  , mapLocale    -- * PrimCTM   , identityCTM   , scaleCTM+  , rotateCTM   , matrixRepCTM   , translMatrixRepCTM-  -  -- * Extras-  , mapLocale-  , movePic-  , moveLocale-  , extractFrame-  , repositionProperties-  , ellipseControlPoints +  , rotatePrimitive+  , scalePrimitive+  , uniformScalePrimitive+  , translatePrimitive++  -- * Additional operations+  , concatTrafos+  , deconsMatrix+  , repositionDeltas++   ) where  import Wumpus.Core.AffineTrans 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.PtSize-import Wumpus.Core.TextEncodingInternal+import Wumpus.Core.TextInternal import Wumpus.Core.Utils  -import Data.AffineSpace-import Data.Semigroup+import Data.AffineSpace                         -- package: vector-space -import Text.PrettyPrint.Leijen          -- package: wl-pprint+import qualified Data.Foldable                  as F   @@ -107,31 +105,71 @@ -- optimization to avoid generating excessive graphics state  -- changes in the PostScript code. ----- Apropos the constructors, Picture is a simple non-empty +-- Omitting some details, Picture is a simple non-empty  -- leaf-labelled rose tree via: -- --- > Single (aka leaf) | Picture (OneList tree)+-- > Leaf primitives | Picture [tree] -- -- Where OneList is a variant of the standard list type that  -- disallows empty lists. --  -- The additional constructors are convenience: ----- @PicBlank@ has a bounding box but no content and is useful for--- some picture language operations (e.g. @hsep@).--- -- @Clip@ nests a picture (tree) inside a clipping path. --+-- The @Group@ constructor allows local shared graphics state +-- updates for the SVG renderer - in some instances this can +-- improve the code size of the generated SVG.+--+data Picture u = Leaf     (Locale u)              (OneList (Primitive u))+               | Picture  (Locale u)              (OneList (Picture u))+               | Clip     (Locale u) (PrimPath u) (Picture u)+               | Group    (Locale u) GSUpdate     (Picture u)+  deriving (Show)  -data Picture u = PicBlank (Locale u)-               | Single   (Locale u) (Primitive u)-               | Picture  (Locale u) (OneList (Picture u))-               | Clip     (Locale u) (Path u)      (Picture u)-  deriving (Eq,Show) +-- | Update the graphics state for SVG rendering. +-- +-- Note - this does not change how any of the Primitives are +-- drawn, nor does it change the default colour or font style. +-- It is solely a backdoor into the SVG renderer to potential +-- allow some code size reductions.+--+newtype GSUpdate = GSUpdate { getGSU :: GraphicsState -> GraphicsState } +instance Show GSUpdate where+  show _ = "*function*"++-- | Locale = (bounding box * current translation matrix)+-- +-- Pictures (and sub-pictures) are located frame consisting of a +-- bounding box and a translation matrix (represented as a list +-- of affine transformations). So that pictures can be arranged +-- via vertical and horizontal composition their bounding box is +-- cached.+--+-- In Wumpus, affine transformations (scalings, rotations...)+-- transform the CTM rather than the constituent points of +-- the primitives. Changes of CTM are transmitted to PostScript+-- as @concat@ commands (and matrix transforms in SVG).+--  +-- So that picture composition is remains stable under affine+-- transformation, the corners of bounding boxes are transformed+-- pointwise when the picture is scaled, rotated etc.+--+type Locale u = (BoundingBox u, [AffineTrafo u])+ type DPicture = Picture Double +-- | 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 (line segments and Bezier curves) and @@ -142,8 +180,8 @@ -- least eight curves. This is inconvenient for drawing dots  -- which can otherwise be drawn with a single @arc@ command. -- --- Wumpus does not follow PostScript and employ arcs as general --- path primitives - they are used only to draw ellipses. This +-- Wumpus does not follow PostScript employing arc as a general +-- path primitive - arcs are used only to draw ellipses. This  -- is because arcs do not enjoy the nice properties of Bezier  -- curves, whereby the affine transformation of a Bezier curve  -- can simply be achieved by the affine transformation of it\'s @@ -156,41 +194,68 @@ -- Though typically for affine transformations a Fractional  -- constraint is also obliged. ----data Primitive u = PPath    PathProps    (Path u)-                 | PLabel   LabelProps   (Label u) -                 | PEllipse EllipseProps (PrimEllipse u)+data Primitive u = PPath    PathProps    XLink (PrimPath u)+                 | PLabel   LabelProps   XLink (PrimLabel u)+                 | PEllipse EllipseProps XLink (PrimEllipse u)   deriving (Eq,Show)  type DPrimitive = Primitive Double +-- | Primitives can be annotated with hyperlinks in SVG output.+--+data XLink = NoLink+           | XLinkHRef String+  deriving (Eq,Show) --- | Path - start point and a list of path segments.+-- | PrimPath - start point and a list of path segments. ---data Path u = Path (Point2 u) [PathSegment u]+data PrimPath u = PrimPath (Point2 u) [PrimPathSegment u]   deriving (Eq,Show) -type DPath = Path Double+type DPrimPath = PrimPath Double --- | PathSegment - either a cubic Bezier curve or a line.---  -data PathSegment u = PCurveTo  (Point2 u) (Point2 u) (Point2 u)-                   | PLineTo   (Point2 u)+-- | PrimPathSegment - either a cubic Bezier curve or a line.+--+data PrimPathSegment u = PCurveTo  (Point2 u) (Point2 u) (Point2 u)+                       | PLineTo   (Point2 u)   deriving (Eq,Show) -type DPathSegment = PathSegment Double+type DPrimPathSegment = PrimPathSegment Double --- | Label - represented by bottom left corner and text.+-- | Note when drawn /filled/ and drawn /stroked/ the same+-- polygon will have (slightly) different size: ---data Label u = Label -      { label_bottom_left :: Point2 u-      , label_text        :: EncodedText-      , label_ctm         :: PrimCTM u+-- * 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.+--+data PrimLabel u = PrimLabel +      { label_baseline_left :: Point2 u+      , label_text          :: EncodedText+      , label_ctm           :: PrimCTM u       }   deriving (Eq,Show) -type DLabel = Label Double+type DPrimLabel = PrimLabel Double +data LabelProps   = LabelProps +      { label_colour :: RGBi+      , label_font   :: FontAttr+      }+  deriving (Eq,Ord,Show)++ -- Ellipse represented by center and half_width * half_height -- data PrimEllipse u = PrimEllipse @@ -201,9 +266,20 @@       }    deriving (Eq,Show) -type DPrimEllipse = PrimEllipse Double +-- | 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. +-- data PrimCTM u = PrimCTM        { ctm_scale_x     :: u       , ctm_scale_y     :: u@@ -212,146 +288,251 @@   deriving (Eq,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 DrawPath = CFill | CStroke [StrokeAttr] | OStroke [StrokeAttr]-  deriving (Eq,Show)+--------------------------------------------------------------------------------+-- family instances --- | Ellipses and circles are always closed.-data DrawEllipse = EFill | EStroke [StrokeAttr]-  deriving (Eq,Show)+type instance DUnit (Picture u)     = u+type instance DUnit (Primitive u)   = u+type instance DUnit (PrimEllipse u) = u -type PathProps    = (PSRgb, DrawPath)-type LabelProps   = (PSRgb, FontAttr)-type EllipseProps = (PSRgb, DrawEllipse)+--------------------------------------------------------------------------------+-- instances --- | Locale = (current frame x bounding box)--- --- Pictures (and sub-pictures) are located within an affine frame.--- So pictures can be arranged (vertical and horizontal --- composition) their bounding box is cached.------ In Wumpus, affine transformations (scalings, rotations...)--- transform the frame rather than the constituent points of --- the primitives. Changes of frame are transmitted to PostScript--- as @concat@ commands (and matrix transforms in SVG) - the --- @point-in-world-coordinate@ of a point on a path is never --- calculated.---  --- So that picture composition is remains stable under affine--- transformation, the corners of bounding boxes are transformed--- pointwise when the picture is scaled, rotated etc.----type Locale u = (Frame2 u, BoundingBox u)  +instance (Num u, PSUnit u) => Format (Picture u) where+  format (Leaf m prims)     = indent 2 $ vcat [ text "** Leaf-pic **"+                                              , fmtLocale m +                                              , fmtPrims prims ] +  format (Picture m pics)   = indent 2 $ vcat [ text "** Tree-pic **"+                                              , fmtLocale m+                                              , fmtPics pics ]+ +  format (Clip m path pic)  = indent 2 $ vcat [ text "** Clip-path **"+                                              , fmtLocale m+                                              , format path+                                              , format pic  ] +  format (Group m _ pic)    = indent 2 $ vcat [ text "** Group **"+                                              , fmtLocale m+                                              , format pic  ]  ------------------------------------------------------------------------------------ Pretty printing+fmtPics :: PSUnit u => OneList (Picture u) -> Doc+fmtPics ones = snd $ F.foldl' fn (0,empty) ones+  where+    fn (n,acc) e = (n+1, vcat [ acc, text "-- " <+> int n, format e, line]) -instance (Num u, Pretty u) => Pretty (Picture u) where-  pretty (PicBlank m)       = text "*BLANK*" <+> ppLocale m-  pretty (Single m prim)    = ppLocale m <$> indent 2 (pretty prim)-  pretty (Picture m ones)   = -      ppLocale m <$> indent 2 (list $ toListF pretty ones)+fmtPrims :: PSUnit u => OneList (Primitive u) -> Doc+fmtPrims ones = snd $ F.foldl' fn (0,empty) ones+  where+    fn (n,acc) e = (n+1, vcat [ acc, text "-- leaf" <+> int n, format e, line]) -  pretty (Clip m cpath p)   = -      text "Clip:" <+> ppLocale m <$> indent 2 (pretty cpath)-                                  <$> indent 2 (pretty p)+fmtLocale :: (Num u, PSUnit u) => Locale u -> Doc+fmtLocale (bb,_) = format bb -ppLocale :: (Num u, Pretty u) => Locale u -> Doc-ppLocale (fr,bb) = align (ppfr <$> pretty bb) where-   ppfr = if standardFrame fr then text "*std-frame*" else pretty fr +instance PSUnit u => Format (Primitive u) where+  format (PPath props _ p)    = +      indent 2 $ vcat [ text "path:" <+> format props, format p ] -instance Pretty u => Pretty (Primitive u) where-  pretty (PPath _ p)        = pretty "path:" <+> pretty p-  pretty (PLabel _ lbl)     = pretty lbl-  pretty (PEllipse _ e)     = pretty e +  format (PLabel props _ l)   =+      indent 2 $ vcat [ text "label:" <+> format props, format l ] +  format (PEllipse props _ e) = +      indent 2 $ vcat [ text "ellipse:" <+> format props, format e ] -instance Pretty u => Pretty (Path u) where-   pretty (Path pt ps) = pretty pt <> hcat (map pretty ps) -instance Pretty u => Pretty (PathSegment u) where-  pretty (PCurveTo p1 p2 p3)  = text ".*" <> pretty p1 <> text ",," <> pretty p2 -                                          <> text "*." <> pretty p3-  pretty (PLineTo pt)         = text "--" <> pretty pt+instance PSUnit u => Format (PrimPath u) where+   format (PrimPath pt ps) = vcat (start : map format ps)+      where+        start = text "start_point " <> format pt -instance Pretty u => Pretty (Label u) where-  pretty (Label pt s ctm) = dquotes (pretty s) <> char '@' <> pretty pt-                                              <+> pretty ctm+instance PSUnit u => Format (PrimPathSegment u) where+  format (PCurveTo p1 p2 p3)  =+    text "curve_to    " <> format p1 <+> format p2 <+> format p3 -instance Pretty u => Pretty (PrimEllipse u) where-  pretty (PrimEllipse ctr w h ctm) = pretty "ellipse" <+> pretty ctr-                                        <+> text "w:" <> pretty w-                                        <+> text "h:" <> pretty h-                                        <+> pretty ctm+  format (PLineTo pt)         = text "line_to     " <> format pt++instance PSUnit u => Format (PrimLabel u) where+  format (PrimLabel pt s ctm) = +     vcat [ dquotes (format s)+          ,     text "baseline_left=" <> format pt+            <+> text "ctm="           <> format ctm+          ]++instance PSUnit u => Format (PrimEllipse u) where+  format (PrimEllipse ctr hw hh ctm) = text "center="   <> format ctr+                                   <+> text "hw="       <> dtruncFmt hw+                                   <+> text "hh="       <> dtruncFmt hh+                                   <+> text "ctm="      <> format ctm    -instance Pretty u => Pretty (PrimCTM u) where-  pretty (PrimCTM x y ang) = -      braces (pretty x <> comma <+> pretty y <> comma <+> pretty ang)+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"   +++ -------------------------------------------------------------------------------- --- | Paths are sensibly a Semigroup - there is no notion of --- /empty path/.+instance Boundary (Picture u) where+  boundary (Leaf    (bb,_) _)   = bb+  boundary (Picture (bb,_) _)   = bb+  boundary (Clip    (bb,_) _ _) = bb+  boundary (Group   (bb,_) _ _) = bb -instance Semigroup (Path u) where-  Path st xs `append` Path st' xs' = Path st (xs ++ (PLineTo st' : xs'))+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  -instance Pointwise (Path u) where-  type Pt (Path u) = Point2 u-  pointwise f (Path st xs) = Path (f st) (map (pointwise f) xs) -instance Pointwise (PathSegment u) where-  type Pt (PathSegment u) = Point2 u-  pointwise f (PLineTo p)         = PLineTo (f p)-  pointwise f (PCurveTo p1 p2 p3) = PCurveTo (f p1) (f p2) (f p3)-  +pathBoundary :: Ord u => PrimPath u -> BoundingBox u+pathBoundary (PrimPath st xs) = step (st,st) xs+  where+    step (lo,hi) []                       = BBox lo hi +    step (lo,hi) (PLineTo p1:rest)        = step (lo2 lo p1, hi2 hi p1) rest+    step (lo,hi) (PCurveTo p1 p2 p3:rest) = let lo' = lo4 lo p1 p2 p3 +                                                hi' = hi4 hi p1 p2 p3+                                            in step (lo',hi') rest  +    lo2 (P2 x1 y1) (P2 x2 y2) = P2 (min x1 x2) (min y1 y2) +    hi2 (P2 x1 y1) (P2 x2 y2) = P2 (max x1 x2) (max y1 y2)++    lo4 (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) (P2 x4 y4) = +        P2 (min x1 $ min x2 $ min x3 x4) (min y1 $ min y2 $ min y3 y4) ++    hi4 (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) (P2 x4 y4) = +        P2 (max x1 $ max x2 $ max x3 x4) (max y1 $ max y2 $ max y3 y4) + +++labelBoundary :: (Floating u, Real u, FromPtSize u) +              => FontAttr -> PrimLabel u -> BoundingBox u+labelBoundary attr (PrimLabel (P2 x y) xs ctm) = +    retraceBoundary  (disp . (m33 *#)) untraf_bbox+  where+    disp        = (.+^ V2 x y)+    m33         = matrixRepCTM ctm+    untraf_bbox = textBounds (font_size attr) zeroPt char_count+    char_count  = textLength xs++++-- | Ellipse bbox is the bounding rectangle, rotated as necessary +-- then retraced.+--+ellipseBoundary :: (Real u, Floating u) => PrimEllipse u -> BoundingBox u+ellipseBoundary (PrimEllipse pt hw0 hh0 (PrimCTM sx sy theta)) = +    traceBoundary $ applyIf (theta /= 0) (map (rotm *#)) [ll,lr,ur,ul]+  where+    hw   = hw0 * sx+    hh   = hh0 * sy+    ll   = pt .+^ V2 (-hw) (-hh) +    lr   = pt .+^ V2   hw  (-hh) +    ur   = pt .+^ V2   hw    hh +    ul   = pt .+^ V2 (-hw)   hh +    rotm = rotationMatrix theta+++ ----------------------------------------------------------------------------------- Affine trans instances+-- Affine transformations -type instance DUnit (Picture u)     = u-type instance DUnit (Primitive u)   = u-type instance DUnit (Path u)        = u-type instance DUnit (PrimEllipse u) = u+-- Note YRange remains constant (as do the actually points +-- within the primitives).+-- +-- TO DO - this is potentially wrong... + instance (Num u, Ord u) => Transform (Picture u) where-  transform ctm pic = trafoPicture (transform ctm) (transform ctm) pic+  transform mtrx = +    mapLocale $ \(bb,xs) -> (transform mtrx bb, Matrix mtrx:xs) +instance (Real u, Floating u) => Rotate (Picture u) where+  rotate theta = +    mapLocale $ \(bb,xs) -> (rotate theta bb, Rotate theta:xs) -instance (Floating u, Real u) => Rotate (Picture u) where-  rotate = rotatePicture  -instance (Floating u, Real u) => RotateAbout (Picture u) where-  rotateAbout = rotatePictureAbout+instance (Real u, Floating u) => RotateAbout (Picture u) where+  rotateAbout theta pt = +    mapLocale $ \(bb,xs) -> (rotateAbout theta pt bb, RotAbout theta pt:xs)  instance (Num u, Ord u) => Scale (Picture u) where-  scale = scalePicture+  scale sx sy = +    mapLocale $ \(bb,xs) -> (scale sx sy bb, Scale sx sy : xs)  instance (Num u, Ord u) => Translate (Picture u) where-  translate = translatePicture+  translate dx dy = +    mapLocale $ \(bb,xs) -> (translate dx dy bb, Translate dx dy:xs)  +mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u+mapLocale f (Leaf lc ones)     = Leaf (f lc) ones+mapLocale f (Picture lc ones)  = Picture (f lc) ones+mapLocale f (Clip lc pp pic)   = Clip (f lc) pp pic+mapLocale f (Group lc upd pic) = Group (f lc) upd pic +--------------------------------------------------------------------------------+-- Manipulating the PrimCTM --- Primitives+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@@ -370,9 +551,9 @@ -- 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+rotatePrimitive ang (PPath a xl path)   = PPath a xl $ rotatePath ang path+rotatePrimitive ang (PLabel a xl lbl)   = PLabel a xl $ rotateLabel ang lbl+rotatePrimitive ang (PEllipse a xl ell) = PEllipse a xl $ rotateEllipse ang ell   -- | Scale a Primitive.@@ -398,9 +579,9 @@ -- \"cost-free\". -- 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+scalePrimitive x y (PPath a xl path)   = PPath    a xl $ scalePath x y path+scalePrimitive x y (PLabel a xl lbl)   = PLabel   a xl $ scaleLabel x y lbl+scalePrimitive x y (PEllipse a xl ell) = PEllipse a xl $ scaleEllipse x y ell  -- | Apply a uniform scale to a Primitive. --@@ -418,61 +599,17 @@ -- the generated output.  --  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--------------------------------------------------------------------------------------- Helpers for the affine transformations--rotatePicture :: (Real u, Floating u) => Radian -> Picture u -> Picture u-rotatePicture ang = trafoPicture (rotate ang) (rotate ang)--rotatePictureAbout :: (Real u, Floating u) -                   => Radian -> Point2 u -> Picture u -> Picture u-rotatePictureAbout ang pt = -    trafoPicture (rotateAbout ang pt) (rotateAbout ang pt)-  -scalePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u-scalePicture x y = trafoPicture (scale x y) (scale x y)+translatePrimitive x y (PPath a xl path)   = +    PPath a xl $ translatePath x y path -translatePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u-translatePicture x y = trafoPicture (translate x y) (translate x y)+translatePrimitive x y (PLabel a xl lbl)   = +    PLabel a xl $ translateLabel x y lbl --- TODO - the nameing for these functions is confusing now that--- I've added a Transform typeclass.------ Look to unifying the naming scheme in someway.----trafoPicture :: (Num u, Ord u) -             => (Point2 u -> Point2 u) -             -> (Vec2 u -> Vec2 u) -             -> Picture u -             -> Picture u-trafoPicture fp fv = -    mapLocale $ \(frm,bb) -> (trafoFrame fp fv frm, trafoBBox fp bb)+translatePrimitive x y (PEllipse a xl ell) = +    PEllipse a xl $ translateEllipse x y ell   -trafoFrame :: Num u-           => (Point2 u -> Point2 u) -           -> (Vec2 u -> Vec2 u) -           -> Frame2 u -           -> Frame2 u-trafoFrame fp fv (Frame2 e0 e1 o) = Frame2 (fv e0) (fv e1) (fp o)----- Bounding boxes need recalculating after a transformation.--- For instance after a reflection in the y-axis br becomes bl.-trafoBBox :: (Num u, Ord u)-              => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u-trafoBBox fp bb = traceBoundary $ map fp $ [bl,br,tl,tr]-  where-    (bl,br,tr,tl) = corners bb-- -------------------------------------------------------------------------------- -- Paths @@ -487,9 +624,10 @@ -- (0,0), but don\'t not basis vectors) so manipulating them  -- cannot follow the standard affine interpretation. -- -rotatePath :: (Real u, Floating u) => Radian -> Path u -> Path u-rotatePath ang (Path start xs) = -    Path start $ map (pointwise (rotateAbout ang start)) xs+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  -- scalePath - scale the vector between each point and the start  -- point.@@ -499,45 +637,24 @@ -- are lifted to Pictures their manipulation cannot correspond -- to the standard affine manipulations. ---scalePath :: Num u => u -> u -> Path u -> Path u-scalePath x y (Path pt xs) = Path pt (map (pointwise fn) xs) +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)  -- translatePath - move all points in the path by the supplied  -- x and y values. ---translatePath :: Num u => u -> u -> Path u -> Path u-translatePath x y = pointwise (translate x y)-+translatePath :: Num u => u -> u -> PrimPath u -> PrimPath u+translatePath x y = mapPath (translate x y)  ------------------------------------------------------------------------------------ Manipulating the Primitive CTM--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 x y ang) = PrimCTM (x1*x) (y1*y) ang--rotateCTM :: Radian -> PrimCTM u -> PrimCTM u-rotateCTM ang1 (PrimCTM x y ang) = PrimCTM x y (circularModulo $ ang1+ang)--matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u-matrixRepCTM (PrimCTM x y ang) = -    rotationMatrix (circularModulo ang) * scalingMatrix x y-+mapPath :: (Point2 u -> Point2 u) -> PrimPath u -> PrimPath u+mapPath fn (PrimPath st xs) = PrimPath (fn st) (map (mapSeg fn) xs) --- 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.------ The function encapsulated the correct order.----translMatrixRepCTM :: (Floating u, Real u) -                   => u -> u -> PrimCTM u -> Matrix3'3 u-translMatrixRepCTM x y ctm = translationMatrix x y * matrixRepCTM ctm+mapSeg :: (Point2 u -> Point2 u) -> PrimPathSegment u -> PrimPathSegment u+mapSeg fn (PLineTo p)         = PLineTo (fn p)+mapSeg fn (PCurveTo p1 p2 p3) = PCurveTo (fn p1) (fn p2) (fn p3)  -------------------------------------------------------------------------------- -- Labels@@ -547,17 +664,17 @@ -- Rotations on a (primitive) Label are interpreted as rotating -- about the bottom-left corner. ---rotateLabel :: Radian -> Label u -> Label u-rotateLabel ang (Label pt txt ctm) = Label pt txt (rotateCTM ang ctm)+rotateLabel :: Radian -> PrimLabel u -> PrimLabel u+rotateLabel ang (PrimLabel pt txt ctm) = PrimLabel pt txt (rotateCTM ang ctm) -scaleLabel :: Num u => u -> u -> Label u -> Label u-scaleLabel x y (Label pt txt ctm) = Label pt txt (scaleCTM x y ctm)+scaleLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u+scaleLabel x y (PrimLabel pt txt ctm) = PrimLabel pt txt (scaleCTM x y ctm)   -- Change the bottom-left corner. ---translateLabel :: Num u => u -> u -> Label u -> Label u-translateLabel x y (Label pt txt ctm) = Label (translate x y pt) txt ctm+translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u+translateLabel x y (PrimLabel pt txt ctm) = PrimLabel (translate x y pt) txt ctm  -------------------------------------------------------------------------------- -- Ellipse@@ -580,153 +697,56 @@ 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-     ------------------------------------------------------------------------------------ Boundary -instance Boundary (Picture u) where-  boundary (PicBlank (_,bb))     = bb-  boundary (Single   (_,bb) _)   = bb-  boundary (Picture  (_,bb) _)   = bb-  boundary (Clip     (_,bb) _ _) = bb -instance (Num u, Ord u) => Boundary (Path u) where-  boundary (Path st xs) = traceBoundary $ st : foldr f [] xs where-      f (PLineTo p1)        acc  = p1 : acc-      f (PCurveTo p1 p2 p3) acc  = p1 : p2 : p3 : acc +--------------------------------------------------------------------------------+-- Additional operations  --- Note - this will calculate an approximate bounding box for --- text.--instance (Real u, Floating u, FromPtSize u) => Boundary (Primitive u) where-  boundary (PPath _ p)        = boundary p-  boundary (PLabel (_,a) l)   = primLabelBoundary a l -  boundary (PEllipse _ e)     = boundary e+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  -primLabelBoundary :: (Floating u, Real u, FromPtSize u) -                  => FontAttr -> Label u -> BoundingBox u-primLabelBoundary attr (Label (P2 x y) xs ctm) = -    retraceBoundary  (disp . (m33 *#)) untraf_bbox-  where-    disp        = (.+^ V2 x y)-    m33         = matrixRepCTM ctm-    untraf_bbox = textBounds (font_size attr) zeroPt char_count-    char_count  = textLength xs--instance (Real u, Floating u) => Boundary (PrimEllipse u) where-  boundary = ellipseBoundary---- Find the bbox of an ellipse by drawing it as four bezier --- curves then trace all the points and control points to find--- the bbox.--- --- Note all_points takes three of the four points to avoid --- duplicating--- /matched/ start-end points-----ellipseBoundary :: (Real u, Floating u) => PrimEllipse u -> BoundingBox u-ellipseBoundary = traceBoundary . ellipseControlPoints---- PROBLEM:--- Currently a rotated circle has a different BBox to a --- non-rotated circle, because of how tangents are selected...+-- | Destructor for Matrix3'3. -- --- This is the same as a diamond having a larger BBox--- than a square with same side-length-------------------------------------------------------------------------------------+-- Pattern matching on 6-tuple may be more convenient than using +-- the Matrix3'3 directly. ---+-- > (M3'3 e0x e1x ox  +-- >       e0y e1y oy  +-- >       _   _   _  ) = (e0x,e0y,  e1x,e1y,  ox,oy)+--  +deconsMatrix :: Matrix3'3 u -> (u,u,u,u,u,u)+deconsMatrix (M3'3 e0x e1x ox  +                   e0y e1y oy  +                   _   _   _  ) = (e0x,e0y,  e1x,e1y,  ox,oy)   -mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u-mapLocale f (PicBlank m)      = PicBlank (f m)-mapLocale f (Single   m prim) = Single (f m) prim-mapLocale f (Picture  m ones) = Picture (f m) ones-mapLocale f (Clip     m x p)  = Clip (f m) x p---movePic :: Num u => Vec2 u -> Picture u -> Picture u-movePic v = mapLocale (moveLocale v) --  -moveLocale :: Num u => Vec2 u -> Locale u -> Locale u-moveLocale v (fr,bb) = (displaceOrigin v fr, pointwise (.+^ v) bb) --------------------------------------------------------------------------------------- | Should this really be public?-extractFrame :: Num u => Picture u -> Frame2 u-extractFrame (PicBlank (fr,_))     = fr-extractFrame (Single   (fr,_) _)   = fr-extractFrame (Picture  (fr,_) _)   = fr-extractFrame (Clip     (fr,_) _ _) = fr----- This needs is for PostScript and SVG output - it should be --- hidden in the export list of Wumpus.Core-- -- If a picture has coordinates smaller than (P2 4 4) then it --- needs repositioning before it is drawn to PostSCript or SVG.+-- needs repositioning before it is drawn to PostScript or SVG. --  -- (P2 4 4) gives a 4 pt margin - maybe it sould be (0,0) or  -- user defined. ---repositionProperties :: (Num u, Ord u) -                     => Picture u -> (BoundingBox u, Maybe (Vec2 u))-repositionProperties = fn . boundary where-  fn bb@(BBox (P2 llx lly) (P2 urx ury))-      | llx < 4 || lly < 4  = (BBox ll ur, Just $ V2 x y)-      | otherwise           = (bb, Nothing)-    where -      x  = 4 - llx-      y  = 4 - lly-      ll = P2 (llx+x) (lly+y)-      ur = P2 (urx+x) (ury+y)  ----- | Get the control points as a list--- --- There are no duplicates in the list except for the final --- /wrap-around/. We take 4 points initially (start,cp1,cp2,end)--- then (cp1,cp2,end) for the other three quadrants.----ellipseControlPoints :: (Floating u, Real u)-                     => PrimEllipse u -> [Point2 u]-ellipseControlPoints (PrimEllipse (P2 x y) hw hh ctm) = -    map (disp . (new_mtrx *#)) circ-  where-    disp             = (.+^ V2 x y)-    (radius,(dx,dy)) = circleScalingProps hw hh-    new_mtrx         = matrixRepCTM $ scaleCTM dx dy ctm-    circ             = bezierCircle 1 radius (P2 0 0)--    -- subdivide the bezierCircle with 1 to get two-    -- control points per quadrant.    -------- I don't know how to calculate bezier arcs (and thus control--- points) for an ellipse but I know how to do it for a circle...------ So a make a circle with the largest of half-width and --- half-height then apply a scale to the points--- -circleScalingProps  :: (Fractional u, Ord u) => u -> u -> (u,(u,u))-circleScalingProps hw hh  = (radius, (dx,dy))+repositionDeltas :: (Num u, Ord u) +                 => Picture u -> (BoundingBox u, Maybe (Vec2 u))+repositionDeltas = step . boundary    where-    radius     = max hw hh-    (dx,dy)    = if radius == hw then (1, rescale (0,hw) (0,1) hh)-                                 else (rescale (0,hh) (0,1) hw, 1)--+    step bb@(BBox (P2 llx lly) (P2 urx ury))+        | llx < 4 || lly < 4  = (BBox ll ur, Just $ V2 x y)+        | otherwise           = (bb, Nothing)+      where +        x  = 4 - llx+        y  = 4 - lly+        ll = P2 (llx+x) (lly+y)+        ur = P2 (urx+x) (ury+y)  

@@ -1,544 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.PostScript--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more------ PostScript generation via a Writer monad.------ PostScript is emitted line by line - there is no abstract--- syntax tree representing PostScript. So we use a writer --- monad.----------------------------------------------------------------------------------------module Wumpus.Core.PostScript -  (-  -- * Types-    PostScript-  , WumpusM--  , runWumpus--  -- * Escape sepcial characters-  , escapeStringPS--  -- * Deltas -  , deltaFontAttr-  , deltaRgbColour--  , deltaStrokeWidth-  , deltaMiterLimit-  , deltaLineCap-  , deltaLineJoin-  , deltaDashPattern- -  -- * Emit PostScript -  , ps_comment-  -  , ps_gsave-  , ps_grestore-  , ps_setlinewidth-  , ps_setlinecap-  , ps_setlinejoin-  , ps_setmiterlimit-  , ps_setdash-  , ps_setgray-  , ps_setrgbcolor-  , ps_sethsbcolor-  , ps_translate-  , ps_scale-  , ps_concat-  , ps_newpath-  , ps_moveto-  , ps_rmoveto-  , ps_lineto-  , ps_rlineto-  , ps_arc-  , ps_arcn-  , ps_curveto-  , ps_closepath-  , ps_clip-  , ps_fill-  , ps_stroke-  , ps_showpage-  , ps_findfont-  , ps_scalefont-  , ps_setfont-  , ps_show-  , ps_glyphshow-  , bang_PS-  , bang_EPS-  , dsc_comment-  , dsc_BoundingBox-  , dsc_CreationDate-  , dsc_Pages-  , dsc_Page-  , dsc_EndComments-  , dsc_EOF--  ) where--import Wumpus.Core.Colour-import Wumpus.Core.GraphicsState-import Wumpus.Core.TextEncoder-import Wumpus.Core.Utils---import MonadLib--import Data.List ( foldl' )----- Graphics state for PostScript Rendering------ Values with no default value (e.g. font) in the graphics --- state of the PostScript interpreter (not Wumpus\'s renderer) --- are Maybes.--- --- The graphics state is considered successive - all elements --- have a colour and all text labels have a font. So during --- processing there are two situations: ---- (1) If font or colour is the same as the last no state--- change needs to be printed.------ (2) If the font or colour changes the update needs to be --- printed, but as the next element always has a colour (and a--- font if it is a label), no @undo@ needs to be printed.------ This contrasts with the behaviour for stroke attributes--- which needs @undo@.--data PostScriptGS = PostScriptGS { -        gs_font         :: Maybe FontAttr,-        gs_rgb_colour   :: DRGB-      }-  deriving (Eq,Show)------ | Stroke properties do not have to be fully specified in --- Wumpus\'s picture types - i.e. a Path might have it\'s stroke --- width set but nothing else.------ If a path changes any of the stroke properties, it --- immediately undoes the changes after drawing, returning the --- the stroke values to their PostScript defaults.------ This means Wumpus doesn't have to carry a nested environment --- around as it renders to PostScript. As stroke properties can--- only be assigned to leaves in the picture tree, a nested --- environment wouldn\'t really be an ideal fit anyway.---gs_stroke_width :: Double-gs_stroke_width = 1.0--gs_miter_limit  :: Double-gs_miter_limit  = 10.0--gs_line_cap     :: LineCap-gs_line_cap     = CapSquare--gs_line_join    :: LineJoin-gs_line_join    = JoinMiter--gs_dash_pattern :: DashPattern-gs_dash_pattern = Solid----type PostScript = String--type PsOutput = H Char--type WumpusM a = PsT Id a---newtype PsT m a = PsT { -    unPsT :: StateT PostScriptGS -                    (WriterT PsOutput (ReaderT TextEncoder m)) a }--gs_init :: PostScriptGS -gs_init = PostScriptGS { gs_font           = Nothing-                       , gs_rgb_colour     = black -                       }-           -            -runPsT :: Monad m -       => TextEncoder -> PsT m a -> m ((a,PostScriptGS),PsOutput)-runPsT i m = runReaderT i $ runWriterT $ runStateT gs_init $ unPsT m--instance Monad m => Functor (PsT m) where-  fmap f (PsT mf) = PsT $ fmap f mf --instance Monad m => Monad (PsT m) where-  return a  = PsT $ return a-  ma >>= f  = PsT $ unPsT ma >>= unPsT . f--instance Monad m => WriterM (PsT m) PsOutput where-  put = PsT . put--instance Monad m => ReaderM (PsT m) TextEncoder where-  ask = PsT $ ask--instance Monad m => StateM (PsT m) PostScriptGS where-  set = PsT . set-  get = PsT $ get--instance MonadT PsT where-  lift = PsT . lift . lift . lift---pstId :: TextEncoder -> PsT Id a -> ((a,PostScriptGS),PsOutput)-pstId = runId `oo` runPsT---- | Drop state and result, take the Writer trace.-runWumpus :: TextEncoder -> WumpusM a -> String-runWumpus = (toListH . snd) `oo` pstId------------------------------------------------------------------------------------- Escape special chars---- | Escape these characters:------ > \\ - (, ), <, >, [, ], {, }, /, and %----escapeStringPS :: String -> String-escapeStringPS = foldr f "" where-  f c ss | c `elem` ps_special = '\\' : c : ss-         | otherwise           = c : ss--ps_special :: [Char]-ps_special = "\\()<>[]{}/%"-------------------------------------------------------------------------------------- "Deltas" of the graphics state--deltaFontAttr :: FontAttr -> WumpusM (Maybe FontAttr)-deltaFontAttr new = get >>= maybe update diff . gs_font-  where-    update :: WumpusM (Maybe FontAttr)-    update = sets_ (\s -> s { gs_font = Just new }) >> return (Just new)-    -    diff :: FontAttr -> WumpusM (Maybe FontAttr)-    diff old | old == new = return Nothing-             | otherwise  = update---deltaRgbColour :: DRGB -> WumpusM (Maybe DRGB)-deltaRgbColour new = get >>= diff . gs_rgb_colour-  where-    diff :: DRGB -> WumpusM (Maybe DRGB)-    diff old | old == new = return Nothing-             | otherwise  = do { sets_ (\s -> s { gs_rgb_colour = new })-                               ; return (Just new)-                               }---deltaStrokeWidth :: Double -> Maybe (Double,Double)-deltaStrokeWidth n-    | n == gs_stroke_width = Nothing-    | otherwise            = Just (n,gs_stroke_width)--deltaMiterLimit :: Double -> Maybe (Double,Double)-deltaMiterLimit n -    | n == gs_miter_limit  = Nothing-    | otherwise            = Just (n,gs_miter_limit)---deltaLineCap :: LineCap -> Maybe (LineCap,LineCap)-deltaLineCap lc-    | lc == gs_line_cap    = Nothing-    | otherwise            = Just (lc,gs_line_cap)--deltaLineJoin :: LineJoin -> Maybe (LineJoin,LineJoin)-deltaLineJoin lj -    | lj == gs_line_join   = Nothing-    | otherwise            = Just (lj,gs_line_join)--deltaDashPattern :: DashPattern -> Maybe (DashPattern,DashPattern)-deltaDashPattern p -    | p == gs_dash_pattern = Nothing-    | otherwise            = Just (p,gs_dash_pattern)--------------------------------------------------------------------------------------- writer monad helpers--tell :: WriterM m i => i -> m ()-tell s = puts ((),s)--writeChar :: WriterM m PsOutput => Char -> m ()-writeChar = tell . showChar ---write :: WriterM m PsOutput => String -> m ()-write = tell . showString ---writeln :: WriterM m PsOutput => String -> m ()-writeln s = write s >> writeChar '\n'---writeArg :: WriterM m PsOutput => String -> m () -writeArg s = write s >> writeChar ' '-----type Command = String--command :: Command -> [String] -> WumpusM ()-command cmd xs = mapM_ writeArg xs >> writeln cmd----showArray :: (a -> ShowS) -> [a] -> String-showArray _ []     = "[ ]"-showArray f (x:xs) = sfun "]" -  where -    sfun = foldl' (\a e -> a . (' ':) . f e) (('[':) . f x) xs-                              ----- | @ %% ... @-ps_comment :: String -> WumpusM ()-ps_comment s = write "%% " >> writeln s------------------------------------------------------------------------------------- graphics state operators---- | @ gsave @-ps_gsave :: WumpusM ()-ps_gsave = command "gsave" []---- | @ grestore @-ps_grestore :: WumpusM () -ps_grestore = command "grestore" []---- | @ ... setlinewidth @-ps_setlinewidth :: PSUnit u => u -> WumpusM ()-ps_setlinewidth = command "setlinewidth" . return . dtrunc---- | @ ... setlinecap @-ps_setlinecap :: LineCap -> WumpusM ()-ps_setlinecap = command "setlinecap" . return . show . fromEnum---- | @ ... setlinejoin @-ps_setlinejoin :: LineJoin -> WumpusM ()-ps_setlinejoin = command "setlinejoin" . return . show . fromEnum---- | @ ... setmiterlimit @-ps_setmiterlimit :: PSUnit u => u -> WumpusM ()-ps_setmiterlimit = command "setmiterlimit" . return . dtrunc---- | @ [... ...] ... setdash @-ps_setdash :: DashPattern -> WumpusM ()-ps_setdash Solid          = command "setdash" ["[]", "0"]-ps_setdash (Dash n pairs) = command "setdash" [showArray shows arr, show n]-  where-    arr = foldr (\(x,y) a -> x:y:a) [] pairs---- | @ ... setgray @-ps_setgray :: PSUnit u => u -> WumpusM ()-ps_setgray = command "setgray" . return . dtrunc ---- | @ ... ... ... setrgbcolor @-ps_setrgbcolor :: PSUnit u => u -> u -> u -> WumpusM ()-ps_setrgbcolor r g b = command "setrgbcolor" $ map dtrunc [r,g,b]---- | @ ... ... ... sethsbcolor @-ps_sethsbcolor :: PSUnit u => u -> u -> u -> WumpusM ()-ps_sethsbcolor h s b = command "sethsbcolor" $ map dtrunc [h,s,b]-------------------------------------------------------------------------------------- coordinate system and matrix operators ---- | @ ... ... translate @-ps_translate :: PSUnit u => u -> u -> WumpusM ()-ps_translate tx ty = do-    command "translate" $ map dtrunc [tx,ty]---- | @ ... ... scale @-ps_scale :: PSUnit u => u -> u -> WumpusM ()-ps_scale tx ty = do-    command "scale" $ map dtrunc [tx,ty]----- Do not use setmatrix for changing the CTM use concat...---- | @ [... ... ... ... ... ...] concat @-ps_concat :: PSUnit u => CTM u -> WumpusM ()-ps_concat (CTM a b  c d  e f) = command "concat" [mat] where -    mat = showArray ((++) . dtrunc) [a,b,c,d,e,f]-------------------------------------------------------------------------------------- Path construction operators---- | @ newpath @-ps_newpath :: WumpusM ()-ps_newpath = command "newpath" []----- Note - it is preferable to show doubles as 0.0 rather than 0.--- In PostScript the coercion from int to float is apparently --- quite expensive.---- | @ ... ... moveto @-ps_moveto :: PSUnit u => u -> u -> WumpusM ()-ps_moveto x y = command "moveto" [dtrunc x, dtrunc y]---- | @ ... ... rmoveto @-ps_rmoveto :: PSUnit u => u -> u -> WumpusM ()-ps_rmoveto x y = command "rmoveto" [dtrunc x, dtrunc y]---- | @ ... ... lineto @-ps_lineto :: PSUnit u => u -> u -> WumpusM ()-ps_lineto x y = command "lineto" [dtrunc x, dtrunc y]---- | @ ... ... rlineto @-ps_rlineto :: PSUnit u => u -> u -> WumpusM ()-ps_rlineto x y = command "rlineto" [dtrunc x, dtrunc y]---- | @ ... ... ... ... ... arc @-ps_arc :: PSUnit u => u -> u -> u -> u -> u -> WumpusM ()-ps_arc x y r ang1 ang2 = -    command "arc" $ map dtrunc [x,y,r,ang1,ang2]---- | @ ... ... ... ... ... arcn @-ps_arcn :: PSUnit u => u -> u -> u -> u -> u -> WumpusM ()-ps_arcn x y r ang1 ang2 = -    command "arcn" $ map dtrunc [x,y,r,ang1,ang2]---- | @ ... ... ... ... ... ... curveto @-ps_curveto :: PSUnit u => u -> u -> u -> u -> u -> u -> WumpusM ()-ps_curveto x1 y1 x2 y2 x3 y3 = -    command "curveto" $ map dtrunc [x1,y1, x2,y2, x3,y3]---- | @ closepath @-ps_closepath :: WumpusM ()-ps_closepath = command "closepath" []---- | @ clip @-ps_clip :: WumpusM ()-ps_clip = command "clip" []-------------------------------------------------------------------------------------  painting operators---- | @ fill @-ps_fill :: WumpusM ()-ps_fill = command "fill" []---- | @ stroke @-ps_stroke :: WumpusM ()-ps_stroke = command "stroke" []-------------------------------------------------------------------------------------- Output operators---- | @ showpage @-ps_showpage :: WumpusM ()-ps_showpage = command "showpage" []--------------------------------------------------------------------------------------- Character and font operators---- | The following fonts are expected to exist on most platforms:------ > Times-Roman  Times-Italic  Times-Bold  Times-BoldItalic--- > Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique--- > Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique--- > Symbol------ List from Bill Casselman \'Mathematical Illustrations\' p279.---- | @ /... findfont @-ps_findfont :: String -> WumpusM () -ps_findfont = command "findfont" . return . ('/' :)---- | @ ... scalefont @-ps_scalefont :: Int -> WumpusM ()-ps_scalefont = command "scalefont" . return . show---- | @ setfont @-ps_setfont :: WumpusM ()-ps_setfont = command "setfont" []---- | @ (...) show  @-ps_show :: String -> WumpusM ()-ps_show = command "show" . return . parens---- | @ (...) show  @-ps_glyphshow :: String -> WumpusM ()-ps_glyphshow = command "glyphshow" . return . ('/':)-------------------------------------------------------------------------------------- document structuring conventions---- | @ %!PS-Adobe-3.0 @-bang_PS :: WumpusM ()-bang_PS = writeln "%!PS-Adobe-3.0"---- | @ %!PS-Adobe-3.0 EPSF-3.0 @-bang_EPS :: WumpusM ()-bang_EPS = writeln "%!PS-Adobe-3.0 EPSF-3.0"---- | @ %%...: ... @-dsc_comment :: String -> [String] -> WumpusM ()-dsc_comment name [] = write "%%" >> writeln name-dsc_comment name xs = write "%%" >> write name >> write ": " >> writeln (hsep xs)----- | @ %%BoundingBox: ... ... ... ... @  /llx lly urx ury/-dsc_BoundingBox :: PSUnit u => u -> u -> u -> u -> WumpusM ()-dsc_BoundingBox llx lly urx ury = -  dsc_comment "BoundingBox"  (map (roundup . toDouble) [llx,lly,urx,ury])---- | @ %%CreationDate: ... @--- --- The creation date is informational and never interpreted, --- thus the format is entirely arbitrary.-dsc_CreationDate :: String -> WumpusM ()-dsc_CreationDate = dsc_comment "CreationDate" . return---- | @ %%Pages: ... @-dsc_Pages :: Int -> WumpusM ()-dsc_Pages = dsc_comment "Pages" . return . show----- | @ %%Page: ... ... @-dsc_Page :: String -> Int -> WumpusM ()-dsc_Page label ordinal = -    dsc_comment "Page" [label, show ordinal]----- | @ %%EndComments @-dsc_EndComments :: WumpusM ()-dsc_EndComments = dsc_comment "EndComments" []---- | @ %%EOF @-dsc_EOF :: WumpusM ()-dsc_EOF = dsc_comment "EOF" []-

@@ -0,0 +1,350 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.PostScriptDoc+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- PostScript Doc combinators.+--+--------------------------------------------------------------------------------++module Wumpus.Core.PostScriptDoc+  ( + +    escapeSpecial+    +  , psHeader+  , epsHeader+  , psFooter+  , epsFooter+  , dsc_Page++  , missingCharCode++  , command+  , ps_comment++  , ps_gsave+  , ps_grestore+  , ps_setlinewidth+  , ps_setlinecap+  , ps_setlinejoin+  , ps_setmiterlimit+  , ps_setdash+  , ps_setrgbcolor++  , ps_translate+  , ps_concat++  , ps_newpath+  , ps_moveto+  , ps_lineto+  , ps_arc+  , ps_curveto+  , ps_closepath+  , ps_clip++  , ps_fill +  , ps_stroke+  +  , ps_showpage+  , ps_findfont+  , ps_scalefont+  , ps_setfont+  , ps_show+  , ps_glyphshow++  )  where++import Wumpus.Core.BoundingBox+import Wumpus.Core.Colour+import Wumpus.Core.FormatCombinators+import Wumpus.Core.Geometry+import Wumpus.Core.GraphicsState+import Wumpus.Core.PictureInternal+import Wumpus.Core.TextEncoder+import Wumpus.Core.Utils++import Data.Time+++++--------------------------------------------------------------------------------+-- Escape special chars++-- | Escape these characters:+--+-- > \\ - (, ), <, >, [, ], {, }, /, and %+--+escapeSpecial :: String -> String+escapeSpecial = foldr f "" +  where+    f c ss | c `elem` ps_special = '\\' : c : ss+           | otherwise           = c : ss++ps_special :: [Char]+ps_special = "\\()<>[]{}/%"++++psHeader  :: Int -> ZonedTime -> Doc+psHeader page_count tod = vcat $ +    [ text "%!PS-Adobe-3.0"+    , text "%%Pages:"         <+> int page_count+    , text "%%CreationDate:"  <+> parens (showsDoc $ psTimeStamp tod)                +    , text "%%EndComments"                  +    ]+++epsHeader :: PSUnit u => BoundingBox u -> ZonedTime -> Doc+epsHeader bb tod = vcat $ +    [ text "%!PS-Adobe-3.0 EPSF-3.0"+    , text "%%BoundingBox:"   <+> upint llx <+> upint lly+                              <+> upint urx <+> upint ury+    , text "%%CreationDate:"  <+> parens (showsDoc $ psTimeStamp tod)                +    , text "%%EndComments"                  +    ]+  where+    upint             = text . roundup . toDouble+    (llx,lly,urx,ury) = destBoundingBox bb ++++psFooter :: Doc+psFooter = text "%%EOF"+++epsFooter :: Doc+epsFooter = vcat [ text "showpage", text "%%EOF" ]+++-- | @ %%Page: ... ... @+--+dsc_Page :: String -> Int -> Doc+dsc_Page label ordinal = text "%%Page:" <+> text label <+> int ordinal+++missingCharCode :: CharCode -> GlyphName -> Doc+missingCharCode i fallback = vcat $+    [ ps_comment $ "missing lookup for &#" ++ show i ++ ";" +    , ps_glyphshow fallback+    ]++--------------------------------------------------------------------------------++formatArray :: (a -> Doc) -> [a] -> Doc+formatArray _  [] = brackets space+formatArray fn xs = brackets (separate space $ map fn xs)++command :: String -> [Doc] -> Doc+command cmd [] = text cmd+command cmd ds = hsep ds <+> text cmd +++-- | @ %% ... @+--+ps_comment :: String -> Doc+ps_comment ss = text "%%" <+> text ss++--------------------------------------------------------------------------------+-- Graphics state operators++-- | @ gsave @+--+ps_gsave :: Doc+ps_gsave = command "gsave" []++-- | @ grestore @+--+ps_grestore :: Doc+ps_grestore = command "grestore" []++++-- | @ ... setlinewidth @+--+ps_setlinewidth :: PSUnit u => u -> Doc+ps_setlinewidth u = command "setlinewidth" [dtruncFmt u]++-- | @ ... setlinecap @+--+ps_setlinecap :: LineCap -> Doc+ps_setlinecap a = command "setlinecap" [int $ fromEnum a]++-- | @ ... setlinejoin @+--+ps_setlinejoin :: LineJoin -> Doc+ps_setlinejoin a = command "setlinejoin" [int $ fromEnum a]++-- | @ ... setmiterlimit @+--+ps_setmiterlimit :: PSUnit u => u -> Doc+ps_setmiterlimit u = command "setmiterlimit" [dtruncFmt u]++-- | @ [... ...] ... setdash @+--+ps_setdash :: DashPattern -> Doc+ps_setdash Solid          = command "setdash" [text "[]", char '0']+ps_setdash (Dash n pairs) = command "setdash" [brackets $ step pairs, int n]+  where+    step []         = empty+    step [(a,b)]    = int a <+> int b+    step ((a,b):xs) = int a <+> int b <+> step xs  ++-- | @ ... ... ... setrgbcolor @+--+ps_setrgbcolor :: RGBi -> Doc+ps_setrgbcolor (RGBi r g b) = command "setrgbcolor" [fn r, fn g, fn b]+  where+    fn i = dtruncFmt $ (fromIntegral i / d255)+    d255 :: Double+    d255 = 255.0++--------------------------------------------------------------------------------+-- coordinate system and matrix operators ++-- | @ ... ... translate @+ps_translate :: PSUnit u => (Vec2 u) -> Doc+ps_translate (V2 dx dy) = command "translate" [dtruncFmt dx, dtruncFmt dy]+++-- Note - Do not use @setmatrix@ for changing the CTM use +-- @concat@ instead.+--+-- Using concat is harmonious with /nesting/.+-- ++-- | @ [... ... ... ... ... ...] concat @+--+ps_concat :: PSUnit u => Matrix3'3 u -> Doc+ps_concat mtrx = doc <+> text  "concat"+  where +    (a,b,c,d,e,f) = deconsMatrix mtrx+    doc           = formatArray dtruncFmt [a,b,c,d,e,f]++--------------------------------------------------------------------------------+-- Path construction operators++-- | @ newpath @+--+ps_newpath :: Doc+ps_newpath = command "newpath" []++-- Note - it is apparently preferable to show doubles as 0.0 +-- rather than 0.+--+-- I have read that in PostScript the coercion from int to float+-- is apparently quite expensive (I ought to locate the reference +-- for this...).++-- | @ ... ... moveto @+--+ps_moveto :: PSUnit u => Point2 u -> Doc+ps_moveto (P2 x y) = command "moveto" [dtruncFmt x, dtruncFmt y]+++-- | @ ... ... lineto @+--+ps_lineto :: PSUnit u => Point2 u -> Doc+ps_lineto (P2 x y) = command "lineto" [dtruncFmt x, dtruncFmt y]+++-- | @ ... ... ... ... ... arc @+--+ps_arc :: PSUnit u => Point2 u -> u -> Radian -> Radian -> Doc+ps_arc (P2 x y) radius ang1 ang2 = +    command "arc" $ [ dtruncFmt x+                    , dtruncFmt y+                    , dtruncFmt radius+                    , dtruncFmt $ fromR ang1+                    , dtruncFmt $ fromR ang2+                    ]+  where+    fromR :: Radian -> Double+    fromR = fromRadian++-- | @ ... ... ... ... ... ... curveto @+--+ps_curveto :: PSUnit u => Point2 u -> Point2 u -> Point2 u -> Doc+ps_curveto (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) =+    command "curveto" $ map dtruncFmt [x1,y1, x2,y2, x3,y3]++-- | @ closepath @+--+ps_closepath :: Doc+ps_closepath = command "closepath" []+++-- | @ clip @+--+ps_clip :: Doc+ps_clip = command "clip" []+++--------------------------------------------------------------------------------+--  painting operators++-- | @ fill @+--+ps_fill :: Doc+ps_fill = command "fill" []++-- | @ stroke @+--+ps_stroke :: Doc+ps_stroke = command "stroke" []++--------------------------------------------------------------------------------+-- Output operators++-- | @ showpage @+ps_showpage :: Doc+ps_showpage = command "showpage" []+++--------------------------------------------------------------------------------+-- Character and font operators++-- | The following fonts are expected to exist on most platforms:+--+-- > Times-Roman  Times-Italic  Times-Bold  Times-BoldItalic+-- > Helvetica  Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique+-- > Courier  Courier-Oblique  Courier-Bold  Courier-Bold-Oblique+-- > Symbol+--+-- List taken from Bill Casselman \'Mathematical Illustrations\' p279.+--+++-- | @ /... findfont @+--+ps_findfont :: String -> Doc+ps_findfont ss = command "findfont" [text $ '/':ss]++-- | @ ... scalefont @+--+ps_scalefont :: Int -> Doc+ps_scalefont sz = command "scalefont" [int sz]++-- | @ setfont @+--+ps_setfont :: Doc+ps_setfont = command "setfont" []++-- | @ (...) show  @+--+ps_show :: String -> Doc+ps_show ss = command "show" [parens $ text ss]++-- | @ (/...) show  @+--+ps_glyphshow :: String -> Doc+ps_glyphshow ss = command "glyphshow" [text $ '/':ss]+

@@ -9,7 +9,7 @@ -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more+-- Portability :  GHC -- -- Numeric type representing Point size (1/72 inch) which is  -- PostScript and Wumpus-Core\'s internal unit size.@@ -34,7 +34,9 @@   ) where  --- | Wumpus-Core +-- | Wrapped Double representing /Point size/ for font metrics +-- etc.+--  newtype PtSize = PtSize { ptSize :: Double }    deriving (Eq,Ord,Num,Floating,Fractional) 

@@ -1,436 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Core.SVG--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC with TypeFamilies and more------ SVG generation.------ SVG is represented using XML.Light. XML.Light is a simple,--- generic XML representation (almost) everything is an element --- with attributes.------ SVG output is monadic to handle clipping paths and --- configurable text encoding via a Reader monad. ------ SVG does not achieve clipping by changing the graphics state --- (being /declarative/ SVG doesn\'t have a graphics state as --- such). Instead a clipping path has an id, subsequent elements --- that are bound by the clipping path are tagged with a --- @clip-path@ attribute that references the clipping path id: ------ > clip-path=\"url(#clip1)\"--- --- --- The operations to build XML elements (e.g. element_path) don\'t --- take more parameters than necessary, and are expected to be --- augmented with attributes using 'add_attr' and 'add_attrs' from --- the XML.Light library.--- -----------------------------------------------------------------------------------module Wumpus.Core.SVG -  (-  -- * SVG Monad -    SvgM-  , runSVG-  , newClipLabel-  , currentClipLabel   ---  -- * Build SVG-  , SvgPath--  , unqualAttr-  , xmlVersion-  , svgDocType-  , gElement-  , svgElement-  -  , element_circle-  , element_ellipse-  , attr_x-  , attr_y-  , attr_r-  , attr_rx-  , attr_ry-  , attr_cx-  , attr_cy-  , element_path-  , element_clippath-  , element_text-  , element_tspan-  , content_text-  , attr_font_family-  , attr_font_size-  , attr_font_weight-  , attr_font_style-  , attr_id-  , attr_fill-  , attr_fill_none-  , attr_stroke-  , attr_stroke_none-  , attr_stroke_width-  , attr_stroke_miterlimit-  , attr_stroke_linecap-  , attr_stroke_linejoin--  , attr_stroke_dasharray-  , attr_stroke_dasharray_none-  , attr_stroke_dashoffset--  , attr_color-  , attr_clippath-  , attr_transform-  , val_matrix-  , val_colour-  , val_rgb-  , val_url-  , val_translate-  , path_m-  , path_l-  , path_c---  ) where--import Wumpus.Core.Colour-import Wumpus.Core.GraphicsState-import Wumpus.Core.TextEncoder-import Wumpus.Core.Utils---import MonadLib hiding ( version )-import Text.XML.Light---data SvgState = SvgSt { clipCount :: Int }---- | The SVG monad - which wraps a state monad to generate --- fresh names.-type SvgM a = SvgT Id a--newtype SvgT m a = SvgT { unSvgT :: StateT SvgState (ReaderT TextEncoder m) a }--runSvgT :: Monad m => TextEncoder -> SvgT m a -> m (a,SvgState)-runSvgT i m = runReaderT i $ runStateT st0 $ unSvgT m where-    st0 = SvgSt { clipCount = 0 } --instance Monad m => Functor (SvgT m) where-  fmap f (SvgT mf) = SvgT $ fmap f mf --instance Monad m => Monad (SvgT m) where-  return a  = SvgT $ return a-  ma >>= f  = SvgT $ unSvgT ma >>= unSvgT . f--instance Monad m => StateM (SvgT m) SvgState where-  get = SvgT $ get-  set = SvgT . set--instance Monad m => ReaderM (SvgT m) TextEncoder where-  ask = SvgT $ ask--instance MonadT SvgT where-  lift = SvgT . lift . lift---svgId :: TextEncoder -> SvgT Id a -> (a,SvgState)-svgId = runId `oo` runSvgT  ---- | Run the SVG monad.-runSVG :: TextEncoder -> SvgM a -> a-runSVG = fst `oo` svgId----- | Get the current clip label.-currentClipLabel :: SvgM String-currentClipLabel = get >>= return . clipname . clipCount---- | Generate a new clip label.-newClipLabel :: SvgM String-newClipLabel = do -  i <- (get >>= return . clipCount)-  sets_ (\s -> s { clipCount=i+1 })-  return $ clipname i---clipname :: Int -> String-clipname = ("clip" ++) . show-------------------------------------------------------------------------------------- Helpers for XML.Light and /data in strings/.---- | Helper for XML.Light-unqualAttr :: String -> String -> Attr-unqualAttr name val = Attr (unqual name) val-------------------------------------------------------------------------------------- SVG helpers--type SvgPath = [String]----- | @ \<?xml version=\"1.0\" encoding=\"...\"?\> @----xmlVersion :: String -> CData-xmlVersion s = CData CDataRaw -                     ("<?xml version=\"1.0\" encoding=\"" ++ s ++ "\"?>")-                     (Just 1)---- |--- > <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"           --- >     "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" > ----svgDocType :: CData-svgDocType = CData CDataRaw (line1 ++ "\n" ++ line2) (Just 1)-  where-    line1 = "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\""-    line2 = "  \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">"---- | --- > <g> ... </g>------ Wumpus uses the g element (group) to achieve nesting. -gElement :: [Attr] -> [Element] -> Element-gElement xs ys = unode "g" (xs,ys)---- |--- > <svg xmlns="http://www.w3.org/2000/svg" version="1.1">--- > ...--- > </svg>----svgElement :: [Element] -> Element-svgElement xs = unode "svg" ([xmlns,version],xs)-  where-    xmlns   = unqualAttr "xmlns" "http://www.w3.org/2000/svg"-    version = unqualAttr "version" "1.1"  ----------------------------------------------------------------------------------------- |--- > <circle/>----element_circle :: Element-element_circle = unode "circle" ()---- |--- > <ellipse/>----element_ellipse :: Element-element_ellipse = unode "ellipse" ()------ | @ x=\"...\" @-attr_x :: PSUnit u => u -> Attr-attr_x = unqualAttr "x" . dtrunc---- | @ y=\"...\" @-attr_y :: PSUnit u => u -> Attr-attr_y = unqualAttr "y" . dtrunc---- | @ r=\"...\" @-attr_r :: PSUnit u => u -> Attr-attr_r = unqualAttr "r" . dtrunc----- | @ rx=\"...\" @-attr_rx :: PSUnit u => u -> Attr-attr_rx = unqualAttr "rx" . dtrunc---- | @ ry=\"...\" @-attr_ry :: PSUnit u => u -> Attr-attr_ry = unqualAttr "ry" . dtrunc---- | @ cx=\"...\" @-attr_cx :: PSUnit u => u -> Attr-attr_cx = unqualAttr "cx" . dtrunc---- | @ cy=\"...\" @-attr_cy :: PSUnit u => u -> Attr-attr_cy = unqualAttr "cy" . dtrunc------- |--- > <path d="..." />------ Note the argument to this function is an attribute rather--- than content. We have no use for empty paths.-element_path :: SvgPath -> Element-element_path = unode "path" . attr_d---- |--- > <clipPath>--- > ...--- > </clipPath>----element_clippath :: SvgPath -> Element-element_clippath = unode "clipPath" . element_path---- |--- > <text>...</text>----element_text :: Node t => t -> Element-element_text = unode "text" ---- |--- > <text>...</text>----element_tspan :: String -> Element-element_tspan = unode "tspan" . content_text----- | Render the string as 'CDataText' - see XML.Light.-content_text :: String -> Content-content_text str = Text $ CData CDataRaw str Nothing----- | @ font-family=\"...\" @-attr_font_family :: String -> Attr-attr_font_family = unqualAttr "font-family" ---- | @ font-size=\"...\" @-attr_font_size :: Int -> Attr-attr_font_size = unqualAttr "font-size" . show---- | @ font-weight=\"...\" @-attr_font_weight :: String -> Attr-attr_font_weight = unqualAttr "font-weight"---- | @ font-style=\"...\" @-attr_font_style :: String -> Attr-attr_font_style = unqualAttr "font-style"----- | @ id=\"...\" @-attr_id :: String -> Attr-attr_id = unqualAttr "id" ---- | @ d="..." @-attr_d :: SvgPath -> Attr-attr_d = unqualAttr "d" . hsep---- | @ fill=\"rgb(..., ..., ...)\" @-attr_fill :: PSColour c => c -> Attr-attr_fill = unqualAttr "fill" . val_colour---- | @ fill=\"none\" @-attr_fill_none :: Attr-attr_fill_none = unqualAttr "fill" "none"---- | @ stroke=\"rgb(..., ..., ...)\" @-attr_stroke :: PSColour c => c -> Attr-attr_stroke = unqualAttr "stroke" . val_colour---- | @ stroke=\"none\" @-attr_stroke_none :: Attr-attr_stroke_none = unqualAttr "stroke" "none"---- | @ stroke-width=\"...\" @-attr_stroke_width :: PSUnit u => u -> Attr-attr_stroke_width = unqualAttr "stroke-width" . dtrunc----- | @ stroke-miterlimit=\"...\" @-attr_stroke_miterlimit :: PSUnit u => u -> Attr-attr_stroke_miterlimit = unqualAttr "stroke-miterlimit" . dtrunc---- | @ stroke-linejoin=\"...\" @-attr_stroke_linejoin :: LineJoin -> Attr-attr_stroke_linejoin JoinMiter = unqualAttr "stroke-linejoin" "miter"-attr_stroke_linejoin JoinRound = unqualAttr "stroke-linejoin" "round"-attr_stroke_linejoin JoinBevel = unqualAttr "stroke-linejoin" "bevel"----attr_stroke_linecap :: LineCap -> Attr-attr_stroke_linecap CapButt   = unqualAttr "stroke-linecap" "butt"-attr_stroke_linecap CapRound  = unqualAttr "stroke-linecap" "round"-attr_stroke_linecap CapSquare = unqualAttr "stroke-linecap" "square"----- | @ stroke-dasharray=\"...\" @-attr_stroke_dasharray :: [Int] -> Attr-attr_stroke_dasharray = unqualAttr "stroke-dasharray" . commasep . map show---- | @ stroke-dasharray=\"none\" @-attr_stroke_dasharray_none :: Attr-attr_stroke_dasharray_none = unqualAttr "stroke-dasharray" "none"---- | @ stroke-dashoffset=\"...\" @-attr_stroke_dashoffset :: Int -> Attr-attr_stroke_dashoffset = unqualAttr "stroke-dashoffset" . show---- | @ color=\"rgb(..., ..., ...)\" @------ Gray or HSB values will be converted to and rendered as RGB.-attr_color :: PSColour c => c -> Attr-attr_color = unqualAttr "color" . val_colour---- | @ clip-path=\"url(#...)\" @-attr_clippath :: String -> Attr-attr_clippath = unqualAttr "clip-path" . val_url---- | @ transform="..." @-attr_transform :: String -> Attr-attr_transform = unqualAttr "transform"---- | @ matrix(..., ..., ..., ..., ..., ...) @-val_matrix :: PSUnit u => u -> u -> u -> u -> u -> u -> String-val_matrix a b c d e f = "matrix" ++ tupled (map dtrunc [a,b,c,d,e,f])------ | @ rgb(..., ..., ...) @--- --- HSB and gray scale are translated to RGB values.-val_colour :: PSColour c => c -> String-val_colour = val_rgb . psColour----- | @ rgb(..., ..., ...) @-val_rgb :: RGB3 Double -> String-val_rgb (RGB3 r g b) = "rgb" ++ show (ramp255 r,ramp255 g,ramp255 b)----- | @ url(#...) @-val_url :: String -> String-val_url s = "url" ++ parens ('#':s)---- | @ translate(..., ...) @-val_translate :: PSUnit u => u -> u -> String-val_translate x y = "translate" ++ tupled (map dtrunc [x,y])-  --- | @ M ... ... @------ c.f. PostScript's @moveto@.-path_m :: PSUnit u => u -> u -> String-path_m x y  = hsep $ "M" : map dtrunc [x,y]---- | @ L ... ... @------ c.f. PostScript's @lineto@.-path_l :: PSUnit u => u -> u -> String-path_l x y  = hsep $ "L" : map dtrunc [x,y]---- | @ S ... ... ... ... ... ... @--- --- c.f. PostScript's @curveto@.-path_c :: PSUnit u => u -> u -> u -> u -> u -> u -> String-path_c x1 y1 x2 y2 x3 y3 =  hsep $ "C" : map dtrunc [x1,y1,x2,y2,x3,y3]--

@@ -0,0 +1,382 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Core.SVGDoc+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- SVG Doc combinators.+--+--------------------------------------------------------------------------------++module Wumpus.Core.SVGDoc+  (+    escapeSpecial++  , xml_version+  , doctype+  , elem_svg+  , elem_g+  , elem_g_no_attrs++  , elem_a_xlink  +  , elem_clipPath+  , elem_path+  , elem_text+  , elem_tspan+  , elem_ellipse+  , elem_circle++  , attr_id+  , attr_x+  , attr_y+  , attr_r+  , attr_rx+  , attr_ry+  , attr_cx+  , attr_cy++  , path_m+  , path_l+  , path_c++  , val_rgb++  , attr_font_family+  , attr_font_size+  , attr_font_weight+  , attr_font_style++  , attr_fill+  , attr_fill_none+  , attr_stroke+  , attr_stroke_none+  , attr_stroke_width+  , attr_stroke_miterlimit+  , attr_stroke_linecap+  , attr_stroke_linejoin++  , attr_stroke_dasharray+  , attr_stroke_dasharray_none+  , attr_stroke_dashoffset++  , attr_clip_path+  , attr_transform+  , val_matrix+  , val_translate++  ) where++import Wumpus.Core.Colour+import Wumpus.Core.FormatCombinators+import Wumpus.Core.Geometry+import Wumpus.Core.GraphicsState+import Wumpus.Core.PictureInternal+import Wumpus.Core.TextEncoder+import Wumpus.Core.Utils+++escapeSpecial :: CharCode -> String+escapeSpecial i = "&#" ++ show i ++ ";"+++-- Note - it is easier put particular attrs at the end (esp. d +-- for paths) if attrs are treated as a Doc. +++svgElem :: String -> Doc -> Doc+svgElem name attrs = angles (text name <+> attrs <+> char '/')++svgElemB :: String -> Doc -> Doc -> Doc+svgElemB name attrs body = vcat [ open, indent 2 body, close ]+  where+    open  = angles (text name <+> attrs)+    close = angles (char '/' <> text name)++svgElemB_no_attrs :: String -> Doc -> Doc+svgElemB_no_attrs name body = vcat [ open, indent 2 body, close ]+  where+    open  = angles (text name)+    close = angles (char '/' <> text name)++-- 1 line version of svgElemB+--+svgElemB1 :: String -> Doc -> Doc -> Doc+svgElemB1 name attrs body = open <> body <> close+  where+    open  = angles (text name <+> attrs)+    close = angles (char '/' <> text name)+++svgAttr :: String -> Doc -> Doc+svgAttr name val = text name <> char '=' <> dquotes val+ +dquoteText :: String -> Doc+dquoteText = dquotes . text ++--------------------------------------------------------------------------------+xml_version :: Doc+xml_version = text "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>"++doctype :: Doc +doctype = angles (    text "!DOCTYPE svg PUBLIC" +                  <+> dquoteText "-//W3C//DTD SVG 1.1//EN"+                  <+> dquoteText svg_url )+  where+    svg_url = "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"+++elem_svg :: Doc -> Doc +elem_svg body = svgElemB "svg" (svgns <+> svgvn <+> xlink) body+  where +    svgns = svgAttr "xmlns"       (text "http://www.w3.org/2000/svg")+    svgvn = svgAttr "version"     (text "1.1")+    xlink = svgAttr "xmlns:xlink" (text "http://www.w3.org/1999/xlink")++-- | @ \<g ...\> ... \</g\> @ +--+elem_g :: Doc -> Doc -> Doc+elem_g attrs body = svgElemB "g" attrs body++-- | @ \<g\> ... \<g/\> @ +--+elem_g_no_attrs :: Doc -> Doc+elem_g_no_attrs body = svgElemB_no_attrs "g" body++-- | @ \<clipPath ...\> ... \</clipPath\> @ +--+elem_clipPath :: Doc -> Doc -> Doc+elem_clipPath attrs body = svgElemB "clipPath" attrs body+++elem_a_xlink :: String -> Doc -> Doc+elem_a_xlink href body = svgElemB "a" attrs body+  where+    attrs = svgAttr "xlink:href" (text href)++++-- | @ \<path ... d=... /\> @+--+elem_path :: Doc -> Doc -> Doc+elem_path attrs path = svgElem "path" (attrs <+> svgAttr "d" path)+++-- | @ \<text ... >...\</text\> @+--+elem_text :: Doc -> Doc -> Doc+elem_text attrs body = svgElemB "text" attrs body+++-- | @ \<tspan ... >...\</tspan\> @+--+elem_tspan :: Doc -> Doc -> Doc+elem_tspan attrs body1 = svgElemB1 "tspan" attrs body1++-- @ \<circle ... /\>+--+elem_circle :: Doc -> Doc+elem_circle attrs = svgElem "circle" attrs++-- @ \<ellipse ... /\>+--+elem_ellipse :: Doc -> Doc+elem_ellipse attrs = svgElem "ellipse" attrs++-- | @ id=\"...\" @+--+attr_id :: String -> Doc+attr_id = svgAttr "id" . text+++-- | @ x=\"...\" @+--+attr_x :: PSUnit u => u -> Doc+attr_x = svgAttr "x" . dtruncFmt++-- | @ y=\"...\" @+--+attr_y :: PSUnit u => u -> Doc+attr_y = svgAttr "y" . dtruncFmt++-- | @ r=\"...\" @+--+attr_r :: PSUnit u => u -> Doc+attr_r = svgAttr "r" . dtruncFmt+++-- | @ rx=\"...\" @+--+attr_rx :: PSUnit u => u -> Doc+attr_rx = svgAttr "rx" . dtruncFmt++-- | @ ry=\"...\" @+--+attr_ry :: PSUnit u => u -> Doc+attr_ry = svgAttr "ry" . dtruncFmt++-- | @ cx=\"...\" @+--+attr_cx :: PSUnit u => u -> Doc+attr_cx = svgAttr "cx" . dtruncFmt++-- | @ cy=\"...\" @+--+attr_cy :: PSUnit u => u -> Doc+attr_cy = svgAttr "cy" . dtruncFmt+++++--------------------------------------------------------------------------------+-- Path Segments, encoded as string values.+++-- | @ M ... ... @+--+-- c.f. PostScript's @moveto@.+--+path_m :: PSUnit u => Point2 u -> Doc+path_m (P2 x y) = char 'M' <+> dtruncFmt x <+> dtruncFmt y++-- | @ L ... ... @+--+-- c.f. PostScript's @lineto@.+--+path_l :: PSUnit u => Point2 u -> Doc+path_l (P2 x y) = char 'L' <+> dtruncFmt x <+> dtruncFmt y++-- | @ C ... ... ... ... ... ... @+-- +-- c.f. PostScript's @curveto@.+--+path_c :: PSUnit u => Point2 u -> Point2 u -> Point2 u -> Doc+path_c (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) =+    char 'C' <+> dtruncFmt x1 <+> dtruncFmt y1+             <+> dtruncFmt x2 <+> dtruncFmt y2+             <+> dtruncFmt x3 <+> dtruncFmt y3+++val_rgb :: RGBi -> Doc+val_rgb (RGBi r g b) = +    text "rgb" <> tupled [integral r, integral g, integral b]+++-- | @ font-family=\"...\" @+--+attr_font_family :: String -> Doc+attr_font_family = svgAttr "font-family" . text++-- | @ font-size=\"...\" @+--+attr_font_size :: Int -> Doc+attr_font_size = svgAttr "font-size" . int++-- | @ font-weight=\"...\" @+--+attr_font_weight :: String -> Doc+attr_font_weight = svgAttr "font-weight" . text++-- | @ font-style=\"...\" @+--+attr_font_style :: String -> Doc+attr_font_style = svgAttr "font-style" . text+++-- | @ fill=\"rgb(..., ..., ...)\" @+--+attr_fill :: RGBi -> Doc+attr_fill = svgAttr "fill" . val_rgb ++-- | @ fill=\"none\" @+--+attr_fill_none :: Doc+attr_fill_none = svgAttr "fill" (text "none")++-- | @ stroke=\"rgb(..., ..., ...)\" @+--+attr_stroke :: RGBi -> Doc+attr_stroke = svgAttr "stroke" . val_rgb++-- | @ stroke=\"none\" @+--+attr_stroke_none :: Doc+attr_stroke_none = svgAttr "stroke" (text "none")++-- | @ stroke-width=\"...\" @+--+attr_stroke_width :: PSUnit u => u -> Doc+attr_stroke_width = svgAttr "stroke-width" . dtruncFmt+++-- | @ stroke-miterlimit=\"...\" @+--+attr_stroke_miterlimit :: PSUnit u => u -> Doc+attr_stroke_miterlimit = svgAttr "stroke-miterlimit" . dtruncFmt++-- | @ stroke-linejoin=\"...\" @+--+attr_stroke_linejoin :: LineJoin -> Doc+attr_stroke_linejoin = svgAttr "stroke-linejoin" . step +  where+    step JoinMiter = text "miter"+    step JoinRound = text "round"+    step JoinBevel = text "bevel"+++-- | @ stroke-linecap=\"...\" @+--+attr_stroke_linecap :: LineCap -> Doc+attr_stroke_linecap = svgAttr "stroke-linecap" . step+  where+    step CapButt   = text "butt"+    step CapRound  = text "round"+    step CapSquare = text "square"+++-- | @ stroke-dasharray=\"...\" @+--+attr_stroke_dasharray :: [(Int,Int)] -> Doc+attr_stroke_dasharray = svgAttr "stroke-dasharray" . step +  where+    step []         = empty+    step [(a,b)]    = int a <> comma <> int b +    step ((a,b):xs) = int a <> comma <> int b <> step xs++-- | @ stroke-dasharray=\"none\" @+--+attr_stroke_dasharray_none :: Doc+attr_stroke_dasharray_none = svgAttr "stroke-dasharray" (text "none")++-- | @ stroke-dashoffset=\"...\" @+--+attr_stroke_dashoffset :: Int -> Doc+attr_stroke_dashoffset = svgAttr "stroke-dashoffset" . int++-- | @ clip_path="url(#...)" @+--+attr_clip_path :: String -> Doc+attr_clip_path ss = svgAttr "transform" (text "url" <> parens (text $ '#':ss)) +++-- | @ transform="..." @+--+attr_transform :: Doc -> Doc+attr_transform = svgAttr "transform"++-- | @ matrix(..., ..., ..., ..., ..., ...) @+--+val_matrix :: PSUnit u => Matrix3'3 u -> Doc+val_matrix mtrx = text "matrix" <> tupled (map dtruncFmt [a,b,c,d,e,f])+  where+    (a,b,c,d,e,f) = deconsMatrix mtrx++-- | @ translate(..., ..., ..., ..., ..., ...) @+--+val_translate :: PSUnit u => Vec2 u -> Doc+val_translate (V2 x y) = text "translate" <> tupled [dtruncFmt x, dtruncFmt y]