wumpus-basic 0.12.0 → 0.13.0

raw patch · 59 files changed

+6685/−4156 lines, 59 filesdep +directorydep +filepathdep ~vector-spacedep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath

Dependency ranges changed: vector-space, wumpus-core

API changes (from Hackage documentation)

Files

• CHANGES +22/−0
• demo/ArrowCircuit.hs +46/−17
• demo/Arrowheads.hs +9/−15
• demo/ClipPic.hs +26/−25
• demo/ColourChartUtils.hs +502/−0
• demo/ColourCharts.hs +23/−17
• demo/ColourDefns.hs +0/−502
• demo/Connectors.hs +8/−13
• demo/DotPic.hs +38/−16
• demo/DrawingCompo.hs +152/−0
• demo/FeatureModel.hs +130/−0
• demo/FontLoaderUtils.hs +95/−0
• demo/FontPic.hs +34/−26
• demo/LeftRightText.hs +124/−0
• demo/PetriNet.hs +56/−56
• demo/Picture.hs +0/−151
• demo/Symbols.hs +189/−227
• src/Wumpus/Basic/Anchors.hs +0/−138
• src/Wumpus/Basic/Arrows/Connectors.hs +16/−14
• src/Wumpus/Basic/Arrows/Tips.hs +164/−123
• src/Wumpus/Basic/Dots/AnchorDots.hs +24/−12
• src/Wumpus/Basic/Dots/Marks.hs +31/−29
• src/Wumpus/Basic/DrawingComposition.hs +458/−0
• src/Wumpus/Basic/FontLoader/AfmLoader.hs +62/−0
• src/Wumpus/Basic/FontLoader/AfmParserBase.hs +215/−0
• src/Wumpus/Basic/FontLoader/AfmV2Parser.hs +67/−0
• src/Wumpus/Basic/FontLoader/AfmV4Dot1Parser.hs +67/−0
• src/Wumpus/Basic/FontLoader/Base.hs +222/−0
• src/Wumpus/Basic/FontLoader/GSFontMap.hs +87/−0
• src/Wumpus/Basic/FontLoader/GSLoader.hs +63/−0
• src/Wumpus/Basic/Graphic.hs +13/−3
• src/Wumpus/Basic/Graphic/Anchors.hs +158/−0
• src/Wumpus/Basic/Graphic/Base.hs +29/−373
• src/Wumpus/Basic/Graphic/ContextFunction.hs +718/−0
• src/Wumpus/Basic/Graphic/Drawing.hs +62/−304
• src/Wumpus/Basic/Graphic/DrawingContext.hs +70/−10
• src/Wumpus/Basic/Graphic/GlyphMetrics.hs +110/−0
• src/Wumpus/Basic/Graphic/GraphicOperations.hs +399/−0
• src/Wumpus/Basic/Graphic/GraphicTypes.hs +441/−0
• src/Wumpus/Basic/Graphic/PrimGraphic.hs +0/−319
• src/Wumpus/Basic/Graphic/Query.hs +79/−24
• src/Wumpus/Basic/Graphic/TraceDrawing.hs +329/−0
• src/Wumpus/Basic/Paths/Base.hs +2/−2
• src/Wumpus/Basic/Paths/RoundCorners.hs +9/−4
• src/Wumpus/Basic/PictureLanguage.hs +0/−481
• src/Wumpus/Basic/SafeFonts.hs +25/−17
• src/Wumpus/Basic/Shapes.hs +0/−2
• src/Wumpus/Basic/Shapes/Base.hs +7/−5
• src/Wumpus/Basic/Shapes/Coordinate.hs +75/−27
• src/Wumpus/Basic/Shapes/Derived.hs +2/−5
• src/Wumpus/Basic/Shapes/Plaintext.hs +0/−149
• src/Wumpus/Basic/Text/LRSymbol.hs +0/−746
• src/Wumpus/Basic/Text/LRText.hs +170/−128
• src/Wumpus/Basic/Utils/Combinators.hs +0/−92
• src/Wumpus/Basic/Utils/FormatCombinators.hs +430/−0
• src/Wumpus/Basic/Utils/ParserCombinators.hs +376/−0
• src/Wumpus/Basic/Utils/TokenParsers.hs +175/−0
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +74/−82

@@ -1,5 +1,27 @@  +0.11.0 to 0.12.0:++  * Changes Base types in  @Basic.Graphic@. The @Graphic@ and +    @Image@ types now produce (wrapped) @Primitives@, rather than +    Hughes lists of @Primitives@. This means they can now be +    transformed with the affine transformations. Removed the +    function @ati@, it is replaced by @at@.++  * Added @Basic.Utils.Combinators@.++  * Arrowheads and Connectors reworked - Arrowheads are now a +    functional type, Connectors use new Image combining +    operations from @Basic.Graphic.Base@.++  * Path connectors re-worked and renamed. ++  * Dot hierarchy changed - @Basic.Dots@ becomes +    @Basic.Dots.AnchorDots@; @Basic.Dots.Primitive@ becomes+    @Basic.Dots.Marks@.++  * @Basic.Shapes@ - internals reworked.+ 0.10.0 to 0.11.0:     * Reworked arrowheads and connectors - connectors are now 

@@ -8,15 +8,20 @@  module ArrowCircuit where -import Wumpus.Basic.Anchors import Wumpus.Basic.Arrows+import Wumpus.Basic.FontLoader.AfmLoader+import Wumpus.Basic.FontLoader.GSLoader import Wumpus.Basic.Graphic import Wumpus.Basic.Paths  import Wumpus.Basic.SafeFonts import Wumpus.Basic.Shapes+import Wumpus.Basic.Text.LRText  import Wumpus.Core                      -- package: wumpus-core +import FontLoaderUtils++ import Data.AffineSpace  import System.Directory@@ -24,27 +29,52 @@  main :: IO () main = do +    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help     createDirectoryIfMissing True "./out/"-    writeEPS_latin1 "./out/arrow_circuit.eps" pic1-    writeSVG_latin1 "./out/arrow_circuit.svg" pic1 +    maybe gs_failk  makeGSPicture  $ mb_gs+    maybe afm_failk makeAfmPicture $ mb_afm+  where+    gs_failk  = putStrLn "No GhostScript font path supplied..."+    afm_failk = putStrLn "No AFM v4.1 font path supplied..." -times_ctx :: DrawingContext-times_ctx = fontface times_roman $ standardContext 11+makeGSPicture :: FilePath -> IO ()+makeGSPicture font_dir = do +    putStrLn "Using GhostScript metrics..."+    base_metrics <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"]+    let pic1 = runDrawingU (makeCtx base_metrics) circuit_drawing+    writeEPS "./out/arrow_circuit01.eps" pic1+    writeSVG "./out/arrow_circuit01.svg" pic1  +makeAfmPicture :: FilePath -> IO ()+makeAfmPicture font_dir = do +    putStrLn "Using AFM 4.1 metrics..."+    base_metrics <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"]+    let pic1 = runDrawingU (makeCtx base_metrics) circuit_drawing+    writeEPS "./out/arrow_circuit02.eps" pic1+    writeSVG "./out/arrow_circuit02.svg" pic1 ++ +makeCtx :: BaseGlyphMetrics -> DrawingContext+makeCtx = fontface times_roman . metricsContext 11+++ -- Note - quite a bit of this diagram was produced /by eye/,  -- rather than using anchors directly - e.g. the placing of the  -- ptext labels and the anchors displaced by vectors. --++-- Note `at` currently does not work for Shapes.          -pic1 :: Picture Double -pic1 = liftToPictureU $ execDrawing times_ctx $ do-    a1 <- drawi $ strokedShape $ rrectangle 12 66 30 `at` P2 0 72+circuit_drawing :: Drawing Double +circuit_drawing = drawTracing $ do+    a1 <- drawi $ strokedShape $ rrectangle 12 66 30 $ P2 0 72     atext a1 "CONST 0"-    a2 <- drawi $ strokedShape $ circle 16 `at` P2 120 60+    a2 <- drawi $ strokedShape $ circle 16 $ P2 120 60     atext a2 "IF"-    a3 <- drawi $ strokedShape $ circle 16 `at` P2 240 28+    a3 <- drawi $ strokedShape $ circle 16 $ P2 240 28     atext a3 "+1"-    a4 <- drawi $ strokedShape $ rectangle 66 30 `at` P2 120 0+    a4 <- drawi $ strokedShape $ rectangle 66 30 $ P2 120 0     atext a4 "DELAY 0"     connWith connLine (east a1) (east a1 .+^ hvec 76)     connWith connLine (east a2) (east a2 .+^ hvec 180)@@ -58,25 +88,24 @@     return ()  --- Note - conn from Basic.Graphic is now questionable...  connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m             , Real u, Floating u, FromPtSize u )           => ConnectorPath u -> Point2 u -> Point2 u -> m () connWith con p0 p1 = localize doublesize $ -    drawi_ $ strokeConnector (rightArrow con tri45) p0 p1+    drawi_ $ situ2 (strokeConnector (rightArrow con tri45)) p0 p1   atext :: ( CenterAnchor t, DUnit t ~ u          , Real u, Floating u, FromPtSize u          , TraceM m, DrawingCtxM m, u ~ MonUnit m )       => t -> String -> m ()-atext ancr ss = let (P2 x y) = center ancr in-   drawi_ $ drawText $ translate x y $ plaintext ss+atext ancr ss = let pt = center ancr in+   drawi_ $ singleLineCC ss `at` pt   ptext :: ( Real u, Floating u, FromPtSize u          , TraceM m, DrawingCtxM m, u ~ MonUnit m )       => Point2 u -> String -> m ()-ptext (P2 x y) ss = localize (fontsize 14 . fontface times_italic) $ -    drawi_ $ drawText $ translate x y $ plaintext ss+ptext pt ss = localize (fontsize 14 . fontface times_italic) $ +    drawi_ $ singleLineCC ss `at` pt

@@ -19,19 +19,12 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    demo01--pt2 :: Point2 Double-pt2 = P2 100 10---demo01 :: IO ()-demo01 = do -    writeEPS_latin1 "./out/arrowheads01.eps" pic1-    writeSVG_latin1 "./out/arrowheads01.svg" pic1+    let pic1 = runDrawingU std_ctx arrow_drawing+    writeEPS "./out/arrowheads01.eps" pic1+    writeSVG "./out/arrowheads01.svg" pic1 -pic1 :: Picture Double-pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ arrtable+arrow_drawing :: Drawing Double+arrow_drawing = drawTracing $ tableGraphic arrtable  arrtable :: [(Arrowhead Double, Arrowhead Double)] arrtable = @@ -66,7 +59,7 @@     ]  tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [(Arrowhead u, Arrowhead u)] -> Drawing u ()+             => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u () tableGraphic tips = zipWithM_ makeArrowDrawing tips ps   where     ps = unchain (coordinateScalingContext 120 24) $ tableDown 20 4@@ -79,9 +72,10 @@   makeArrowDrawing :: (Real u, Floating u, FromPtSize u) -                 => (Arrowhead u, Arrowhead u) -> Point2 u -> Drawing u ()+                 => (Arrowhead u, Arrowhead u) -> Point2 u +                 -> TraceDrawing u () makeArrowDrawing (arrl,arrr) p0 = -    drawi_ $ strokeConnector (leftrightArrow connLine arrl arrr) p0 p1+    drawi_ $ situ2 (strokeConnector (leftrightArrow connLine arrl arrr)) p0 p1   where     p1 = p0 .+^ hvec 100   

@@ -14,36 +14,38 @@  import Wumpus.Basic.Chains import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.DrawingComposition import Wumpus.Basic.Graphic import Wumpus.Basic.Paths-import Wumpus.Basic.PictureLanguage-import Wumpus.Basic.Text.LRSymbol-import Wumpus.Basic.Text.LRText+import Wumpus.Basic.SafeFonts  import Wumpus.Core                              -- package: wumpus-core +import Data.AffineSpace                         -- package: vector-space+ import System.Directory   main :: IO () main = do      createDirectoryIfMissing True "./out/"-    >> writeEPS_latin1 "./out/clip_pic.eps" pic-    >> writeSVG_latin1 "./out/clip_pic.svg" pic+    let pic = runDrawingU pic_drawing_ctx big_pic+    writeEPS "./out/clip_pic.eps" pic+    writeSVG "./out/clip_pic.svg" pic   pic_drawing_ctx :: DrawingContext pic_drawing_ctx = standardContext 14  -pic :: DPicture-pic = pic1 `nextToV` (stackOver [cpic1, cpic2, cpic3] cpic4)+big_pic :: DDrawing+big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4]  fillPath :: Num u => Path u -> Graphic u fillPath = filledPath . toPrimPath -pic1 :: DPicture-pic1 = liftToPictureU $ execDrawing pic_drawing_ctx $ +pic1 :: DDrawing+pic1 = drawTracing $          localize (fillColour medium_slate_blue) $ do             draw $ fillPath path01             localize (fillColour powder_blue) $ @@ -52,30 +54,29 @@             draw $ fillPath path04  -background :: RGBi -> DPicture -background rgb = liftToPictureU $ execDrawing pic_drawing_ctx $ -                   localize (strokeColour rgb) $ do                  -                     mapM_ iheartHaskell ps-+background :: RGBi -> DDrawing+background rgb = drawTracing $ +    localize (strokeColour rgb) $ mapM_ iheartHaskell ps    where      ps = unchain (coordinateScalingContext 86 16) $ tableDown 18 8 -cpic1 :: DPicture -cpic1 = clip (toPrimPath path01) (background black)+cpic1 :: DDrawing +cpic1 = clipDrawing (toPrimPath path01) (background black)   -cpic2 :: DPicture -cpic2 = clip (toPrimPath path02) (background medium_violet_red)+cpic2 :: DDrawing+cpic2 = clipDrawing (toPrimPath path02) (background medium_violet_red) -cpic3 :: DPicture -cpic3 = clip (toPrimPath path03) (background black)+cpic3 :: DDrawing +cpic3 = clipDrawing (toPrimPath path03) (background black) -cpic4 :: DPicture -cpic4 = clip (toPrimPath path04) (background black)+cpic4 :: DDrawing +cpic4 = clipDrawing (toPrimPath path04) (background black)  -iheartHaskell :: Num u => FromPtSize u => Point2 u -> Drawing u () -iheartHaskell pt = -    draw $ (execLRText $ char 'I' >> heart >> mapM_ char "Haskell") `at` pt+iheartHaskell :: Num u => FromPtSize u => Point2 u -> TraceDrawing u () +iheartHaskell pt = do+    draw $ textline "I Haskell" `at` pt+    draw $ localize (fontface symbol) $ textline "&heart;" `at` (pt .+^ hvec 7)   path01 :: Floating u => Path u

@@ -0,0 +1,502 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  ColourChartUtils+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- All the SVG / X11 \"named colours\" listed in tables. +--+--------------------------------------------------------------------------------++module ColourChartUtils+  ( +  -- * Tables of all colours+    all_x11_colours+  , all_svg_colours++  ) where++import qualified Wumpus.Basic.Colour.SVGColours    as SVG+import qualified Wumpus.Basic.Colour.X11Colours    as X11++import Wumpus.Core.Colour ( RGBi )+++all_svg_colours :: [(String,RGBi)]+all_svg_colours = +  [ ("alice_blue",              SVG.alice_blue)+  , ("antique_white",           SVG.antique_white)+  , ("aqua",                    SVG.aqua)+  , ("aquamarine",              SVG.aquamarine)+  , ("azure",                   SVG.azure)+  , ("beige",                   SVG.beige)+  , ("bisque",                  SVG.bisque)+  , ("black",                   SVG.black)+  , ("blanched_almond",         SVG.blanched_almond)+  , ("blue",                    SVG.blue)+  , ("blue_violet",             SVG.blue_violet)+  , ("brown",                   SVG.brown)+  , ("burlywood",               SVG.burlywood)+  , ("cadet_blue",              SVG.cadet_blue)+  , ("chartreuse",              SVG.chartreuse)+  , ("chocolate",               SVG.chocolate)+  , ("coral",                   SVG.coral)+  , ("cornflower_blue",         SVG.cornflower_blue)+  , ("cornsilk",                SVG.cornsilk)+  , ("crimson",                 SVG.crimson)+  , ("cyan",                    SVG.cyan)+  , ("dark_blue",               SVG.dark_blue)+  , ("dark_cyan",               SVG.dark_cyan)+  , ("dark_goldenrod",          SVG.dark_goldenrod)+  , ("dark_gray",               SVG.dark_gray)+  , ("dark_green",              SVG.dark_green)+  , ("dark_grey",               SVG.dark_grey)+  , ("dark_khaki",              SVG.dark_khaki)+  , ("dark_magenta",            SVG.dark_magenta)+  , ("dark_olive_green",        SVG.dark_olive_green)+  , ("dark_orange",             SVG.dark_orange)+  , ("dark_orchid",             SVG.dark_orchid)+  , ("dark_red",                SVG.dark_red)+  , ("dark_salmon",             SVG.dark_salmon)+  , ("dark_sea_green",          SVG.dark_sea_green)+  , ("dark_slate_blue",         SVG.dark_slate_blue)+  , ("dark_slate_gray",         SVG.dark_slate_gray)+  , ("dark_slate_grey",         SVG.dark_slate_grey)+  , ("dark_turquoise",          SVG.dark_turquoise)+  , ("dark_violet",             SVG.dark_violet)+  , ("deep_pink",               SVG.deep_pink)+  , ("deep_sky_blue",           SVG.deep_sky_blue)+  , ("dim_gray",                SVG.dim_gray)+  , ("dim_grey",                SVG.dim_grey)+  , ("dodger_blue",             SVG.dodger_blue)+  , ("firebrick",               SVG.firebrick)+  , ("floral_white",            SVG.floral_white)+  , ("forest_green",            SVG.forest_green)+  , ("fuchsia",                 SVG.fuchsia)+  , ("gainsboro",               SVG.gainsboro)+  , ("ghost_white",             SVG.ghost_white)+  , ("gold",                    SVG.gold)+  , ("goldenrod",               SVG.goldenrod)+  , ("gray",                    SVG.gray)+  , ("grey",                    SVG.grey)+  , ("green",                   SVG.green)+  , ("green_yellow",            SVG.green_yellow)+  , ("honeydew",                SVG.honeydew)+  , ("hot_pink",                SVG.hot_pink)+  , ("indian_red",              SVG.indian_red)+  , ("indigo",                  SVG.indigo)+  , ("ivory",                   SVG.ivory)+  , ("khaki",                   SVG.khaki)+  , ("lavender",                SVG.lavender)+  , ("lavender_blush",          SVG.lavender_blush)+  , ("lawn_green",              SVG.lawn_green)+  , ("lemon_chiffon",           SVG.lemon_chiffon)+  , ("light_blue",              SVG.light_blue)+  , ("light_coral",             SVG.light_coral)+  , ("light_cyan",              SVG.light_cyan)+  , ("light_goldenrod_yellow",  SVG.light_goldenrod_yellow)+  , ("light_gray",              SVG.light_gray)+  , ("light_green",             SVG.light_green)+  , ("light_grey",              SVG.light_grey)+  , ("light_pink",              SVG.light_pink)+  , ("light_salmon",            SVG.light_salmon)+  , ("light_sea_green",         SVG.light_sea_green)+  , ("light_sky_blue",          SVG.light_sky_blue)+  , ("light_slate_gray",        SVG.light_slate_gray)+  , ("light_slate_grey",        SVG.light_slate_grey)+  , ("light_steel_blue",        SVG.light_steel_blue)+  , ("light_yellow",            SVG.light_yellow)+  , ("lime",                    SVG.lime)+  , ("lime_green",              SVG.lime_green)+  , ("linen",                   SVG.linen)+  , ("magenta",                 SVG.magenta)+  , ("maroon",                  SVG.maroon)+  , ("medium_aquamarine",       SVG.medium_aquamarine)+  , ("medium_blue",             SVG.medium_blue)+  , ("medium_orchid",           SVG.medium_orchid)+  , ("medium_purple",           SVG.medium_purple)+  , ("medium_sea_green",        SVG.medium_sea_green)+  , ("medium_slate_blue",       SVG.medium_slate_blue)+  , ("medium_spring_green",     SVG.medium_spring_green)+  , ("medium_turquoise",        SVG.medium_turquoise)+  , ("medium_violet_red",       SVG.medium_violet_red)+  , ("midnight_blue",           SVG.midnight_blue)+  , ("mintcream",               SVG.mintcream)+  , ("mistyrose",               SVG.mistyrose)+  , ("moccasin",                SVG.moccasin)+  , ("navajo_white",            SVG.navajo_white)+  , ("navy",                    SVG.navy)+  , ("old_lace",                SVG.old_lace)+  , ("olive",                   SVG.olive)+  , ("olive_drab",              SVG.olive_drab)+  , ("orange",                  SVG.orange)+  , ("orange_red",              SVG.orange_red)+  , ("orchid",                  SVG.orchid)+  , ("pale_goldenrod",          SVG.pale_goldenrod)+  , ("pale_green",              SVG.pale_green)+  , ("pale_turquoise",          SVG.pale_turquoise)+  , ("pale_violet_red",         SVG.pale_violet_red)+  , ("papaya_whip",             SVG.papaya_whip)+  , ("peach_puff",              SVG.peach_puff)+  , ("peru",                    SVG.peru)+  , ("pink",                    SVG.pink)+  , ("plum",                    SVG.plum)+  , ("powder_blue",             SVG.powder_blue)+  , ("purple",                  SVG.purple)+  , ("red",                     SVG.red)+  , ("rosy_brown",              SVG.rosy_brown)+  , ("royal_blue",              SVG.royal_blue)+  , ("saddle_brown",            SVG.saddle_brown)+  , ("salmon",                  SVG.salmon)+  , ("sandy_brown",             SVG.sandy_brown)+  , ("sea_green",               SVG.sea_green)+  , ("seashell",                SVG.seashell)+  , ("sienna",                  SVG.sienna)+  , ("silver",                  SVG.silver)+  , ("sky_blue",                SVG.sky_blue)+  , ("slate_blue",              SVG.slate_blue)+  , ("slate_gray",              SVG.slate_gray)+  , ("slate_grey",              SVG.slate_grey)+  , ("snow",                    SVG.snow)+  , ("spring_green",            SVG.spring_green)+  , ("steel_blue",              SVG.steel_blue)+  , ("tan",                     SVG.tan)+  , ("teal",                    SVG.teal)+  , ("thistle",                 SVG.thistle)+  , ("tomato",                  SVG.tomato)+  , ("turquoise",               SVG.turquoise)+  , ("violet",                  SVG.violet)+  , ("wheat",                   SVG.wheat)+  , ("white",                   SVG.white)+  , ("whitesmoke",              SVG.whitesmoke)+  , ("yellow",                  SVG.yellow)+  , ("yellow_green",            SVG.yellow_green)+  ]++++all_x11_colours :: [(String,RGBi)]+all_x11_colours = +  [ ("antique_white1",          X11.antique_white1)+  , ("antique_white2",          X11.antique_white2)+  , ("antique_white3",          X11.antique_white3)+  , ("antique_white4",          X11.antique_white4)+  , ("aquamarine1",             X11.aquamarine1)+  , ("aquamarine2",             X11.aquamarine2)+  , ("aquamarine3",             X11.aquamarine3)+  , ("aquamarine4",             X11.aquamarine4)+  , ("azure1",                  X11.azure1)+  , ("azure2",                  X11.azure2)+  , ("azure3",                  X11.azure3)+  , ("azure4",                  X11.azure4)+  , ("bisque1",                 X11.bisque1)+  , ("bisque2",                 X11.bisque2)+  , ("bisque3",                 X11.bisque3)+  , ("bisque4",                 X11.bisque4)+  , ("blue1",                   X11.blue1)+  , ("blue2",                   X11.blue2)+  , ("blue3",                   X11.blue3)+  , ("blue4",                   X11.blue4)+  , ("brown1",                  X11.brown1)+  , ("brown2",                  X11.brown2)+  , ("brown3",                  X11.brown3)+  , ("brown4",                  X11.brown4)+  , ("burlywood1",              X11.burlywood1)+  , ("burlywood2",              X11.burlywood2)+  , ("burlywood3",              X11.burlywood3)+  , ("burlywood4",              X11.burlywood4)+  , ("cadet_blue1",             X11.cadet_blue1)+  , ("cadet_blue2",             X11.cadet_blue2)+  , ("cadet_blue3",             X11.cadet_blue3)+  , ("cadet_blue4",             X11.cadet_blue4)+  , ("chartreuse1",             X11.chartreuse1)+  , ("chartreuse2",             X11.chartreuse2)+  , ("chartreuse3",             X11.chartreuse3)+  , ("chartreuse4",             X11.chartreuse4)+  , ("chocolate1",              X11.chocolate1)+  , ("chocolate2",              X11.chocolate2)+  , ("chocolate3",              X11.chocolate3)+  , ("chocolate4",              X11.chocolate4)+  , ("coral1",                  X11.coral1)+  , ("coral2",                  X11.coral2)+  , ("coral3",                  X11.coral3)+  , ("coral4",                  X11.coral4)+  , ("cornsilk1",               X11.cornsilk1)+  , ("cornsilk2",               X11.cornsilk2)+  , ("cornsilk3",               X11.cornsilk3)+  , ("cornsilk4",               X11.cornsilk4)+  , ("cyan1",                   X11.cyan1)+  , ("cyan2",                   X11.cyan2)+  , ("cyan3",                   X11.cyan3)+  , ("cyan4",                   X11.cyan4)+  , ("dark_goldenrod1",         X11.dark_goldenrod1)+  , ("dark_goldenrod2",         X11.dark_goldenrod2)+  , ("dark_goldenrod3",         X11.dark_goldenrod3)+  , ("dark_goldenrod4",         X11.dark_goldenrod4)+  , ("dark_olive_green1",       X11.dark_olive_green1)+  , ("dark_olive_green2",       X11.dark_olive_green2)+  , ("dark_olive_green3",       X11.dark_olive_green3)+  , ("dark_olive_green4",       X11.dark_olive_green4)+  , ("dark_orange1",            X11.dark_orange1)+  , ("dark_orange2",            X11.dark_orange2)+  , ("dark_orange3",            X11.dark_orange3)+  , ("dark_orange4",            X11.dark_orange4)+  , ("dark_orchid1",            X11.dark_orchid1)+  , ("dark_orchid2",            X11.dark_orchid2)+  , ("dark_orchid3",            X11.dark_orchid3)+  , ("dark_orchid4",            X11.dark_orchid4)+  , ("dark_sea_green1",         X11.dark_sea_green1)+  , ("dark_sea_green2",         X11.dark_sea_green2)+  , ("dark_sea_green3",         X11.dark_sea_green3)+  , ("dark_sea_green4",         X11.dark_sea_green4)+  , ("dark_slate_gray1",        X11.dark_slate_gray1)+  , ("dark_slate_gray2",        X11.dark_slate_gray2)+  , ("dark_slate_gray3",        X11.dark_slate_gray3)+  , ("dark_slate_gray4",        X11.dark_slate_gray4)+  , ("deep_pink1",              X11.deep_pink1)+  , ("deep_pink2",              X11.deep_pink2)+  , ("deep_pink3",              X11.deep_pink3)+  , ("deep_pink4",              X11.deep_pink4)+  , ("deep_sky_blue1",          X11.deep_sky_blue1)+  , ("deep_sky_blue2",          X11.deep_sky_blue2)+  , ("deep_sky_blue3",          X11.deep_sky_blue3)+  , ("deep_sky_blue4",          X11.deep_sky_blue4)+  , ("dodger_blue1",            X11.dodger_blue1)+  , ("dodger_blue2",            X11.dodger_blue2)+  , ("dodger_blue3",            X11.dodger_blue3)+  , ("dodger_blue4",            X11.dodger_blue4)+  , ("firebrick1",              X11.firebrick1)+  , ("firebrick2",              X11.firebrick2)+  , ("firebrick3",              X11.firebrick3)+  , ("firebrick4",              X11.firebrick4)+  , ("gold1",                   X11.gold1)+  , ("gold2",                   X11.gold2)+  , ("gold3",                   X11.gold3)+  , ("gold4",                   X11.gold4)+  , ("goldenrod1",              X11.goldenrod1)+  , ("goldenrod2",              X11.goldenrod2)+  , ("goldenrod3",              X11.goldenrod3)+  , ("goldenrod4",              X11.goldenrod4)+  , ("green1",                  X11.green1)+  , ("green2",                  X11.green2)+  , ("green3",                  X11.green3)+  , ("green4",                  X11.green4)+  , ("honeydew1",               X11.honeydew1)+  , ("honeydew2",               X11.honeydew2)+  , ("honeydew3",               X11.honeydew3)+  , ("honeydew4",               X11.honeydew4)+  , ("hot_pink1",               X11.hot_pink1)+  , ("hot_pink2",               X11.hot_pink2)+  , ("hot_pink3",               X11.hot_pink3)+  , ("hot_pink4",               X11.hot_pink4)+  , ("indian_red1",             X11.indian_red1)+  , ("indian_red2",             X11.indian_red2)+  , ("indian_red3",             X11.indian_red3)+  , ("indian_red4",             X11.indian_red4)+  , ("ivory1",                  X11.ivory1)+  , ("ivory2",                  X11.ivory2)+  , ("ivory3",                  X11.ivory3)+  , ("ivory4",                  X11.ivory4)+  , ("khaki1",                  X11.khaki1)+  , ("khaki2",                  X11.khaki2)+  , ("khaki3",                  X11.khaki3)+  , ("khaki4",                  X11.khaki4)+  , ("lavender_blush1",         X11.lavender_blush1)+  , ("lavender_blush2",         X11.lavender_blush2)+  , ("lavender_blush3",         X11.lavender_blush3)+  , ("lavender_blush4",         X11.lavender_blush4)+  , ("lemon_chiffon1",          X11.lemon_chiffon1)+  , ("lemon_chiffon2",          X11.lemon_chiffon2)+  , ("lemon_chiffon3",          X11.lemon_chiffon3)+  , ("lemon_chiffon4",          X11.lemon_chiffon4)+  , ("light_blue1",             X11.light_blue1)+  , ("light_blue2",             X11.light_blue2)+  , ("light_blue3",             X11.light_blue3)+  , ("light_blue4",             X11.light_blue4)+  , ("light_cyan1",             X11.light_cyan1)+  , ("light_cyan2",             X11.light_cyan2)+  , ("light_cyan3",             X11.light_cyan3)+  , ("light_cyan4",             X11.light_cyan4)+  , ("light_goldenrod1",        X11.light_goldenrod1)+  , ("light_goldenrod2",        X11.light_goldenrod2)+  , ("light_goldenrod3",        X11.light_goldenrod3)+  , ("light_goldenrod4",        X11.light_goldenrod4)+  , ("light_pink1",             X11.light_pink1)+  , ("light_pink2",             X11.light_pink2)+  , ("light_pink3",             X11.light_pink3)+  , ("light_pink4",             X11.light_pink4)+  , ("light_salmon1",           X11.light_salmon1)+  , ("light_salmon2",           X11.light_salmon2)+  , ("light_salmon3",           X11.light_salmon3)+  , ("light_salmon4",           X11.light_salmon4)+  , ("light_sky_blue1",         X11.light_sky_blue1)+  , ("light_sky_blue2",         X11.light_sky_blue2)+  , ("light_sky_blue3",         X11.light_sky_blue3)+  , ("light_sky_blue4",         X11.light_sky_blue4)+  , ("light_steel_blue1",       X11.light_steel_blue1)+  , ("light_steel_blue2",       X11.light_steel_blue2)+  , ("light_steel_blue3",       X11.light_steel_blue3)+  , ("light_steel_blue4",       X11.light_steel_blue4)+  , ("light_yellow1",           X11.light_yellow1)+  , ("light_yellow2",           X11.light_yellow2)+  , ("light_yellow3",           X11.light_yellow3)+  , ("light_yellow4",           X11.light_yellow4)+  , ("magenta1",                X11.magenta1)+  , ("magenta2",                X11.magenta2)+  , ("magenta3",                X11.magenta3)+  , ("magenta4",                X11.magenta4)+  , ("maroon1",                 X11.maroon1)+  , ("maroon2",                 X11.maroon2)+  , ("maroon3",                 X11.maroon3)+  , ("maroon4",                 X11.maroon4)+  , ("medium_orchid1",          X11.medium_orchid1)+  , ("medium_orchid2",          X11.medium_orchid2)+  , ("medium_orchid3",          X11.medium_orchid3)+  , ("medium_orchid4",          X11.medium_orchid4)+  , ("medium_purple1",          X11.medium_purple1)+  , ("medium_purple2",          X11.medium_purple2)+  , ("medium_purple3",          X11.medium_purple3)+  , ("medium_purple4",          X11.medium_purple4)+  , ("misty_rose1",             X11.misty_rose1)+  , ("misty_rose2",             X11.misty_rose2)+  , ("misty_rose3",             X11.misty_rose3)+  , ("misty_rose4",             X11.misty_rose4)+  , ("navajo_white1",           X11.navajo_white1)+  , ("navajo_white2",           X11.navajo_white2)+  , ("navajo_white3",           X11.navajo_white3)+  , ("navajo_white4",           X11.navajo_white4)+  , ("olive_drab1",             X11.olive_drab1)+  , ("olive_drab2",             X11.olive_drab2)+  , ("olive_drab3",             X11.olive_drab3)+  , ("olive_drab4",             X11.olive_drab4)+  , ("orange1",                 X11.orange1)+  , ("orange2",                 X11.orange2)+  , ("orange3",                 X11.orange3)+  , ("orange4",                 X11.orange4)+  , ("orange_red1",             X11.orange_red1)+  , ("orange_red2",             X11.orange_red2)+  , ("orange_red3",             X11.orange_red3)+  , ("orange_red4",             X11.orange_red4)+  , ("orchid1",                 X11.orchid1)+  , ("orchid2",                 X11.orchid2)+  , ("orchid3",                 X11.orchid3)+  , ("orchid4",                 X11.orchid4)+  , ("pale_green1",             X11.pale_green1)+  , ("pale_green2",             X11.pale_green2)+  , ("pale_green3",             X11.pale_green3)+  , ("pale_green4",             X11.pale_green4)+  , ("pale_turquoise1",         X11.pale_turquoise1)+  , ("pale_turquoise2",         X11.pale_turquoise2)+  , ("pale_turquoise3",         X11.pale_turquoise3)+  , ("pale_turquoise4",         X11.pale_turquoise4)+  , ("pale_violet_red1",        X11.pale_violet_red1)+  , ("pale_violet_red2",        X11.pale_violet_red2)+  , ("pale_violet_red3",        X11.pale_violet_red3)+  , ("pale_Violet_red4",        X11.pale_violet_red4)+  , ("peach_puff1",             X11.peach_puff1)+  , ("peach_puff2",             X11.peach_puff2)+  , ("peach_puff3",             X11.peach_puff3)+  , ("peach_puff4",             X11.peach_puff4)+  , ("pink1",                   X11.pink1)+  , ("pink2",                   X11.pink2)+  , ("pink3",                   X11.pink3)+  , ("pink4",                   X11.pink4)+  , ("plum1",                   X11.plum1)+  , ("plum2",                   X11.plum2)+  , ("plum3",                   X11.plum3)+  , ("plum4",                   X11.plum4)+  , ("purple1",                 X11.purple1)+  , ("purple2",                 X11.purple2)+  , ("purple3",                 X11.purple3)+  , ("purple4",                 X11.purple4)+  , ("red1",                    X11.red1)+  , ("red2",                    X11.red2)+  , ("red3",                    X11.red3)+  , ("red4",                    X11.red4)+  , ("rosy_brown1",             X11.rosy_brown1)+  , ("rosy_brown2",             X11.rosy_brown2)+  , ("rosy_brown3",             X11.rosy_brown3)+  , ("rosy_brown4",             X11.rosy_brown4)+  , ("royal_blue1",             X11.royal_blue1)+  , ("royal_blue2",             X11.royal_blue2)+  , ("royal_blue3",             X11.royal_blue3)+  , ("royal_blue4",             X11.royal_blue4)+  , ("salmon1",                 X11.salmon1)+  , ("salmon2",                 X11.salmon2)+  , ("salmon3",                 X11.salmon3)+  , ("salmon4",                 X11.salmon4)+  , ("sea_green1",              X11.sea_green1)+  , ("sea_green2",              X11.sea_green2)+  , ("sea_green3",              X11.sea_green3)+  , ("sea_green4",              X11.sea_green4)+  , ("seashell1",               X11.seashell1)+  , ("seashell2",               X11.seashell2)+  , ("seashell3",               X11.seashell3)+  , ("seashell4",               X11.seashell4)+  , ("sienna1",                 X11.sienna1)+  , ("sienna2",                 X11.sienna2)+  , ("sienna3",                 X11.sienna3)+  , ("sienna4",                 X11.sienna4)+  , ("sky_blue1",               X11.sky_blue1)+  , ("sky_blue2",               X11.sky_blue2)+  , ("sky_blue3",               X11.sky_blue3)+  , ("sky_blue4",               X11.sky_blue4)+  , ("slate_blue1",             X11.slate_blue1)+  , ("slate_blue2",             X11.slate_blue2)+  , ("slate_blue3",             X11.slate_blue3)+  , ("slate_blue4",             X11.slate_blue4)+  , ("slate_gray1",             X11.slate_gray1)+  , ("slate_gray2",             X11.slate_gray2)+  , ("slate_gray3",             X11.slate_gray3)+  , ("slate_gray4",             X11.slate_gray4)+  , ("snow1",                   X11.snow1)+  , ("snow2",                   X11.snow2)+  , ("snow3",                   X11.snow3)+  , ("snow4",                   X11.snow4)+  , ("spring_green1",           X11.spring_green1)+  , ("spring_green2",           X11.spring_green2)+  , ("spring_green3",           X11.spring_green3)+  , ("spring_green4",           X11.spring_green4)+  , ("steel_blue1",             X11.steel_blue1)+  , ("steel_blue2",             X11.steel_blue2)+  , ("steel_blue3",             X11.steel_blue3)+  , ("steel_blue4",             X11.steel_blue4)+  , ("tan1",                    X11.tan1)+  , ("tan2",                    X11.tan2)+  , ("tan3",                    X11.tan3)+  , ("tan4",                    X11.tan4)+  , ("thistle1",                X11.thistle1)+  , ("thistle2",                X11.thistle2)+  , ("thistle3",                X11.thistle3)+  , ("thistle4",                X11.thistle4)+  , ("tomato1",                 X11.tomato1)+  , ("tomato2",                 X11.tomato2)+  , ("tomato3",                 X11.tomato3)+  , ("tomato4",                 X11.tomato4)+  , ("turquoise1",              X11.turquoise1)+  , ("turquoise2",              X11.turquoise2)+  , ("turquoise3",              X11.turquoise3)+  , ("turquoise4",              X11.turquoise4)+  , ("violet_red1",             X11.violet_red1)+  , ("violet_red2",             X11.violet_red2)+  , ("violet_red3",             X11.violet_red3)+  , ("violet_red4",             X11.violet_red4)+  , ("wheat1",                  X11.wheat1)+  , ("wheat2",                  X11.wheat2)+  , ("wheat3",                  X11.wheat3)+  , ("wheat4",                  X11.wheat4)+  , ("yellow1",                 X11.yellow1)+  , ("yellow2",                 X11.yellow2)+  , ("yellow3",                 X11.yellow3)+  , ("yellow4",                 X11.yellow4)+  ]++++

@@ -2,7 +2,7 @@  module ColourCharts where -import ColourDefns+import ColourChartUtils  import Wumpus.Basic.Chains import Wumpus.Basic.Graphic@@ -16,33 +16,39 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    writeEPS_latin1 "./out/SVGcolours.eps" svg-    writeSVG_latin1 "./out/SVGcolours.svg" svg-    writeEPS_latin1 "./out/X11colours.eps" $ uniformScale 0.75 x11_portrait-    writeSVG_latin1 "./out/X11colours.svg" x11_landscape+    --+    let svg_pic = runDrawingU draw_ctx svg +    writeEPS "./out/SVGcolours.eps" svg_pic+    writeSVG "./out/SVGcolours.svg" svg_pic+    --+    let x11_p = runDrawingU draw_ctx x11_portrait+    writeEPS "./out/X11colours.eps" $ uniformScale 0.75 x11_p+    let x11_l = runDrawingU draw_ctx x11_landscape+    writeSVG "./out/X11colours.svg" x11_l -svg :: Picture Double-svg = makePicture 52 all_svg_colours+draw_ctx :: DrawingContext+draw_ctx = (standardContext 9) -x11_landscape :: Picture Double-x11_landscape = makePicture 52 all_x11_colours+svg :: Drawing Double+svg = makeDrawing 52 all_svg_colours -x11_portrait :: Picture Double-x11_portrait = makePicture 72 all_x11_colours     +x11_landscape :: Drawing Double+x11_landscape = makeDrawing 52 all_x11_colours -makePicture :: Int -> [(String,RGBi)] -> DPicture -makePicture row_count xs = -    liftToPictureU $ execDrawing (standardContext 9) $ -        tableGraphic row_count xs+x11_portrait :: Drawing Double+x11_portrait = makeDrawing 72 all_x11_colours      -tableGraphic :: Int -> [(String,RGBi)] -> Drawing Double ()+makeDrawing :: Int -> [(String,RGBi)] -> DDrawing+makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs++tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double () tableGraphic row_count xs =      zipWithM_ (\(name,rgb) pt -> colourSample name rgb pt) xs ps   where     ps = unchain (coordinateScalingContext 152 11) $ tableDown row_count 10   -colourSample :: String -> RGBi -> DPoint2 -> Drawing Double ()+colourSample :: String -> RGBi -> DPoint2 -> TraceDrawing Double () colourSample name rgb pt = localize (fillColour rgb) $ do      draw $ borderedRectangle 15 10 `at` pt     draw $ textline name `at` displace 20 2 pt 

@@ -1,502 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  ColourDefns--- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ All the SVG / X11 \"named colours\" listed in tables. --------------------------------------------------------------------------------------module ColourDefns-  ( -  -- * Tables of all colours-    all_x11_colours-  , all_svg_colours--  ) where--import qualified Wumpus.Basic.Colour.SVGColours    as SVG-import qualified Wumpus.Basic.Colour.X11Colours    as X11--import Wumpus.Core.Colour ( RGBi )---all_svg_colours :: [(String,RGBi)]-all_svg_colours = -  [ ("alice_blue",              SVG.alice_blue)-  , ("antique_white",           SVG.antique_white)-  , ("aqua",                    SVG.aqua)-  , ("aquamarine",              SVG.aquamarine)-  , ("azure",                   SVG.azure)-  , ("beige",                   SVG.beige)-  , ("bisque",                  SVG.bisque)-  , ("black",                   SVG.black)-  , ("blanched_almond",         SVG.blanched_almond)-  , ("blue",                    SVG.blue)-  , ("blue_violet",             SVG.blue_violet)-  , ("brown",                   SVG.brown)-  , ("burlywood",               SVG.burlywood)-  , ("cadet_blue",              SVG.cadet_blue)-  , ("chartreuse",              SVG.chartreuse)-  , ("chocolate",               SVG.chocolate)-  , ("coral",                   SVG.coral)-  , ("cornflower_blue",         SVG.cornflower_blue)-  , ("cornsilk",                SVG.cornsilk)-  , ("crimson",                 SVG.crimson)-  , ("cyan",                    SVG.cyan)-  , ("dark_blue",               SVG.dark_blue)-  , ("dark_cyan",               SVG.dark_cyan)-  , ("dark_goldenrod",          SVG.dark_goldenrod)-  , ("dark_gray",               SVG.dark_gray)-  , ("dark_green",              SVG.dark_green)-  , ("dark_grey",               SVG.dark_grey)-  , ("dark_khaki",              SVG.dark_khaki)-  , ("dark_magenta",            SVG.dark_magenta)-  , ("dark_olive_green",        SVG.dark_olive_green)-  , ("dark_orange",             SVG.dark_orange)-  , ("dark_orchid",             SVG.dark_orchid)-  , ("dark_red",                SVG.dark_red)-  , ("dark_salmon",             SVG.dark_salmon)-  , ("dark_sea_green",          SVG.dark_sea_green)-  , ("dark_slate_blue",         SVG.dark_slate_blue)-  , ("dark_slate_gray",         SVG.dark_slate_gray)-  , ("dark_slate_grey",         SVG.dark_slate_grey)-  , ("dark_turquoise",          SVG.dark_turquoise)-  , ("dark_violet",             SVG.dark_violet)-  , ("deep_pink",               SVG.deep_pink)-  , ("deep_sky_blue",           SVG.deep_sky_blue)-  , ("dim_gray",                SVG.dim_gray)-  , ("dim_grey",                SVG.dim_grey)-  , ("dodger_blue",             SVG.dodger_blue)-  , ("firebrick",               SVG.firebrick)-  , ("floral_white",            SVG.floral_white)-  , ("forest_green",            SVG.forest_green)-  , ("fuchsia",                 SVG.fuchsia)-  , ("gainsboro",               SVG.gainsboro)-  , ("ghost_white",             SVG.ghost_white)-  , ("gold",                    SVG.gold)-  , ("goldenrod",               SVG.goldenrod)-  , ("gray",                    SVG.gray)-  , ("grey",                    SVG.grey)-  , ("green",                   SVG.green)-  , ("green_yellow",            SVG.green_yellow)-  , ("honeydew",                SVG.honeydew)-  , ("hot_pink",                SVG.hot_pink)-  , ("indian_red",              SVG.indian_red)-  , ("indigo",                  SVG.indigo)-  , ("ivory",                   SVG.ivory)-  , ("khaki",                   SVG.khaki)-  , ("lavender",                SVG.lavender)-  , ("lavender_blush",          SVG.lavender_blush)-  , ("lawn_green",              SVG.lawn_green)-  , ("lemon_chiffon",           SVG.lemon_chiffon)-  , ("light_blue",              SVG.light_blue)-  , ("light_coral",             SVG.light_coral)-  , ("light_cyan",              SVG.light_cyan)-  , ("light_goldenrod_yellow",  SVG.light_goldenrod_yellow)-  , ("light_gray",              SVG.light_gray)-  , ("light_green",             SVG.light_green)-  , ("light_grey",              SVG.light_grey)-  , ("light_pink",              SVG.light_pink)-  , ("light_salmon",            SVG.light_salmon)-  , ("light_sea_green",         SVG.light_sea_green)-  , ("light_sky_blue",          SVG.light_sky_blue)-  , ("light_slate_gray",        SVG.light_slate_gray)-  , ("light_slate_grey",        SVG.light_slate_grey)-  , ("light_steel_blue",        SVG.light_steel_blue)-  , ("light_yellow",            SVG.light_yellow)-  , ("lime",                    SVG.lime)-  , ("lime_green",              SVG.lime_green)-  , ("linen",                   SVG.linen)-  , ("magenta",                 SVG.magenta)-  , ("maroon",                  SVG.maroon)-  , ("medium_aquamarine",       SVG.medium_aquamarine)-  , ("medium_blue",             SVG.medium_blue)-  , ("medium_orchid",           SVG.medium_orchid)-  , ("medium_purple",           SVG.medium_purple)-  , ("medium_sea_green",        SVG.medium_sea_green)-  , ("medium_slate_blue",       SVG.medium_slate_blue)-  , ("medium_spring_green",     SVG.medium_spring_green)-  , ("medium_turquoise",        SVG.medium_turquoise)-  , ("medium_violet_red",       SVG.medium_violet_red)-  , ("midnight_blue",           SVG.midnight_blue)-  , ("mintcream",               SVG.mintcream)-  , ("mistyrose",               SVG.mistyrose)-  , ("moccasin",                SVG.moccasin)-  , ("navajo_white",            SVG.navajo_white)-  , ("navy",                    SVG.navy)-  , ("old_lace",                SVG.old_lace)-  , ("olive",                   SVG.olive)-  , ("olive_drab",              SVG.olive_drab)-  , ("orange",                  SVG.orange)-  , ("orange_red",              SVG.orange_red)-  , ("orchid",                  SVG.orchid)-  , ("pale_goldenrod",          SVG.pale_goldenrod)-  , ("pale_green",              SVG.pale_green)-  , ("pale_turquoise",          SVG.pale_turquoise)-  , ("pale_violet_red",         SVG.pale_violet_red)-  , ("papaya_whip",             SVG.papaya_whip)-  , ("peach_puff",              SVG.peach_puff)-  , ("peru",                    SVG.peru)-  , ("pink",                    SVG.pink)-  , ("plum",                    SVG.plum)-  , ("powder_blue",             SVG.powder_blue)-  , ("purple",                  SVG.purple)-  , ("red",                     SVG.red)-  , ("rosy_brown",              SVG.rosy_brown)-  , ("royal_blue",              SVG.royal_blue)-  , ("saddle_brown",            SVG.saddle_brown)-  , ("salmon",                  SVG.salmon)-  , ("sandy_brown",             SVG.sandy_brown)-  , ("sea_green",               SVG.sea_green)-  , ("seashell",                SVG.seashell)-  , ("sienna",                  SVG.sienna)-  , ("silver",                  SVG.silver)-  , ("sky_blue",                SVG.sky_blue)-  , ("slate_blue",              SVG.slate_blue)-  , ("slate_gray",              SVG.slate_gray)-  , ("slate_grey",              SVG.slate_grey)-  , ("snow",                    SVG.snow)-  , ("spring_green",            SVG.spring_green)-  , ("steel_blue",              SVG.steel_blue)-  , ("tan",                     SVG.tan)-  , ("teal",                    SVG.teal)-  , ("thistle",                 SVG.thistle)-  , ("tomato",                  SVG.tomato)-  , ("turquoise",               SVG.turquoise)-  , ("violet",                  SVG.violet)-  , ("wheat",                   SVG.wheat)-  , ("white",                   SVG.white)-  , ("whitesmoke",              SVG.whitesmoke)-  , ("yellow",                  SVG.yellow)-  , ("yellow_green",            SVG.yellow_green)-  ]----all_x11_colours :: [(String,RGBi)]-all_x11_colours = -  [ ("antique_white1",          X11.antique_white1)-  , ("antique_white2",          X11.antique_white2)-  , ("antique_white3",          X11.antique_white3)-  , ("antique_white4",          X11.antique_white4)-  , ("aquamarine1",             X11.aquamarine1)-  , ("aquamarine2",             X11.aquamarine2)-  , ("aquamarine3",             X11.aquamarine3)-  , ("aquamarine4",             X11.aquamarine4)-  , ("azure1",                  X11.azure1)-  , ("azure2",                  X11.azure2)-  , ("azure3",                  X11.azure3)-  , ("azure4",                  X11.azure4)-  , ("bisque1",                 X11.bisque1)-  , ("bisque2",                 X11.bisque2)-  , ("bisque3",                 X11.bisque3)-  , ("bisque4",                 X11.bisque4)-  , ("blue1",                   X11.blue1)-  , ("blue2",                   X11.blue2)-  , ("blue3",                   X11.blue3)-  , ("blue4",                   X11.blue4)-  , ("brown1",                  X11.brown1)-  , ("brown2",                  X11.brown2)-  , ("brown3",                  X11.brown3)-  , ("brown4",                  X11.brown4)-  , ("burlywood1",              X11.burlywood1)-  , ("burlywood2",              X11.burlywood2)-  , ("burlywood3",              X11.burlywood3)-  , ("burlywood4",              X11.burlywood4)-  , ("cadet_blue1",             X11.cadet_blue1)-  , ("cadet_blue2",             X11.cadet_blue2)-  , ("cadet_blue3",             X11.cadet_blue3)-  , ("cadet_blue4",             X11.cadet_blue4)-  , ("chartreuse1",             X11.chartreuse1)-  , ("chartreuse2",             X11.chartreuse2)-  , ("chartreuse3",             X11.chartreuse3)-  , ("chartreuse4",             X11.chartreuse4)-  , ("chocolate1",              X11.chocolate1)-  , ("chocolate2",              X11.chocolate2)-  , ("chocolate3",              X11.chocolate3)-  , ("chocolate4",              X11.chocolate4)-  , ("coral1",                  X11.coral1)-  , ("coral2",                  X11.coral2)-  , ("coral3",                  X11.coral3)-  , ("coral4",                  X11.coral4)-  , ("cornsilk1",               X11.cornsilk1)-  , ("cornsilk2",               X11.cornsilk2)-  , ("cornsilk3",               X11.cornsilk3)-  , ("cornsilk4",               X11.cornsilk4)-  , ("cyan1",                   X11.cyan1)-  , ("cyan2",                   X11.cyan2)-  , ("cyan3",                   X11.cyan3)-  , ("cyan4",                   X11.cyan4)-  , ("dark_goldenrod1",         X11.dark_goldenrod1)-  , ("dark_goldenrod2",         X11.dark_goldenrod2)-  , ("dark_goldenrod3",         X11.dark_goldenrod3)-  , ("dark_goldenrod4",         X11.dark_goldenrod4)-  , ("dark_olive_green1",       X11.dark_olive_green1)-  , ("dark_olive_green2",       X11.dark_olive_green2)-  , ("dark_olive_green3",       X11.dark_olive_green3)-  , ("dark_olive_green4",       X11.dark_olive_green4)-  , ("dark_orange1",            X11.dark_orange1)-  , ("dark_orange2",            X11.dark_orange2)-  , ("dark_orange3",            X11.dark_orange3)-  , ("dark_orange4",            X11.dark_orange4)-  , ("dark_orchid1",            X11.dark_orchid1)-  , ("dark_orchid2",            X11.dark_orchid2)-  , ("dark_orchid3",            X11.dark_orchid3)-  , ("dark_orchid4",            X11.dark_orchid4)-  , ("dark_sea_green1",         X11.dark_sea_green1)-  , ("dark_sea_green2",         X11.dark_sea_green2)-  , ("dark_sea_green3",         X11.dark_sea_green3)-  , ("dark_sea_green4",         X11.dark_sea_green4)-  , ("dark_slate_gray1",        X11.dark_slate_gray1)-  , ("dark_slate_gray2",        X11.dark_slate_gray2)-  , ("dark_slate_gray3",        X11.dark_slate_gray3)-  , ("dark_slate_gray4",        X11.dark_slate_gray4)-  , ("deep_pink1",              X11.deep_pink1)-  , ("deep_pink2",              X11.deep_pink2)-  , ("deep_pink3",              X11.deep_pink3)-  , ("deep_pink4",              X11.deep_pink4)-  , ("deep_sky_blue1",          X11.deep_sky_blue1)-  , ("deep_sky_blue2",          X11.deep_sky_blue2)-  , ("deep_sky_blue3",          X11.deep_sky_blue3)-  , ("deep_sky_blue4",          X11.deep_sky_blue4)-  , ("dodger_blue1",            X11.dodger_blue1)-  , ("dodger_blue2",            X11.dodger_blue2)-  , ("dodger_blue3",            X11.dodger_blue3)-  , ("dodger_blue4",            X11.dodger_blue4)-  , ("firebrick1",              X11.firebrick1)-  , ("firebrick2",              X11.firebrick2)-  , ("firebrick3",              X11.firebrick3)-  , ("firebrick4",              X11.firebrick4)-  , ("gold1",                   X11.gold1)-  , ("gold2",                   X11.gold2)-  , ("gold3",                   X11.gold3)-  , ("gold4",                   X11.gold4)-  , ("goldenrod1",              X11.goldenrod1)-  , ("goldenrod2",              X11.goldenrod2)-  , ("goldenrod3",              X11.goldenrod3)-  , ("goldenrod4",              X11.goldenrod4)-  , ("green1",                  X11.green1)-  , ("green2",                  X11.green2)-  , ("green3",                  X11.green3)-  , ("green4",                  X11.green4)-  , ("honeydew1",               X11.honeydew1)-  , ("honeydew2",               X11.honeydew2)-  , ("honeydew3",               X11.honeydew3)-  , ("honeydew4",               X11.honeydew4)-  , ("hot_pink1",               X11.hot_pink1)-  , ("hot_pink2",               X11.hot_pink2)-  , ("hot_pink3",               X11.hot_pink3)-  , ("hot_pink4",               X11.hot_pink4)-  , ("indian_red1",             X11.indian_red1)-  , ("indian_red2",             X11.indian_red2)-  , ("indian_red3",             X11.indian_red3)-  , ("indian_red4",             X11.indian_red4)-  , ("ivory1",                  X11.ivory1)-  , ("ivory2",                  X11.ivory2)-  , ("ivory3",                  X11.ivory3)-  , ("ivory4",                  X11.ivory4)-  , ("khaki1",                  X11.khaki1)-  , ("khaki2",                  X11.khaki2)-  , ("khaki3",                  X11.khaki3)-  , ("khaki4",                  X11.khaki4)-  , ("lavender_blush1",         X11.lavender_blush1)-  , ("lavender_blush2",         X11.lavender_blush2)-  , ("lavender_blush3",         X11.lavender_blush3)-  , ("lavender_blush4",         X11.lavender_blush4)-  , ("lemon_chiffon1",          X11.lemon_chiffon1)-  , ("lemon_chiffon2",          X11.lemon_chiffon2)-  , ("lemon_chiffon3",          X11.lemon_chiffon3)-  , ("lemon_chiffon4",          X11.lemon_chiffon4)-  , ("light_blue1",             X11.light_blue1)-  , ("light_blue2",             X11.light_blue2)-  , ("light_blue3",             X11.light_blue3)-  , ("light_blue4",             X11.light_blue4)-  , ("light_cyan1",             X11.light_cyan1)-  , ("light_cyan2",             X11.light_cyan2)-  , ("light_cyan3",             X11.light_cyan3)-  , ("light_cyan4",             X11.light_cyan4)-  , ("light_goldenrod1",        X11.light_goldenrod1)-  , ("light_goldenrod2",        X11.light_goldenrod2)-  , ("light_goldenrod3",        X11.light_goldenrod3)-  , ("light_goldenrod4",        X11.light_goldenrod4)-  , ("light_pink1",             X11.light_pink1)-  , ("light_pink2",             X11.light_pink2)-  , ("light_pink3",             X11.light_pink3)-  , ("light_pink4",             X11.light_pink4)-  , ("light_salmon1",           X11.light_salmon1)-  , ("light_salmon2",           X11.light_salmon2)-  , ("light_salmon3",           X11.light_salmon3)-  , ("light_salmon4",           X11.light_salmon4)-  , ("light_sky_blue1",         X11.light_sky_blue1)-  , ("light_sky_blue2",         X11.light_sky_blue2)-  , ("light_sky_blue3",         X11.light_sky_blue3)-  , ("light_sky_blue4",         X11.light_sky_blue4)-  , ("light_steel_blue1",       X11.light_steel_blue1)-  , ("light_steel_blue2",       X11.light_steel_blue2)-  , ("light_steel_blue3",       X11.light_steel_blue3)-  , ("light_steel_blue4",       X11.light_steel_blue4)-  , ("light_yellow1",           X11.light_yellow1)-  , ("light_yellow2",           X11.light_yellow2)-  , ("light_yellow3",           X11.light_yellow3)-  , ("light_yellow4",           X11.light_yellow4)-  , ("magenta1",                X11.magenta1)-  , ("magenta2",                X11.magenta2)-  , ("magenta3",                X11.magenta3)-  , ("magenta4",                X11.magenta4)-  , ("maroon1",                 X11.maroon1)-  , ("maroon2",                 X11.maroon2)-  , ("maroon3",                 X11.maroon3)-  , ("maroon4",                 X11.maroon4)-  , ("medium_orchid1",          X11.medium_orchid1)-  , ("medium_orchid2",          X11.medium_orchid2)-  , ("medium_orchid3",          X11.medium_orchid3)-  , ("medium_orchid4",          X11.medium_orchid4)-  , ("medium_purple1",          X11.medium_purple1)-  , ("medium_purple2",          X11.medium_purple2)-  , ("medium_purple3",          X11.medium_purple3)-  , ("medium_purple4",          X11.medium_purple4)-  , ("misty_rose1",             X11.misty_rose1)-  , ("misty_rose2",             X11.misty_rose2)-  , ("misty_rose3",             X11.misty_rose3)-  , ("misty_rose4",             X11.misty_rose4)-  , ("navajo_white1",           X11.navajo_white1)-  , ("navajo_white2",           X11.navajo_white2)-  , ("navajo_white3",           X11.navajo_white3)-  , ("navajo_white4",           X11.navajo_white4)-  , ("olive_drab1",             X11.olive_drab1)-  , ("olive_drab2",             X11.olive_drab2)-  , ("olive_drab3",             X11.olive_drab3)-  , ("olive_drab4",             X11.olive_drab4)-  , ("orange1",                 X11.orange1)-  , ("orange2",                 X11.orange2)-  , ("orange3",                 X11.orange3)-  , ("orange4",                 X11.orange4)-  , ("orange_red1",             X11.orange_red1)-  , ("orange_red2",             X11.orange_red2)-  , ("orange_red3",             X11.orange_red3)-  , ("orange_red4",             X11.orange_red4)-  , ("orchid1",                 X11.orchid1)-  , ("orchid2",                 X11.orchid2)-  , ("orchid3",                 X11.orchid3)-  , ("orchid4",                 X11.orchid4)-  , ("pale_green1",             X11.pale_green1)-  , ("pale_green2",             X11.pale_green2)-  , ("pale_green3",             X11.pale_green3)-  , ("pale_green4",             X11.pale_green4)-  , ("pale_turquoise1",         X11.pale_turquoise1)-  , ("pale_turquoise2",         X11.pale_turquoise2)-  , ("pale_turquoise3",         X11.pale_turquoise3)-  , ("pale_turquoise4",         X11.pale_turquoise4)-  , ("pale_violet_red1",        X11.pale_violet_red1)-  , ("pale_violet_red2",        X11.pale_violet_red2)-  , ("pale_violet_red3",        X11.pale_violet_red3)-  , ("pale_Violet_red4",        X11.pale_violet_red4)-  , ("peach_puff1",             X11.peach_puff1)-  , ("peach_puff2",             X11.peach_puff2)-  , ("peach_puff3",             X11.peach_puff3)-  , ("peach_puff4",             X11.peach_puff4)-  , ("pink1",                   X11.pink1)-  , ("pink2",                   X11.pink2)-  , ("pink3",                   X11.pink3)-  , ("pink4",                   X11.pink4)-  , ("plum1",                   X11.plum1)-  , ("plum2",                   X11.plum2)-  , ("plum3",                   X11.plum3)-  , ("plum4",                   X11.plum4)-  , ("purple1",                 X11.purple1)-  , ("purple2",                 X11.purple2)-  , ("purple3",                 X11.purple3)-  , ("purple4",                 X11.purple4)-  , ("red1",                    X11.red1)-  , ("red2",                    X11.red2)-  , ("red3",                    X11.red3)-  , ("red4",                    X11.red4)-  , ("rosy_brown1",             X11.rosy_brown1)-  , ("rosy_brown2",             X11.rosy_brown2)-  , ("rosy_brown3",             X11.rosy_brown3)-  , ("rosy_brown4",             X11.rosy_brown4)-  , ("royal_blue1",             X11.royal_blue1)-  , ("royal_blue2",             X11.royal_blue2)-  , ("royal_blue3",             X11.royal_blue3)-  , ("royal_blue4",             X11.royal_blue4)-  , ("salmon1",                 X11.salmon1)-  , ("salmon2",                 X11.salmon2)-  , ("salmon3",                 X11.salmon3)-  , ("salmon4",                 X11.salmon4)-  , ("sea_green1",              X11.sea_green1)-  , ("sea_green2",              X11.sea_green2)-  , ("sea_green3",              X11.sea_green3)-  , ("sea_green4",              X11.sea_green4)-  , ("seashell1",               X11.seashell1)-  , ("seashell2",               X11.seashell2)-  , ("seashell3",               X11.seashell3)-  , ("seashell4",               X11.seashell4)-  , ("sienna1",                 X11.sienna1)-  , ("sienna2",                 X11.sienna2)-  , ("sienna3",                 X11.sienna3)-  , ("sienna4",                 X11.sienna4)-  , ("sky_blue1",               X11.sky_blue1)-  , ("sky_blue2",               X11.sky_blue2)-  , ("sky_blue3",               X11.sky_blue3)-  , ("sky_blue4",               X11.sky_blue4)-  , ("slate_blue1",             X11.slate_blue1)-  , ("slate_blue2",             X11.slate_blue2)-  , ("slate_blue3",             X11.slate_blue3)-  , ("slate_blue4",             X11.slate_blue4)-  , ("slate_gray1",             X11.slate_gray1)-  , ("slate_gray2",             X11.slate_gray2)-  , ("slate_gray3",             X11.slate_gray3)-  , ("slate_gray4",             X11.slate_gray4)-  , ("snow1",                   X11.snow1)-  , ("snow2",                   X11.snow2)-  , ("snow3",                   X11.snow3)-  , ("snow4",                   X11.snow4)-  , ("spring_green1",           X11.spring_green1)-  , ("spring_green2",           X11.spring_green2)-  , ("spring_green3",           X11.spring_green3)-  , ("spring_green4",           X11.spring_green4)-  , ("steel_blue1",             X11.steel_blue1)-  , ("steel_blue2",             X11.steel_blue2)-  , ("steel_blue3",             X11.steel_blue3)-  , ("steel_blue4",             X11.steel_blue4)-  , ("tan1",                    X11.tan1)-  , ("tan2",                    X11.tan2)-  , ("tan3",                    X11.tan3)-  , ("tan4",                    X11.tan4)-  , ("thistle1",                X11.thistle1)-  , ("thistle2",                X11.thistle2)-  , ("thistle3",                X11.thistle3)-  , ("thistle4",                X11.thistle4)-  , ("tomato1",                 X11.tomato1)-  , ("tomato2",                 X11.tomato2)-  , ("tomato3",                 X11.tomato3)-  , ("tomato4",                 X11.tomato4)-  , ("turquoise1",              X11.turquoise1)-  , ("turquoise2",              X11.turquoise2)-  , ("turquoise3",              X11.turquoise3)-  , ("turquoise4",              X11.turquoise4)-  , ("violet_red1",             X11.violet_red1)-  , ("violet_red2",             X11.violet_red2)-  , ("violet_red3",             X11.violet_red3)-  , ("violet_red4",             X11.violet_red4)-  , ("wheat1",                  X11.wheat1)-  , ("wheat2",                  X11.wheat2)-  , ("wheat3",                  X11.wheat3)-  , ("wheat4",                  X11.wheat4)-  , ("yellow1",                 X11.yellow1)-  , ("yellow2",                 X11.yellow2)-  , ("yellow3",                 X11.yellow3)-  , ("yellow4",                 X11.yellow4)-  ]----

@@ -19,19 +19,14 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    demo01+    let pic1 = runDrawingU std_ctx conn_drawing+    writeEPS "./out/connectors01.eps" pic1+    writeSVG "./out/connectors01.svg" pic1 -pt2 :: Point2 Double-pt2 = P2 100 10  -demo01 :: IO ()-demo01 = do -    writeEPS_latin1 "./out/connectors01.eps" pic1-    writeSVG_latin1 "./out/connectors01.svg" pic1--pic1 :: Picture Double-pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ conntable+conn_drawing :: Drawing Double+conn_drawing = drawTracing $ tableGraphic $ conntable  conntable :: [ConnectorPath Double] conntable = @@ -57,7 +52,7 @@     ]  tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [ConnectorPath u] -> Drawing u ()+             => [ConnectorPath u] -> TraceDrawing u () tableGraphic conns = zipWithM_ makeConnDrawing conns ps   where     ps = unchain (coordinateScalingContext 120 52) $ tableDown 10 6@@ -70,9 +65,9 @@   makeConnDrawing :: (Real u, Floating u, FromPtSize u) -                 => ConnectorPath u -> Point2 u -> Drawing u ()+                 => ConnectorPath u -> Point2 u -> TraceDrawing u () makeConnDrawing conn p0 = -    drawi_ $ strokeConnector (dblArrow conn curveTip) p0 p1+    drawi_ $ situ2 (strokeConnector (dblArrow conn curveTip)) p0 p1   where     p1 = p0 .+^ vec 100 40   

@@ -6,8 +6,13 @@ import Wumpus.Basic.Chains import Wumpus.Basic.Colour.SVGColours import Wumpus.Basic.Dots.AnchorDots+import Wumpus.Basic.FontLoader.AfmLoader+import Wumpus.Basic.FontLoader.GSLoader import Wumpus.Basic.Graphic+import Wumpus.Basic.SafeFonts +import FontLoaderUtils+ import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space@@ -15,22 +20,44 @@ import Control.Monad import System.Directory ++ main :: IO () main = do +    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help     createDirectoryIfMissing True "./out/"-    demo01+    maybe gs_failk  makeGSPicture  $ mb_gs+    maybe afm_failk makeAfmPicture $ mb_afm+  where+    gs_failk  = putStrLn "No GhostScript font path supplied..."+    afm_failk = putStrLn "No AFM v4.1 font path supplied..." -pt2 :: Point2 Double-pt2 = P2 100 10 +makeGSPicture :: FilePath -> IO ()+makeGSPicture font_dir = do +    putStrLn "Using GhostScript metrics..."+    base_metrics <- loadGSMetrics font_dir ["Helvetica"]+    let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing +    writeEPS "./out/dots01.eps" pic1+    writeSVG "./out/dots01.svg" pic1 -demo01 :: IO ()-demo01 = do -    writeEPS_latin1 "./out/dots01.eps" pic1-    writeSVG_latin1 "./out/dots01.svg" pic1+  -pic1 :: Picture Double-pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ +makeAfmPicture :: FilePath -> IO ()+makeAfmPicture font_dir = do +    putStrLn "Using AFM 4.1 metrics..."+    base_metrics <- loadAfmMetrics font_dir ["Helvetica"]+    let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing +    writeEPS "./out/dots02.eps" pic1+    writeSVG "./out/dots02.svg" pic1++ +makeCtx :: BaseGlyphMetrics -> DrawingContext+makeCtx = fillColour peru . fontface helvetica . metricsContext 24+++dot_drawing :: Drawing Double+dot_drawing = drawTracing $ tableGraphic $      [ dotHLine     , dotVLine     , dotX@@ -52,20 +79,15 @@   tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [DotLocImage u] -> Drawing u ()+             => [DotLocImage u] -> TraceDrawing u () tableGraphic imgs = zipWithM_ makeDotDrawing imgs ps   where     ps = unchain (coordinateScalingContext 1 36) $ tableDown (length imgs) 1  - -std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 24 -- makeDotDrawing :: (Real u, Floating u, FromPtSize u) -              => DotLocImage u -> Point2 u -> Drawing u ()+               => DotLocImage u -> Point2 u -> TraceDrawing u () makeDotDrawing dotF pt = do      dashline     mapM_ (\v -> drawi $ dotF `at` pt .+^ v) displacements

@@ -0,0 +1,152 @@+{-# OPTIONS -Wall #-}++module DrawingCompo where++import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.DrawingComposition+import Wumpus.Basic.Graphic++import Wumpus.Core                              -- package: wumpus-core++import System.Directory+++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    let out1 = runDrawingU pic_drawing_ctx pictures+    writeEPS "./out/drawing_composition.eps" out1+    writeSVG "./out/drawing_composition.svg" out1+++pic_drawing_ctx :: DrawingContext+pic_drawing_ctx = standardContext 14+++pictures :: DDrawing+pictures = vsep 12 [ pic1,  pic2,  pic3,  pic4+                   , pic5,  pic6,  pic7,  pic8+                   , pic9,  pic10, pic11, pic12 ]+++drawBlueBounds :: (Real u, Floating u, FromPtSize u) +               => Drawing u -> Drawing u+drawBlueBounds = modifyDrawing (illustrateBounds blue)++pic1 :: DDrawing+pic1 = picAnno pic "red `over` green `over` blue"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ rect_red `over` rect_green `over` rect_blue++pic2 :: DDrawing+pic2 = picAnno pic "red `under` green `under` blue"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ rect_red `under` rect_green `under` rect_blue+++pic3 :: DDrawing +pic3 = picAnno pic "red `centric` green `centric` blue"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            rect_red `centric` rect_green `centric` rect_blue++-- Note - nextToH only moves pictures in the horizontal.+--+pic4 :: DDrawing +pic4 = picAnno pic "red `nextToH` green `nextToH` blue"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            rect_red `nextToH` rect_green `nextToH` rect_blue++-- Note - nextToV only moves pictures in the vertical.+--+pic5 :: DDrawing +pic5 = picAnno pic "red `nextToV` green `nextToV` blue"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            rect_red `nextToV` rect_green `nextToV` rect_blue+++pic6 :: DDrawing+pic6 = picAnno pic "zconcat [red, green, blue]"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            zconcat [rect_red, rect_green, rect_blue]+++pic7 :: DDrawing+pic7 = picAnno pic "hcat [red, green, blue]"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            hcat [rect_red, rect_green, rect_blue]++pic8 :: DDrawing+pic8 = picAnno pic "vcat [red, green, blue]"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            vcat [rect_red, rect_green, rect_blue]++pic9 :: DDrawing+pic9 = picAnno pic "hsep 20 [red, green, blue]"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            hsep 20 [rect_red, rect_green, rect_blue]++pic10 :: DDrawing+pic10 = picAnno pic "vsep 20 [red, green, blue]"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            vsep 20 [rect_red, rect_green, rect_blue]+++pic11 :: DDrawing+pic11 = picAnno pic "hcatA HTop [red, green, blue]"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            hcatA HTop [rect_red, rect_green, rect_blue]+++pic12 :: DDrawing+pic12 = picAnno pic "vcatA VCenter [red, green, blue]"+  where+    pic :: DDrawing+    pic = drawBlueBounds $ +            vcatA VCenter [rect_red, rect_green, rect_blue]+++--------------------------------------------------------------------------------+++picAnno :: DDrawing -> String -> DDrawing+picAnno pic msg = alignHSep HCenter 30 pic lbl+  where+    lbl = drawTracing $ draw $ textline msg `at` zeroPt+++rect_red :: DDrawing+rect_red = drawTracing $ +    localize (fillColour indian_red)+             (draw $ borderedRectangle 30 10 `at` (P2 0 10))+                 +rect_green :: DDrawing+rect_green = drawTracing $ +    localize (fillColour olive_drab)+             (draw $ borderedRectangle 15 15 `at` (P2 10 10))+++rect_blue :: DDrawing+rect_blue = drawTracing $ +    localize (fillColour powder_blue)+             (draw $ borderedRectangle 20 30 `at` (P2 10 0))+

@@ -0,0 +1,130 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++++module FeatureModel where++import Wumpus.Basic.Arrows+import Wumpus.Basic.FontLoader.AfmLoader+import Wumpus.Basic.FontLoader.GSLoader+import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths +import Wumpus.Basic.SafeFonts+import Wumpus.Basic.Shapes+import Wumpus.Basic.Text.LRText++import Wumpus.Core                      -- package: wumpus-core++import FontLoaderUtils+++import System.Directory+++main :: IO ()+main = do +    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help+    createDirectoryIfMissing True "./out/"+    maybe gs_failk  makeGSPicture  $ mb_gs+    maybe afm_failk makeAfmPicture $ mb_afm+  where+    gs_failk  = putStrLn "No GhostScript font path supplied..."+    afm_failk = putStrLn "No AFM v4.1 font path supplied..."++makeGSPicture :: FilePath -> IO ()+makeGSPicture font_dir = do +    putStrLn "Using GhostScript metrics..."+    base_metrics <- loadGSMetrics font_dir ["Courier-Bold"]+    let pic1 = runDrawingU (makeCtx base_metrics) feature_model +    writeEPS "./out/feature_model01.eps" pic1+    writeSVG "./out/feature_model01.svg" pic1 ++makeAfmPicture :: FilePath -> IO ()+makeAfmPicture font_dir = do +    putStrLn "Using AFM 4.1 metrics..."+    base_metrics <- loadAfmMetrics font_dir ["Courier-Bold"]+    let pic1 = runDrawingU (makeCtx base_metrics) feature_model +    writeEPS "./out/feature_model02.eps" pic1+    writeSVG "./out/feature_model02.svg" pic1 ++makeCtx :: BaseGlyphMetrics -> DrawingContext+makeCtx = fontface courier_bold . metricsContext 18+++-- Note - I haven't worked out how to do @alternative@, @or@ and+-- @repetitions@ yet.+--+         +feature_model :: Drawing Double +feature_model = drawTracing $ do+    lea <- widebox "e" $ P2 150 160    +    lra <- widebox "r" $ P2  60  80+    lsa <- widebox "s" $ P2 240  80+    cmandatory_ lea lra+    cmandatory_ lea lsa++    uGa <- box "G" $ P2   0 0+    uHa <- box "H" $ P2  60 0+    uIa <- box "I" $ P2 120 0++    uAa <- box "A" $ P2 180 0+    uBa <- box "B" $ P2 240 0+    uCa <- box "C" $ P2 300 0++    cmandatory_ lra uGa+    cmandatory_ lra uHa+    cmandatory_ lra uIa++    cmandatory_ lsa uAa+    coptional_  lsa uBa+    cmandatory_ lsa uCa++    return ()+++type Box u = Rectangle u+++makeBox :: (Real u, Floating u, FromPtSize u) +        => u -> String -> Point2 u -> TraceDrawing u (Box u)+makeBox w ss pt = do +    a <- drawi $ strokedShape $ rectangle w 20 $ pt+    drawi_ $ singleLineCC ss `at` center a+    return a++box :: (Real u, Floating u, FromPtSize u) +    => String -> Point2 u -> TraceDrawing u (Box u)+box = makeBox 40++widebox :: (Real u, Floating u, FromPtSize u) +        => String -> Point2 u -> TraceDrawing u (Box u)+widebox = makeBox 60+++connWith :: ( Real u, Floating u, FromPtSize u ) +         => Arrowhead u -> Box u -> Box u -> TraceDrawing u (Path u)+connWith arrh b0 b1 = do+   lw <- lineWidth+   let p0 = south b0+   let p1 = northwards (realToFrac lw) b1+   drawi $ situ2 (strokeConnector (rightArrow connLine arrh)) p0 p1++infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_`++cmandatory :: ( Real u, Floating u, FromPtSize u ) +           => Box u -> Box u -> TraceDrawing u (Path u)+cmandatory = connWith diskTip++coptional :: ( Real u, Floating u, FromPtSize u ) +          => Box u -> Box u -> TraceDrawing u (Path u)+coptional = connWith odiskTip+++cmandatory_ :: ( Real u, Floating u, FromPtSize u ) +            => Box u -> Box u -> TraceDrawing u ()+cmandatory_ p0 p1 = connWith diskTip p0 p1 >> return ()++coptional_ :: ( Real u, Floating u, FromPtSize u ) +           => Box u -> Box u -> TraceDrawing u ()+coptional_ p0 p1 = connWith odiskTip p0 p1 >> return ()

@@ -0,0 +1,95 @@+{-# OPTIONS -Wall #-}+++module FontLoaderUtils+  (+    processCmdLine+  , default_font_loader_help+  ) where+++import Control.Applicative+import Control.Monad+import System.Directory+import System.Console.GetOpt+import System.Environment+import System.IO.Error+++wumpus_gs_font_dir :: String+wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR"++wumpus_afm_font_dir :: String+wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR"+++default_font_loader_help :: String+default_font_loader_help = unlines $ +    [ "This example uses glyph metrics loaded at runtime."+    , "It can use either the metrics files supplied with GhostScript,"+    , "or the AFM v4.1 metrics for the Core 14 fonts available from"+    , "Adobe's website."+    , "" +    , "To use GhostScripts font metrics set the environemt variable"+    , wumpus_gs_font_dir ++ " to point to the GhostScript fonts"+    , "directory (e.g. /usr/share/ghostscript/fonts) or use the command"+    , "line flag --gs=PATH_TO_GHOSTSCRIPT_FONTS"+    , ""+    , "To use the Adode Core 14 font metrics download the archive from"+    , "the Adobe website and set the environment variable "+    , wumpus_afm_font_dir ++ " to point to it, or use the command line"+    , "flag -- afm=PATH_TO_AFM_CORE14_FONTS"+    ]+++data CmdLineFlag = Help+                 | GS_FontDir  String+                 | AFM_FontDir String+  deriving (Eq,Ord,Show)++processCmdLine :: String -> IO (Maybe FilePath, Maybe FilePath)+processCmdLine help_message = +    let options = makeCmdLineOptions help_message in do+        args <- getArgs+        let (opts, _, _) = getOpt Permute options args+        if Help `elem` opts then failk help_message+                            else succk opts+  where+    failk msg   = putStr msg >> return (Nothing,Nothing) +    succk flags = (,) <$> gsFontDirectory flags <*> afmFontDirectory flags +       ++makeCmdLineOptions :: String -> [OptDescr CmdLineFlag]+makeCmdLineOptions help_message =+    [ Option ['h'] ["help"]   (NoArg Help)                help_message+    , Option []    ["afm"]    (ReqArg AFM_FontDir "DIR")  "AFM v4.1 metrics dir"+    , Option []    ["gs"]     (ReqArg GS_FontDir  "DIR")  "GhoshScript font dir"+    ]+++gsFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath)+gsFontDirectory = step +  where+    step (GS_FontDir p:xs)  = doesDirectoryExist p >>= \check -> +                              if check then return (Just p) else step xs++    step (_:xs)             = step xs+    step []                 = envLookup wumpus_gs_font_dir+ ++afmFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath)+afmFontDirectory = step +  where+    step (AFM_FontDir p:xs) = doesDirectoryExist p >>= \check -> +                              if check then return (Just p) else step xs++    step (_:xs)             = step xs+    step []                 = envLookup wumpus_afm_font_dir+++envLookup :: String -> IO (Maybe String)+envLookup name = liftM fn $ try $ getEnv name+  where+    fn (Left _)  = Nothing+    fn (Right a) = Just a+

@@ -17,24 +17,32 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    writeEPS_latin1 "./out/font_courier.eps"   courier_pic-    writeSVG_latin1 "./out/font_courier.svg"   courier_pic-    writeEPS_latin1 "./out/font_times.eps"     times_pic-    writeSVG_latin1 "./out/font_times.svg"     times_pic-    writeEPS_latin1 "./out/font_helvetica.eps" helvetica_pic-    writeSVG_latin1 "./out/font_helvetica.svg" helvetica_pic-    writeEPS_latin1 "./out/font_symbol.eps"    symbol_pic-    writeSVG_latin1 "./out/font_symbol.svg"    symbol_pic+    --+    let courier_pic = runDrawingU std_ctx courier_drawing+    writeEPS "./out/font_courier.eps"   courier_pic+    writeSVG "./out/font_courier.svg"   courier_pic+    --+    let times_pic = runDrawingU std_ctx times_drawing+    writeEPS "./out/font_times.eps"     times_pic+    writeSVG "./out/font_times.svg"     times_pic+    --+    let helvetica_pic = runDrawingU std_ctx helvetica_drawing+    writeEPS "./out/font_helvetica.eps" helvetica_pic+    writeSVG "./out/font_helvetica.svg" helvetica_pic+    --+    let symbol_pic = runDrawingU std_ctx symbol_drawing+    writeEPS "./out/font_symbol.eps"    symbol_pic+    writeSVG "./out/font_symbol.svg"    symbol_pic   fontMsg :: FontFace -> Int -> String fontMsg ff sz = msgF []   where-    msgF = showString (font_name ff) . showChar ' ' . shows sz . showString "pt"+    msgF = showString (ps_font_name ff) . showChar ' ' . shows sz . showString "pt"   makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic-makeLabel rgb ff sz = localize upd . (textline $ fontMsg ff sz)+makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz)   where     upd = fillColour rgb . fontsize sz . fontface ff @@ -51,7 +59,7 @@ pointChain :: LocChain Int Int Double pointChain = verticals positions -fontGraphic :: RGBi -> FontFace -> DPoint2 -> Drawing Double ()+fontGraphic :: RGBi -> FontFace -> DPoint2 -> TraceDrawing Double () fontGraphic rgb ff pt =      let ps = unchain (coordinateScalingContext 1 1) $ pointChain pt in        zipWithM_ (\p1 sz -> draw $ makeLabel rgb ff sz `at` p1) ps point_sizes@@ -61,9 +69,9 @@ std_ctx = standardContext 10  -fontPicture :: [(RGBi,FontFace)] -> DPicture-fontPicture xs = liftToPictureU $ execDrawing std_ctx $  -                   zipWithM (\(rgb,ff) pt -> fontGraphic rgb ff pt) xs ps+fontDrawing :: [(RGBi,FontFace)] -> DDrawing+fontDrawing xs = drawTracing $  +    zipWithM (\(rgb,ff) pt -> fontGraphic rgb ff pt) xs ps   where     ps = unchain (coordinateScalingContext 1 180) $ tableDown 4 1 @@ -72,17 +80,17 @@ -------------------------------------------------------------------------------- -- Times -times_pic :: Picture Double-times_pic = -    fontPicture [ (steel_blue,  times_roman)+times_drawing :: Drawing Double+times_drawing = +    fontDrawing [ (steel_blue,  times_roman)                 , (indian_red1, times_italic)                 , (steel_blue,  times_bold)                 , (indian_red1, times_bold_italic)                 ]  -helvetica_pic :: Picture Double-helvetica_pic = -    fontPicture [ (steel_blue,  helvetica)+helvetica_drawing :: Drawing Double+helvetica_drawing = +    fontDrawing [ (steel_blue,  helvetica)                 , (indian_red1, helvetica_oblique)                 , (steel_blue,  helvetica_bold)                 , (indian_red1, helvetica_bold_oblique)@@ -92,9 +100,9 @@  -------------------------------------------------------------------------------- -courier_pic :: Picture Double-courier_pic = -    fontPicture [ (steel_blue,  courier)+courier_drawing :: Drawing Double+courier_drawing = +    fontDrawing [ (steel_blue,  courier)                 , (indian_red1, courier_oblique)                 , (steel_blue,  courier_bold)                 , (indian_red1, courier_bold_oblique)@@ -104,6 +112,6 @@ --------------------------------------------------------------------------------      -symbol_pic :: Picture Double-symbol_pic = -    fontPicture [ (steel_blue, symbol) ]+symbol_drawing :: Drawing Double+symbol_drawing = +    fontDrawing [ (steel_blue, symbol) ]

@@ -0,0 +1,124 @@+{-# OPTIONS -Wall #-}++-- Note - @main@ is more convoluted than would normally be +-- expected as it supports both sources of glyph metrics - the +-- GhostScript distribution or the Core 14 metrics from Adobe.+-- +-- \"Real\" applications would be expected to choose one source. +--+-- I-am-not-a-lawyer, but it does look as though the Adobe font+-- metrics are redistributable, the GhostScript metrics are +-- seemingly redistributable under the same terms as the larger+-- GhostScript distribution.+-- +++module LeftRightText where+++import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.Dots.Marks+import Wumpus.Basic.FontLoader.GSLoader+import Wumpus.Basic.FontLoader.AfmLoader+import Wumpus.Basic.Graphic+import Wumpus.Basic.SafeFonts+import Wumpus.Basic.Text.LRText++import FontLoaderUtils+++import Wumpus.Core                      -- package: wumpus-core++import System.Directory++++main :: IO ()+main = do +    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help+    createDirectoryIfMissing True "./out/"+    maybe gs_failk  makeGSPicture  $ mb_gs+    maybe afm_failk makeAfmPicture $ mb_afm+  where+    gs_failk  = putStrLn "No GhostScript font path supplied..."+    afm_failk = putStrLn "No AFM v4.1 font path supplied..."+++makeGSPicture :: FilePath -> IO ()+makeGSPicture font_dir = do+    putStrLn "Using GhostScript metrics..."+    gs_metrics <- loadGSMetrics font_dir ["Helvetica"]+    let pic1 = runDrawingU (makeCtx gs_metrics) text_drawing +    writeEPS "./out/new_text01.eps" pic1+    writeSVG "./out/new_text01.svg" pic1++makeAfmPicture :: FilePath -> IO ()+makeAfmPicture font_dir = do+    putStrLn "Using AFM 4.1 metrics..."+    afm_metrics <- loadAfmMetrics font_dir ["Helvetica"]+    let pic2 = runDrawingU (makeCtx afm_metrics) text_drawing +    writeEPS "./out/new_text02.eps" pic2+    writeSVG "./out/new_text02.svg" pic2+++++makeCtx :: BaseGlyphMetrics -> DrawingContext+makeCtx = fontface helvetica . metricsContext 18+++text_drawing :: Drawing Double+text_drawing = drawTracing $ do +    drawi_ $ (fn left_text)   `at` P2   0 100+    drawi_ $ (fn center_text) `at` P2 200 100+    drawi_ $ (fn right_text)  `at` P2 400 100+    drawi_ $ (fn blank_text)  `at` P2   0   0+    drawi_ $ (fn bl_oneline)  `at` P2 200   0+    drawi_ $ (fn cc_oneline)  `at` P2 400   0+    +    draw $ redPlus            `at` P2   0 100+    draw $ redPlus            `at` P2 200 100+    draw $ redPlus            `at` P2 400 100+    draw $ redPlus            `at` P2   0   0  +    draw $ redPlus            `at` P2 200   0 +    draw $ redPlus            `at` P2 400   0 +       +  where+    fn = illustrateBoundedLocGraphic++redPlus :: (Fractional u, FromPtSize u) => LocGraphic u+redPlus = localize (strokeColour red) markPlus++bl_oneline :: BoundedLocGraphic Double+bl_oneline = +    localize (strokeColour dark_slate_gray) $ singleLineBL "Baseline-left..."+++cc_oneline :: BoundedLocGraphic Double+cc_oneline = +    localize (strokeColour dark_slate_gray) $ singleLineCC "Center-center..."++blank_text :: BoundedLocGraphic Double+blank_text = +    localize (strokeColour dark_slate_gray) $ multiAlignCenter ""+++left_text :: BoundedLocGraphic Double+left_text = +    localize (strokeColour dark_slate_gray) $ multiAlignLeft dummy_text+++right_text :: BoundedLocGraphic Double+right_text = +    localize (strokeColour dark_slate_gray) $ multiAlignRight dummy_text++center_text :: BoundedLocGraphic Double+center_text = +    localize (strokeColour dark_slate_gray) $ multiAlignCenter dummy_text+++dummy_text :: String +dummy_text = unlines $ [ "The quick brown"+                       , "fox jumps over"+                       , "the lazy dog."+                       ]

@@ -7,7 +7,6 @@  module PetriNet where -import Wumpus.Basic.Anchors import Wumpus.Basic.Arrows import Wumpus.Basic.Colour.SVGColours import Wumpus.Basic.Graphic                     -- package: wumpus-basic@@ -26,67 +25,68 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    writeEPS_latin1 "./out/petri_net.eps" petri_net-    writeSVG_latin1 "./out/petri_net.svg" petri_net+    let pic1 = runDrawingU (standardContext 14) petri_net+    writeEPS "./out/petri_net.eps" pic1+    writeSVG "./out/petri_net.svg" pic1       -petri_net :: DPicture-petri_net = liftToPictureU $ execDrawing (standardContext 14) $ do-              pw     <- place 0 140-              tu1    <- transition 70 140-              rtw    <- place 140 140-              tu2    <- transition 210 140-              w      <- place 280 140-              tu3    <- transition 350 140-              res    <- place 280 70-              pr     <- place 0 0-              tl1    <- transition 70 0-              rtr    <- place 140 0-              tl2    <- transition 210 0-              r      <- place 280 0-              tl3    <- transition 350 0-              connector' (east pw)  (west tu1)              -              connector' (east tu1) (west rtw)-              connector' (east rtw) (west tu2)-              connector' (east tu2) (west w)-              connector' (east w)   (west tu3)-              connectorC 32 (north tu3) (north pw)-              connector' (east pr)  (west tl1)              -              connector' (east tl1) (west rtr)-              connector' (east rtr) (west tl2)-              connector' (east tl2) (west r)-              connector' (east r)   (west tl3)-              connectorC (-32) (south tl3) (south pr)-              connector' (southwest res) (northeast tl2)-              connector' (northwest tl3) (southeast res)-              connectorD 6    (southwest tu3) (northeast res)-              connectorD (-6) (southwest tu3) (northeast res) -              connectorD 6    (northwest res) (southeast tu2)-              connectorD (-6) (northwest res) (southeast tu2) -              draw $ lblParensParens `at` (P2 (-36) 150)-              draw $ lblParensParens `at` (P2 300 60)-              draw $ lblParensParensParens `at` (P2 (-52) (-14))-              draw $ lblBold "processing_w"   `at` (southwards 12 pw)-              draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)-              draw $ lblBold "writing"        `at` (southwards 12 w)-              draw $ lblBold' "resource"      `at` (P2 300 72)-              draw $ lblBold "processing_r"   `at` (northwards 12 pr)-              draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)-              draw $ lblBold "reading"        `at` (northwards 12 r)-              return ()+petri_net :: DDrawing+petri_net = drawTracing $ do+    pw     <- place 0 140+    tu1    <- transition 70 140+    rtw    <- place 140 140+    tu2    <- transition 210 140+    w      <- place 280 140+    tu3    <- transition 350 140+    res    <- place 280 70+    pr     <- place 0 0+    tl1    <- transition 70 0+    rtr    <- place 140 0+    tl2    <- transition 210 0+    r      <- place 280 0+    tl3    <- transition 350 0+    connector' (east pw)  (west tu1)              +    connector' (east tu1) (west rtw)+    connector' (east rtw) (west tu2)+    connector' (east tu2) (west w)+    connector' (east w)   (west tu3)+    connectorC 32 (north tu3) (north pw)+    connector' (east pr)  (west tl1)              +    connector' (east tl1) (west rtr)+    connector' (east rtr) (west tl2)+    connector' (east tl2) (west r)+    connector' (east r)   (west tl3)+    connectorC (-32) (south tl3) (south pr)+    connector' (southwest res) (northeast tl2)+    connector' (northwest tl3) (southeast res)+    connectorD 6    (southwest tu3) (northeast res)+    connectorD (-6) (southwest tu3) (northeast res) +    connectorD 6    (northwest res) (southeast tu2)+    connectorD (-6) (northwest res) (southeast tu2) +    draw $ lblParensParens `at` (P2 (-36) 150)+    draw $ lblParensParens `at` (P2 300 60)+    draw $ lblParensParensParens `at` (P2 (-52) (-14))+    draw $ lblBold "processing_w"   `at` (southwards 12 pw)+    draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)+    draw $ lblBold "writing"        `at` (southwards 12 w)+    draw $ lblBold' "resource"      `at` (P2 300 72)+    draw $ lblBold "processing_r"   `at` (northwards 12 pr)+    draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)+    draw $ lblBold "reading"        `at` (northwards 12 r)+    return ()  greenFill :: DrawingCtxM m => m a -> m a greenFill = localize (fillColour lime_green)  place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m)        => u -> u -> m (Circle u)-place x y = greenFill $ drawi $ borderedShape $ circle 14 `at` P2 x y+place x y = greenFill $ drawi $ borderedShape $ circle 14 $ P2 x y  transition :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m)             => u -> u -> m (Rectangle u) transition x y = -    greenFill $ drawi $ borderedShape $ rectangle 32 22 `at` P2 x y+    greenFill $ drawi $ borderedShape $ rectangle 32 22 $ P2 x y   @@ -95,32 +95,32 @@          , Real u, Floating u, FromPtSize u )        => Point2 u -> Point2 u -> m () connector' p0 p1 = -    drawi_ $ strokeConnector (rightArrow connLine tri45) p0 p1+    drawi_ $ situ2 (strokeConnector (rightArrow connLine tri45)) p0 p1   connectorC :: ( Real u, Floating u, FromPtSize u              , DrawingCtxM m, TraceM m, u ~ MonUnit m )            => u -> Point2 u -> Point2 u -> m () connectorC v p0 p1 = -    drawi_ $ strokeConnector (rightArrow (connRightVHV v) tri45) p0 p1+    drawi_ $ situ2 (strokeConnector (rightArrow (connRightVHV v) tri45)) p0 p1  connectorD :: ( Real u, Floating u, FromPtSize u              , DrawingCtxM m, TraceM m, u ~ MonUnit m )            => u -> Point2 u -> Point2 u -> m () connectorD u p0 p1 = -    drawi_ $ strokeConnector (rightArrow (connIsosceles u) tri45) p0 p1+    drawi_ $ situ2 (strokeConnector (rightArrow (connIsosceles u) tri45)) p0 p1   lblParensParens :: Num u => LocGraphic u-lblParensParens = localize (fontface helvetica) . textline "(),()"+lblParensParens = localize (fontface helvetica) $ textline "(),()"  lblParensParensParens :: Num u => LocGraphic u-lblParensParensParens = localize (fontface helvetica) . textline "(),(),()"+lblParensParensParens = localize (fontface helvetica) $ textline "(),(),()"   lblBold' :: Num u => String -> LocGraphic u-lblBold' ss = localize (fontface helvetica_bold) . textline ss+lblBold' ss = localize (fontface helvetica_bold) $ textline ss   lblBold :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u-lblBold ss = localize (fontface helvetica_bold) . centermonoTextline ss+lblBold ss = localize (fontface helvetica_bold) $ centermonoTextline ss

@@ -1,151 +0,0 @@-{-# OPTIONS -Wall #-}--module Picture where--import Wumpus.Basic.Colour.SVGColours-import Wumpus.Basic.Graphic-import Wumpus.Basic.PictureLanguage--import Wumpus.Core                              -- package: wumpus-core--import System.Directory---main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    >> writeEPS_latin1 "./out/picture_lang.eps" pictures-    >> writeSVG_latin1 "./out/picture_lang.svg" pictures--pictures :: DPicture-pictures = vsep 12 pic1 [ pic2,  pic3,  pic4,  pic5-                        , pic6,  pic7,  pic8,  pic9-                        , pic10, pic11, pic12, pic13 ]--pic1 :: DPicture-pic1 = picAnno pic "red `over` green `over` blue"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ rect_red `over` rect_green `over` rect_blue--pic2 :: DPicture-pic2 = picAnno pic "red `under` green `under` blue"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ rect_red `under` rect_green `under` rect_blue---pic3 :: DPicture -pic3 = picAnno pic "red `centerOver` green `centerOver` blue"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            rect_red `centerOver` rect_green `centerOver` rect_blue---- Note - nextToH only moves pictures in the horizontal.----pic4 :: DPicture -pic4 = picAnno pic "red `nextToH` green `nextToH` blue"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            rect_red `nextToH` rect_green `nextToH` rect_blue---- Note - nextToV only moves pictures in the vertical.----pic5 :: DPicture -pic5 = picAnno pic "red `nextToV` green `nextToV` blue"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            rect_red `nextToV` rect_green `nextToV` rect_blue---pic6 :: DPicture-pic6 = picAnno pic "[red, green] `stackOver` blue"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            [rect_red, rect_green] `stackOver` rect_blue--pic7 :: DPicture-pic7 = picAnno pic "zconcat red [green, blue]"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            zconcat rect_red [rect_green, rect_blue]---pic8 :: DPicture-pic8 = picAnno pic "hcat red [green, blue]"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            hcat rect_red [rect_green, rect_blue]--pic9 :: DPicture-pic9 = picAnno pic "vcat red [green, blue]"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            vcat rect_red [rect_green, rect_blue]--pic10 :: DPicture-pic10 = picAnno pic "hsep 20 red [green, blue]"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            hsep 20 rect_red [rect_green, rect_blue]--pic11 :: DPicture-pic11 = picAnno pic "vsep 20 red [green, blue]"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            vsep 20 rect_red [rect_green, rect_blue]---pic12 :: DPicture-pic12 = picAnno pic "hcatA HTop red [green, blue]"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            hcatA HTop rect_red [rect_green, rect_blue]---pic13 :: DPicture-pic13 = picAnno pic "vcatA VCenter red [green, blue]"-  where-    pic :: DPicture-    pic = illustrateBounds blue $ -            vcatA VCenter rect_red [rect_green, rect_blue]-------------------------------------------------------------------------------------pic_drawing_ctx :: DrawingContext-pic_drawing_ctx = standardContext 14--picAnno :: DPicture -> String -> DPicture-picAnno pic msg = alignHSep HCenter 30 pic lbl-  where-    lbl = liftToPictureU $ execDrawing pic_drawing_ctx $ -            draw $ textline msg `at` zeroPt---rect_red :: DPicture-rect_red = liftToPictureU $ execDrawing pic_drawing_ctx $ -              localize (fillColour indian_red)-                       (draw $ borderedRectangle 30 10 `at` (P2 0 10))-                 -rect_green :: DPicture-rect_green = liftToPictureU $ execDrawing pic_drawing_ctx $ -              localize (fillColour olive_drab)-                       (draw $ borderedRectangle 15 15 `at` (P2 10 10))---rect_blue :: DPicture-rect_blue = liftToPictureU $ execDrawing pic_drawing_ctx $ -              localize (fillColour powder_blue)-                       (draw $ borderedRectangle 20 30 `at` (P2 10 0))-

@@ -2,10 +2,9 @@  module Symbols where +import Wumpus.Basic.Chains import Wumpus.Basic.Graphic import Wumpus.Basic.SafeFonts-import Wumpus.Basic.Text.LRSymbol-import Wumpus.Basic.Text.LRText   import Wumpus.Core                              -- package: wumpus-core@@ -20,242 +19,205 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    demo01+    let pic1 = runDrawingU std_ctx symbols+    writeEPS "./out/symbols.eps" pic1+    writeSVG "./out/symbols.svg" pic1  -demo01 :: IO ()-demo01 = do -    writeEPS_latin1 "./out/symbols.eps" pic1-    writeSVG_latin1 "./out/symbols.svg" pic1- std_ctx :: DrawingContext std_ctx = fontface times_roman $ standardContext 12 -pic1 :: DPicture -pic1 = liftToPictureU $ execDrawing std_ctx $ do-         zipWithM_ mdraw letters_01 column_01-         zipWithM_ sdraw letters_01 column_01-         zipWithM_ mdraw letters_02 column_02-         zipWithM_ sdraw letters_02 column_02-         zipWithM_ mdraw letters_03 column_03-         zipWithM_ sdraw letters_03 column_03-         zipWithM_ mdraw letters_04 column_04-         zipWithM_ sdraw letters_04 column_04-         zipWithM_ mdraw letters_05 column_05-         zipWithM_ sdraw letters_05 column_05-         zipWithM_ mdraw letters_06 column_06-         zipWithM_ sdraw letters_06 column_06 +-- Because the font changes, we draw the all the symbols in one+-- run and all the labels in a second run. This helps Wumpus-Core +-- generate better PostScript as there are less changes to the +-- /graphics state/.+--+symbols :: DDrawing+symbols = drawTracing $ do+    localize (fontface symbol) $ zipWithM_ sdraw all_letters ps+    zipWithM_ ldraw all_letters ps   where-    mdraw (_,ma) pt = draw $ execLRText ma `at` pt-    sdraw (s,_)  pt = draw $ textline s `at` pt .+^ hvec 16--letters_01 :: [(String, LRText Double ())]-letters_01 = -    [ ("uAlpha",                uAlpha) -    , ("uBeta",                 uBeta)-    , ("uChi",                  uChi)-    , ("uDelta",                uDelta)-    , ("uEpsilon",              uEpsilon)-    , ("uEta",                  uEta)-    , ("uEuro",                 uEuro)-    , ("uGamma",                uGamma)-    , ("uIfraktur",             uIfraktur)-    , ("uIota",                 uIota)-    , ("uKappa",                uKappa)-    , ("uLambda",               uLambda)-    , ("uMu",                   uMu)-    , ("uNu",                   uNu)-    , ("uOmega",                uOmega)-    , ("uOmicron",              uOmicron)-    , ("uPhi",                  uPhi)-    , ("uPi",                   uPi)-    , ("uPsi",                  uPsi)-    , ("uRfraktur",             uRfraktur)-    , ("uRho",                  uRho)-    , ("uSigma",                uSigma)-    , ("uTau",                  uTau)-    , ("uTheta",                uTheta)-    , ("uUpsilon",              uUpsilon)-    , ("uUpsilon1",             uUpsilon1)-    , ("uXi",                   uXi)-    , ("uZeta",                 uZeta)-    , ("aleph",                 aleph)-    , ("alpha",                 alpha)-    , ("ampersand",             ampersand)-    , ("angle",                 angle)-    , ("angleleft",             angleleft)-    , ("angleright",            angleright)-    , ("approxequal",           approxequal)-    ]--letters_02 :: [(String, LRText Double ())]-letters_02 = -    [ ("arrowboth",             arrowboth) -    , ("arrowdblboth",          arrowdblboth)-    , ("arrowdbldown",          arrowdbldown)-    , ("arrowdblleft",          arrowdblleft)-    , ("arrowdblright",         arrowdblright)-    , ("arrowdblup",            arrowdblup)-    , ("arrowdown",             arrowdown)-    , ("arrowleft",             arrowleft)-    , ("arrowright",            arrowright)-    , ("arrowup",               arrowup)-    , ("asteriskmath",          asteriskmath)-    , ("bar",                   bar)-    , ("beta",                  beta)-    , ("braceleft",             braceleft)-    , ("braceright",            braceright)-    , ("bracketleft",           bracketleft)-    , ("bracketright",          bracketright)-    , ("bullet",                bullet)-    , ("carriagereturn",        carriagereturn)-    , ("chi",                   chi)-    ]+    sdraw (s,_)     pt = draw $ textline s `at` pt+    ldraw (_,name)  pt = draw $ textline name `at` pt .+^ hvec 16+    ps              = unchain (coordinateScalingContext 100 20) $ tableDown 30 6 -letters_03 :: [(String, LRText Double ())]-letters_03 = -    [ ("circlemultiply",        circlemultiply) -    , ("circleplus",            circleplus)-    , ("club",                  club)-    , ("colon",                 colon)-    , ("comma",                 comma)-    , ("congruent",             congruent)-    , ("copyrightsans",         copyrightsans)-    , ("copyrightserif",        copyrightserif)-    , ("degree",                degree)-    , ("delta",                 delta)-    , ("diamond",               diamond)-    , ("divide",                divide)-    , ("dotmath",               dotmath)-    , ("eight",                 eight)-    , ("element",               element)-    , ("ellipsis",              ellipsis)-    , ("emptyset",              emptyset)-    , ("epsilon",               epsilon)-    , ("equal",                 equal)-    , ("equivalence",           equivalence)-    , ("eta",                   eta)-    , ("exclam",                exclam)-    , ("existential",           existential)-    , ("five",                  five)-    , ("florin",                florin)-    , ("four",                  four)-    , ("fraction",              fraction)-    , ("gamma",                 gamma)-    , ("gradient",              gradient)-    , ("greater",               greater)-    , ("greaterequal",          greaterequal)-    , ("heart",                 heart)-    , ("infinity",              infinity)-    , ("integral",              integral)-    ]+all_letters :: [(String, String)]+all_letters = +    [ ("Α",               "Alpha") +    , ("Β",                "Beta")+    , ("Χ",                 "Chi")+    , ("Δ",               "Delta")+    , ("Ε",             "Epsilon")+    , ("Η",                 "Eta")+    , ("&Euro;",                "Euro")+    , ("Γ",               "Gamma")+    , ("&Ifraktur;",            "Ifraktur")+    , ("Ι",                "Iota")+    , ("Κ",               "Kappa")+    , ("Λ",              "Lambda")+    , ("Μ",                  "Mu")+    , ("Ν",                  "Nu")+    , ("Ω",               "Omega")+    , ("Ο",             "Omicron")+    , ("Φ",                 "Phi")+    , ("Π",                  "Pi")+    , ("Ψ",                 "Psi")+    , ("&Rfraktur;",            "Rfraktur")+    , ("Ρ",                 "Rho")+    , ("Σ",               "Sigma")+    , ("Τ",                 "Tau")+    , ("Θ",               "Theta")+    , ("Υ",             "Upsilon")+    , ("&Upsilon1;",            "Upsilon1")+    , ("Ξ",                  "Xi")+    , ("Ζ",                "Zeta")+    , ("ℵ",               "aleph")+    , ("α",               "alpha")+    , ("&ampersand;",           "ampersand")+    , ("∠",               "angle")+    , ("&angleleft;",           "angleleft")+    , ("&angleright;",          "angleright")+    , ("&approxequal;",         "approxequal") +    -- +    , ("&arrowboth;",           "arrowboth") +    , ("&arrowdblboth;",        "arrowdblboth")+    , ("&arrowdbldown;",        "arrowdbldown")+    , ("&arrowdblleft;",        "arrowdblleft")+    , ("&arrowdblright;",       "arrowdblright")+    , ("&arrowdblup;",          "arrowdblup")+    , ("&arrowdown;",           "arrowdown")+    , ("&arrowleft;",           "arrowleft")+    , ("&arrowright;",          "arrowright")+    , ("&arrowup;",             "arrowup")+    , ("&asteriskmath;",        "asteriskmath")+    , ("&bar;",                 "bar")+    , ("β",                "beta")+    , ("&braceleft;",           "braceleft")+    , ("&braceright;",          "braceright")+    , ("&bracketleft;",         "bracketleft")+    , ("&bracketright;",        "bracketright")+    , ("•",              "bullet")+    , ("&carriagereturn;",      "carriagereturn")+    , ("χ",                 "chi") -letters_04 :: [(String, LRText Double ())]-letters_04 = -    [ ("intersection",          intersection)-    , ("iota",                  iota)-    , ("kappa",                 kappa)-    , ("lambda",                lambda)-    , ("less",                  less)-    , ("lessequal",             lessequal)-    , ("logicaland",            logicaland)-    , ("logicalnot",            logicalnot)-    , ("logicalor",             logicalor)-    , ("lozenge",               lozenge)-    , ("minus",                 minus)-    , ("minute",                minute)-    , ("mu",                    mu)-    , ("multiply",              multiply)-    , ("nine",                  nine)-    , ("notelement",            notelement)-    , ("notequal",              notequal)-    , ("notsubset",             notsubset)-    , ("nu",                    nu)-    , ("numbersign",            numbersign)-    , ("omega",                 omega)-    , ("omega1",                omega1)-    , ("omicron",               omicron)-    , ("one",                   one)-    , ("parenleft",             parenleft)-    , ("parenright",            parenright)-    ]+    --+    , ("&circlemultiply;",      "circlemultiply") +    , ("&circleplus;",          "circleplus")+    , ("&club;",                "club")+    , (":",               "colon")+    , (",",               "comma")+    , ("&congruent;",           "congruent")+    , ("&copyrightsans;",       "copyrightsans")+    , ("&copyrightserif;",      "copyrightserif")+    , ("&degree;",              "degree")+    , ("δ",               "delta")+    , ("⋄",             "diamond")+    , ("÷",              "divide")+    , ("&dotmath;",             "dotmath")+    , ("&eight;",               "eight")+    , ("&element;",             "element")+    , ("&ellipsis;",            "ellipsis")+    , ("∅",            "emptyset")+    , ("ε",             "epsilon")+    , ("&equal;",               "equal")+    , ("&equivalence;",         "equivalence")+    , ("η",                 "eta")+    , ("&exclam;",              "exclam")+    , ("&existential;",         "existential")+    , ("&five;",                "five")+    , ("&florin;",              "florin")+    , ("&four;",                "four")+    , ("&fraction;",            "fraction")+    , ("γ",               "gamma")+    , ("&gradient;",            "gradient")+    , ("&greater;",             "greater")+    , ("&greaterequal;",        "greaterequal")+    , ("&heart;",               "heart")+    , ("&infinity;",            "infinity")+    , ("&integral;",            "integral") -letters_05 :: [(String, LRText Double ())]-letters_05 = -    [ ("partialdiff",           partialdiff)-    , ("percent",               percent)-    , ("period",                period)-    , ("perpendicular",         perpendicular)-    , ("phi",                   phi)-    , ("phi1",                  phi1)-    , ("pi",                    pi)-    , ("plus",                  plus)-    , ("plusminus",             plusminus)-    , ("product",               product)-    , ("propersubset",          propersubset)-    , ("propersuperset",        propersuperset)-    , ("proportional",          proportional)-    , ("psi",                   psi)-    , ("question",              question)-    , ("radical",               radical)-    , ("radicalex",             radicalex)-    , ("reflexsubset",          reflexsubset)-    , ("reflexsuperset",        reflexsuperset)-    , ("registersans",          registersans)-    , ("registerserif",         registerserif)-    , ("rho",                   rho)-    ]+    -- +    , ("&intersection;",        "intersection")+    , ("ι",                "iota")+    , ("κ",               "kappa")+    , ("λ",              "lambda")+    , ("&less;",                "less")+    , ("&lessequal;",           "lessequal")+    , ("&logicaland;",          "logicaland")+    , ("&logicalnot;",          "logicalnot")+    , ("&logicalor;",           "logicalor")+    , ("◊",             "lozenge")+    , ("−",               "minus")+    , ("&minute;",              "minute")+    , ("μ",                  "mu")+    , ("&multiply;",            "multiply")+    , ("&nine;",                "nine")+    , ("&notelement;",          "notelement")+    , ("&notequal;",            "notequal")+    , ("&notsubset;",           "notsubset")+    , ("ν",                  "nu")+    , ("&numbersign;",          "numbersign")+    , ("ω",               "omega")+    , ("&omega1;",              "omega1")+    , ("ο",             "omicron")+    , ("&one;",                 "one")+    , ("&parenleft;",           "parenleft")+    , ("&parenright;",          "parenright") -letters_06 :: [(String, LRText Double ())]-letters_06 = -    [ ("second",                second)-    , ("semicolon",             semicolon)-    , ("seven",                 seven)-    , ("sigma",                 sigma)-    , ("sigma1",                sigma1)-    , ("similar",               similar)-    , ("six",                   six)-    , ("slash",                 slash)-    , ("space",                 space)-    , ("spade",                 spade)-    , ("suchthat",              suchthat)-    , ("summation",             summation)-    , ("tau",                   tau)-    , ("therefore",             therefore)-    , ("theta",                 theta)-    , ("theta1",                theta1)-    , ("three",                 three)-    , ("trademarksans",         trademarksans)-    , ("trademarkserif",        trademarkserif)-    , ("two",                   two)-    , ("underscore",            underscore)-    , ("union",                 union)-    , ("universal",             universal)-    , ("upsilon",               upsilon)-    , ("weierstrass",           weierstrass)-    , ("xi",                    xi)-    , ("zero",                  zero)-    , ("zeta",                  zeta)+    --+    , ("&partialdiff;",         "partialdiff")+    , ("&percent;",             "percent")+    , (".",              "period")+    , ("&perpendicular;",       "perpendicular")+    , ("φ",                 "phi")+    , ("&phi1;",                "phi1")+    , ("π",                  "pi")+    , ("+",                "plus")+    , ("&plusminus;",           "plusminus")+    , ("&product;",             "product")+    , ("&propersubset;",        "propersubset")+    , ("&propersuperset;",      "propersuperset")+    , ("&proportional;",        "proportional")+    , ("ψ",                 "psi")+    , ("&question;",            "question")+    , ("&radical;",             "radical")+    , ("&radicalex;",           "radicalex")+    , ("&reflexsubset;",        "reflexsubset")+    , ("&reflexsuperset;",      "reflexsuperset")+    , ("&registersans;",        "registersans")+    , ("&registerserif;",       "registerserif")+    , ("ρ",                 "rho")+    +    -- +    , ("&second;",              "second")+    , ("&semicolon;",           "semicolon")+    , ("&seven;",               "seven")+    , ("σ",               "sigma")+    , ("&sigma1;",              "sigma1")+    , ("&similar;",             "similar")+    , ("&six;",                 "six")+    , ("&slash;",               "slash")+    , ("&space;",               "space")+    , ("&spade;",               "spade")+    , ("&suchthat;",            "suchthat")+    , ("&summation;",           "summation")+    , ("τ",                 "tau")+    , ("∴",           "therefore")+    , ("θ",               "theta")+    , ("&theta1;",              "theta1")+    , ("&three;",               "three")+    , ("&trademarksans;",       "trademarksans")+    , ("&trademarkserif;",      "trademarkserif")+    , ("&two;",                 "two")+    , ("&underscore;",          "underscore")+    , ("&union;",               "union")+    , ("&universal;",           "universal")+    , ("υ",             "upsilon")+    , ("&weierstrass;",         "weierstrass")+    , ("ξ",                  "xi")+    , ("&zero;",                "zero")+    , ("ζ",                "zeta")     ] --- TODO - this should use a chain when the Chain API stablizes.--column_01 :: Num u => [Point2 u]-column_01 = iterate (.+^ vvec (-16)) (P2 0 600)--column_02 :: Num u => [Point2 u]-column_02 = iterate (.+^ vvec (-16)) (P2 100 600)--column_03 :: Num u => [Point2 u]-column_03 = iterate (.+^ vvec (-16)) (P2 200 600)--column_04 :: Num u => [Point2 u]-column_04 = iterate (.+^ vvec (-16)) (P2 300 600)--column_05 :: Num u => [Point2 u]-column_05 = iterate (.+^ vvec (-16)) (P2 400 600)--column_06 :: Num u => [Point2 u]-column_06 = iterate (.+^ vvec (-16)) (P2 500 600)

@@ -1,138 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Anchors--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Anchor points on shapes.------ \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Anchors-  ( --  -- * Anchors-    CenterAnchor(..)-  , CardinalAnchor(..)-  , CardinalAnchor2(..)-  , RadialAnchor(..)--  -- * extended anchor points-  , northwards-  , southwards-  , eastwards-  , westwards-  , northeastwards-  , southeastwards-  , southwestwards-  , northwestwards--  , radialConnectorPoints--  ) where--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space--class CenterAnchor t where-  center :: DUnit t ~ u => t -> Point2 u---- Note - in TikZ cardinal anchors are not necessarily at the--- equivalent radial position, for instance reactangle north-east--- is the top-right corner whether or not this is incident at --- 45deg.-----class CardinalAnchor t where-  north :: DUnit t ~ u => t -> Point2 u-  south :: DUnit t ~ u => t -> Point2 u-  east  :: DUnit t ~ u => t -> Point2 u-  west  :: DUnit t ~ u => t -> Point2 u--class CardinalAnchor2 t where-  northeast :: DUnit t ~ u => t -> Point2 u-  southeast :: DUnit t ~ u => t -> Point2 u-  southwest :: DUnit t ~ u => t -> Point2 u-  northwest :: DUnit t ~ u => t -> Point2 u----- | Anchor on a border that can be identified with and angle.----class RadialAnchor t where-  radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u---extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u-extendPtDist d p1 p2 = let v   = pvec p1 p2-                           ang = direction v-                           len = vlength v-                       in p1 .+^ avec ang (len+d)----northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-              , u ~ DUnit t ) -           => u -> t -> Point2 u-northwards u a = extendPtDist u (center a) (north a)---southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-              , u ~ DUnit t ) -           => u -> t -> Point2 u-southwards u a = extendPtDist u (center a) (south a)--eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-             , u ~ DUnit t ) -          => u -> t -> Point2 u-eastwards u a = extendPtDist u (center a) (east a)--westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-             , u ~ DUnit t ) -          => u -> t -> Point2 u-westwards u a = extendPtDist u (center a) (west a)---northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-northeastwards u a = extendPtDist u (center a) (northeast a)---southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-southeastwards u a = extendPtDist u (center a) (southeast a)--southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-southwestwards u a = extendPtDist u (center a) (southwest a)--northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-northwestwards u a = extendPtDist u (center a) (northwest a)-------------------------------------------------------------------------------------radialConnectorPoints :: ( Real u, Floating u-                         , CenterAnchor t1, RadialAnchor t1-                         , CenterAnchor t2, RadialAnchor t2-                         , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) -                      => t1 -> t2 -> (Point2 u, Point2 u) -radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b)-  where-    theta = direction $ pvec (center a) (center b)-    

@@ -93,23 +93,25 @@   - strokeConnector :: (Real u, Floating u)                  => Connector u -> ConnectorImage u (Path u)-strokeConnector (Connector cpF opt_la opt_ra) p0 p1 =-    tipEval opt_la (directionL pathc) p0 >>= \(dl,gfL) -> -    tipEval opt_ra (directionR pathc) p1 >>= \(dr,gfR) ->-    intoImage (pure pathc) (gfR $ gfL $ drawP $ shortenPath dl dr pathc) +strokeConnector (Connector cpF opt_la opt_ra) =+    promote2 $ \p0 p1 -> let pathc = cpF p0 p1 in +       tipEval opt_la p0 (directionL pathc) >>= \(dl,gfL) -> +       tipEval opt_ra p1 (directionR pathc) >>= \(dr,gfR) ->+       intoImage (pure pathc) (postpro (gfR . gfL) $ drawP $ shortenPath dl dr pathc)    where-    pathc       = cpF p0 p1     drawP       = openStroke . toPrimPath    + -- for Paths.Base ? ---shortenPath :: (Real u , Floating u) =>  u  -> u -> Path u -> Path u+shortenPath :: (Real u , Floating u) => u  -> u -> Path u -> Path u shortenPath l r = shortenL l .  shortenR r  +type ArrowMark u = PrimGraphic u -> PrimGraphic u + -- 'tipEval' is a bit of an oddity. It has to evaluate the  -- Arrowhead / Image in the DrawingCtx to get the retract  -- distance. But doing so evaluates the tips to PrimGraphics, thus @@ -129,18 +131,18 @@ --  tipEval :: Num u -        => Maybe (Arrowhead u) -> Radian -> Point2 u -        -> DrawingR (u, GraphicTrafoF u)-tipEval Nothing    _     _  = return (0,unmarked)-tipEval (Just arw) theta pt = getArrowhead arw theta pt >>= \(dx,prim) -> -                              return (dx, superior $ pure prim)-+        => Maybe (Arrowhead u) -> Point2 u -> Radian+        -> CF (u, ArrowMark u)+tipEval Nothing    _  _     = return (0,unmarked)+tipEval (Just arw) pt theta = makeMark $ unCF2 pt theta (getArrowhead arw)  -unmarked :: GraphicTrafoF u+unmarked :: ArrowMark u unmarked = id  +makeMark :: Image u a -> CF (a, ArrowMark u)+makeMark = postpro (\(a,prim) -> (a, superior prim))   

@@ -22,6 +22,7 @@       Arrowhead(..)+     , tri90   , tri60@@ -62,7 +63,6 @@  import Wumpus.Basic.Graphic import Wumpus.Basic.Paths-import Wumpus.Basic.Utils.Combinators  import Wumpus.Core                      -- package: wumpus-core @@ -78,7 +78,7 @@ -- the markHeight (or halfMarkHeight) so it has to be calculated -- w.r.t. the DrawingCtx. ---newtype Arrowhead u = Arrowhead { getArrowhead :: ThetaLocImage u u }+newtype Arrowhead u = Arrowhead { getArrowhead :: LocThetaImage u u }   @@ -144,7 +144,7 @@ -}  -markHeightLessLineWidth :: (Fractional u, FromPtSize u) => DrawingR u+markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u markHeightLessLineWidth =      (\h lw -> h - realToFrac lw) <$> markHeight <*> lineWidth @@ -154,13 +154,16 @@ -- Its common for the rectraction not to care about the angle or  -- the point and only care about the DrawingCtx. ---noRetract :: Num u => ThetaLocDrawingR u u-noRetract = rlift2 $ pure 0 +noRetract :: Num u => LocThetaCF u u+noRetract = wrap2 0    + -------------------------------------------------------------------------------- ++ -- | Tripoints takes the \*tip length\* is the mark height. -- -- This means that the 90deg tip has a tip width greater-than the@@ -168,236 +171,269 @@ -- does it). -- tripointsByAngle :: (Floating u, FromPtSize u)-                 => Radian ->  ThetaLocDrawingR u (Point2 u, Point2 u)-tripointsByAngle triang theta pt = -    (\h -> let (vupper,vlower) = triVecsByAngle h (0.5*triang) theta-           in  (pt .+^ vupper, pt .+^ vlower))-      <$> markHeight-+                 => Radian ->  LocThetaCF u (Point2 u, Point2 u)+tripointsByAngle triang = markHeight >>= \h -> +    raise2 $ \pt theta -> let (vup,vlo) = triVecsByAngle h (0.5*triang) theta+                          in  (pt .+^ vup, pt .+^ vlo)+      revtripointsByAngle :: (Floating u, FromPtSize u)                     => Radian -                    -> ThetaLocDrawingR u (Point2 u, Point2 u, Point2 u)-revtripointsByAngle triang theta pt = -    (\h -> let theta'          = circularModulo $ pi+theta -               (vupper,vlower) = triVecsByAngle h (0.5*triang) theta'-               back_tip        = pt .-^ avec theta h -           in (back_tip .+^ vupper, back_tip, back_tip .+^ vlower) )-      <$> markHeight+                    -> LocThetaCF u (Point2 u, Point2 u, Point2 u)+revtripointsByAngle triang = markHeight >>= \h -> +    raise2 $ \pt theta -> let theta'    = circularModulo $ pi+theta +                              (vup,vlo) = triVecsByAngle h (0.5*triang) theta'+                              back_tip  = pt .-^ avec theta h +                          in (back_tip .+^ vup, back_tip, back_tip .+^ vlo)  + tripointsByDist :: (Real u, Floating u, FromPtSize u)-                => ThetaLocDrawingR u (Point2 u, Point2 u)-tripointsByDist theta pt = -    (\h -> let (vup,vlo) = triVecsByDist h (0.5*h) theta-           in  (pt .+^ vup, pt .+^ vlo))-      <$> markHeight+                => LocThetaCF u (Point2 u, Point2 u)+tripointsByDist = markHeight >>= \h ->+    raise2 $ \pt theta -> let (vup,vlo) = triVecsByDist h (0.5*h) theta+                          in  (pt .+^ vup, pt .+^ vlo)+     revtripointsByDist :: (Real u, Floating u, FromPtSize u)-                   => ThetaLocDrawingR u (Point2 u, Point2 u, Point2 u)-revtripointsByDist theta pt = -    (\h -> let theta'    = circularModulo $ pi+theta -               (vup,vlo) = triVecsByDist h (0.5*h) theta'-               back_tip  = pt .-^ avec theta h -           in  (back_tip .+^ vup, back_tip, back_tip .+^ vlo))-      <$> markHeight+                   => LocThetaCF u (Point2 u, Point2 u, Point2 u)+revtripointsByDist = markHeight >>= \h -> +    raise2 $ \pt theta -> let theta'    = circularModulo $ pi+theta +                              (vup,vlo) = triVecsByDist h (0.5*h) theta'+                              back_tip  = pt .-^ avec theta h +                          in  (back_tip .+^ vup, back_tip, back_tip .+^ vlo)   ++bindLocTip :: LocThetaCF u a -> (a -> LocGraphic u) -> LocThetaGraphic u+bindLocTip df da = bind2 df (\a -> static2 $ da a) ++bindLocThetaTip :: LocThetaCF u a -> (a -> LocThetaGraphic u) +                -> LocThetaGraphic u+bindLocThetaTip = bind2 +++ -- width = xchar_height -- filled with stroke colour!  triTLG :: (Floating u, Real u, FromPtSize u)-       => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u-triTLG triang drawF = tripointsByAngle triang `bindR2` \(u,v) -> -    rlift1 $ \pt -> localize bothStrokeColour $ drawF $ vertexPath [pt,u,v]--+       => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u+triTLG triang drawF = localize bothStrokeColour $ +    bindLocTip (tripointsByAngle triang) +               (\(u,v) -> promote1 $ \pt -> drawF $ vertexPath [pt,u,v])    tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri90 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/2) filledPath)+    intoLocThetaImage (dblstatic markHeight) (triTLG (pi/2) filledPath)   tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri60 = Arrowhead $-    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/3) filledPath)+    intoLocThetaImage (dblstatic markHeight) (triTLG (pi/3) filledPath)   tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri45 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/4) filledPath)+    intoLocThetaImage (dblstatic markHeight) (triTLG (pi/4) filledPath)  otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri90 = Arrowhead $-    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/2) closedStroke)+    intoLocThetaImage (dblstatic markHeight) (triTLG (pi/2) closedStroke)  otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri60 = Arrowhead $   -    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/3) closedStroke)+    intoLocThetaImage (dblstatic markHeight) (triTLG (pi/3) closedStroke)  otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri45 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/4) closedStroke)-+    intoLocThetaImage (dblstatic markHeight) (triTLG (pi/4) closedStroke)   -- width = xchar_height -- filled with stroke colour!  revtriTLG :: (Floating u, Real u, FromPtSize u)-          => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u-revtriTLG triang drawF = revtripointsByAngle triang `bindR2` \(u,pt,v) -> -    rlift2 $ localize bothStrokeColour $ drawF $ vertexPath [u,pt,v]+          => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u+revtriTLG triang drawF = localize bothStrokeColour $ +    bindLocTip (revtripointsByAngle triang) +               (\(u,pt,v) -> static1 $ drawF $ vertexPath [u,pt,v])  + revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri90 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeightLessLineWidth) +    intoLocThetaImage (dblstatic markHeightLessLineWidth)                        (revtriTLG (pi/2) filledPath)  revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri60 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeightLessLineWidth) +    intoLocThetaImage (dblstatic markHeightLessLineWidth)                        (revtriTLG (pi/3) filledPath)  revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri45 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeightLessLineWidth) +    intoLocThetaImage (dblstatic markHeightLessLineWidth)                        (revtriTLG (pi/4) filledPath)   orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri90 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeightLessLineWidth) +    intoLocThetaImage (dblstatic markHeightLessLineWidth)                        (revtriTLG (pi/2) closedStroke)  orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri60 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeightLessLineWidth) +    intoLocThetaImage (dblstatic markHeightLessLineWidth)                        (revtriTLG (pi/3) closedStroke)  orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri45 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeightLessLineWidth) +    intoLocThetaImage (dblstatic markHeightLessLineWidth)                        (revtriTLG (pi/4) closedStroke)  -barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u-barbTLG ang = tripointsByAngle ang `bindR2` \(u,v) -> -    rlift1 $ \pt -> openStroke $ vertexPath [u,pt,v] +barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u+barbTLG ang =  +    bindLocTip (tripointsByAngle ang) +               (\(u,v) -> promote1 $ \pt -> openStroke $ vertexPath [u,pt,v]) ++ barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb90 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/2))+barb90 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/2))  barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb60 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/3))+barb60 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/3))   barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb45 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/4))+barb45 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/4))   -revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u-revbarbTLG ang = revtripointsByAngle ang `bindR2` \(u,pt,v) -> -    rlift2 $ openStroke $ vertexPath [u,pt,v]+revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u+revbarbTLG ang = +    bindLocTip (revtripointsByAngle ang)+               (\(u,pt,v) -> static1 $ openStroke $ vertexPath [u,pt,v])  revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb90 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/2))+    intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/2))   revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb60 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/3))+    intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/3))  revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb45 = Arrowhead $ -    intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/4))+    intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/4))  -perpTLG :: (Floating u, FromPtSize u) => ThetaLocGraphic u-perpTLG = bindAskR2 markHalfHeight $ \hh ->-    \theta pt -> let p0 = displacePerpendicular   hh  theta pt-                     p1 = displacePerpendicular (-hh) theta pt  -                 in straightLineBetween p0 p1+perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u+perpTLG = bindLocThetaTip (dblstatic markHalfHeight) fn+  where+    fn hh = promote2 $ \pt theta -> openStroke $ perpPath hh pt theta  +perpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u+perpPath hh ctr theta = primPath p0 [lineTo p1]+  where+    p0 = displacePerpendicular   hh  theta ctr+    p1 = displacePerpendicular (-hh) theta ctr +             ++ perp :: (Floating u, FromPtSize u) => Arrowhead u-perp = Arrowhead $ intoThetaLocImage noRetract perpTLG+perp = Arrowhead $ intoLocThetaImage noRetract perpTLG   -bracketTLG :: (Floating u, FromPtSize u) => ThetaLocGraphic u-bracketTLG = bindAskR2 markHalfHeight $ \hh -> -    \theta pt -> let p1 = displacePerpendicular   hh  theta pt-                     p0 = displaceParallel      (-hh) theta p1-                     p2 = displacePerpendicular (-hh) theta pt-                     p3 = displaceParallel      (-hh) theta p2-                 in openStroke $ vertexPath [p0,p1,p2,p3]+bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u+bracketTLG = bindLocThetaTip (dblstatic markHalfHeight) fn+  where+    fn hh = promote2 $ \pt theta -> openStroke $ bracketPath hh pt theta  +bracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u+bracketPath hh pt theta = vertexPath [p0,p1,p2,p3]+  where+    p1 = displacePerpendicular   hh  theta pt+    p0 = displaceParallel      (-hh) theta p1+    p2 = displacePerpendicular (-hh) theta pt+    p3 = displaceParallel      (-hh) theta p2+          + bracket :: (Floating u, FromPtSize u) => Arrowhead u-bracket = Arrowhead $ intoThetaLocImage noRetract bracketTLG+bracket = Arrowhead $ intoLocThetaImage noRetract bracketTLG + diskTLG :: (Floating u, FromPtSize u) -        => (u -> Point2 u -> Graphic u) -> ThetaLocGraphic u-diskTLG drawF = bindAskR2 markHalfHeight $ \hh ->-    \theta pt -> let ctr = pt .-^ avec theta hh-                 in drawF hh ctr+        => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u+diskTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn +  where+   fn hh = promote2 $ \pt theta -> let ctr = pt .-^ avec theta hh+                                   in drawF hh ctr + diskTip :: (Floating u, FromPtSize u) => Arrowhead u-diskTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (diskTLG drawF)+diskTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (diskTLG drawF)   where-    drawF r pt = localize bothStrokeColour $ filledDisk r pt+    drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt   odiskTip :: (Floating u, FromPtSize u) => Arrowhead u-odiskTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (diskTLG drawF)+odiskTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (diskTLG drawF)   where-    drawF r pt = strokedDisk r pt+    drawF r pt = strokedDisk r `at` pt   squareTLG :: (Floating u, FromPtSize u) -        => (PrimPath u -> Graphic u) -> ThetaLocGraphic u-squareTLG drawF = bindAskR2 markHalfHeight $ \hh ->-    \theta pt -> let p0 = displacePerpendicular     hh  theta pt-                     p3 = displacePerpendicular   (-hh) theta pt-                     p1 = displaceParallel      (-2*hh) theta p0-                     p2 = displaceParallel      (-2*hh) theta p3-                 in drawF $ vertexPath [p0,p1,p2,p3]+        => (PrimPath u -> Graphic u) -> LocThetaGraphic u+squareTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn+  where+    fn hh = promote2 $ \pt theta -> +              let p0 = displacePerpendicular     hh  theta pt+                  p3 = displacePerpendicular   (-hh) theta pt+                  p1 = displaceParallel      (-2*hh) theta p0+                  p2 = displaceParallel      (-2*hh) theta p3+              in drawF $ vertexPath [p0,p1,p2,p3] + squareTip :: (Floating u, FromPtSize u) => Arrowhead u-squareTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (squareTLG drawF)+squareTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (squareTLG drawF)   where     drawF = localize bothStrokeColour . filledPath   osquareTip :: (Floating u, FromPtSize u) => Arrowhead u osquareTip = Arrowhead $ -    intoThetaLocImage (rlift2 markHeight) (squareTLG closedStroke)+    intoLocThetaImage (dblstatic markHeight) (squareTLG closedStroke)   diamondTLG :: (Floating u, FromPtSize u) -           => (PrimPath u -> Graphic u) -> ThetaLocGraphic u-diamondTLG drawF = bindAskR2 markHalfHeight $ \hh ->-    \theta pt -> let ctr = displaceParallel       (-2*hh) theta pt-                     p1  = displacePerpendicular     hh   theta ctr-                     p3  = displacePerpendicular   (-hh)  theta ctr-                     p2  = displaceParallel       (-4*hh) theta pt-                 in drawF $ vertexPath [pt,p1,p2,p3]+           => (PrimPath u -> Graphic u) -> LocThetaGraphic u+diamondTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn+  where+    fn hh = promote2 $ \pt theta -> +              let ctr = displaceParallel       (-2*hh) theta pt+                  p1  = displacePerpendicular     hh   theta ctr+                  p3  = displacePerpendicular   (-hh)  theta ctr+                  p2  = displaceParallel       (-4*hh) theta pt+              in drawF $ vertexPath [pt,p1,p2,p3]   diamondTip :: (Floating u, FromPtSize u) => Arrowhead u diamondTip = Arrowhead $ -    intoThetaLocImage (rlift2 $ fmap (2*) markHeightLessLineWidth) +    intoLocThetaImage (dblstatic $ fmap (2*) markHeightLessLineWidth)                        (diamondTLG drawF)   where     drawF = localize bothStrokeColour . filledPath@@ -405,40 +441,45 @@  odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u odiamondTip = Arrowhead $ -    intoThetaLocImage (rlift2 $ fmap (2*) markHeight) (diamondTLG closedStroke)+    intoLocThetaImage (dblstatic $ fmap (2*) markHeight) (diamondTLG closedStroke)  + -- Note - points flipped to get the second trapezium to  -- draw /underneath/. ---curveTLG :: (Real u, Floating u, FromPtSize u) => ThetaLocGraphic u-curveTLG theta pt = -    markHalfHeight           >>= \hh        -> -    tripointsByDist theta pt >>= \(tup,tlo) -> -    let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup-        (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt -        tpath   = curve tup u2 u1 pt `append` curve pt l1 l2 tlo-    in localize (joinRound . capRound) -                (openStroke $ toPrimPath $ tpath)+curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u+curveTLG = bindLocThetaTip (dblstatic markHalfHeight) fn+  where+    fn hh = promote2 $ \pt theta -> +              unLocTheta pt theta tripointsByDist >>= \(tup,tlo) -> +              let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup+                  (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt +                  tpath   = curve tup u2 u1 pt `append` curve pt l1 l2 tlo+              in localize (joinRound . capRound) +                          (openStroke $ toPrimPath $ tpath) + curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u curveTip = Arrowhead $ -    intoThetaLocImage (rlift2 $ fmap realToFrac lineWidth) curveTLG+    intoLocThetaImage (dblstatic $ fmap realToFrac lineWidth) curveTLG   -- Note - points flipped to get the second trapezium to  -- draw /underneath/. ---revcurveTLG :: (Real u, Floating u, FromPtSize u) => ThetaLocGraphic u-revcurveTLG theta pt = -    markHalfHeight              >>= \hh           -> -    revtripointsByDist theta pt >>= \(tup,p1,tlo) -> -    let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup-        (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1-        tpath   = curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo-    in localize (joinRound . capRound) -                (openStroke $ toPrimPath $ tpath)+revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u+revcurveTLG = bindLocThetaTip (dblstatic markHalfHeight) fn +  where+   fn hh = promote2 $ \pt theta ->+             unLocTheta pt theta revtripointsByDist >>= \(tup,p1,tlo) -> +             let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup+                 (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1+                 tpath   = curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo+             in localize (joinRound . capRound) +                         (openStroke $ toPrimPath $ tpath)  revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u revcurveTip = Arrowhead $ -    intoThetaLocImage (rlift2 markHeight) revcurveTLG+    intoLocThetaImage (dblstatic markHeight) revcurveTLG+

@@ -54,17 +54,15 @@    ) where -import Wumpus.Basic.Anchors import Wumpus.Basic.Dots.Marks import Wumpus.Basic.Graphic-import Wumpus.Basic.Utils.Combinators+import Wumpus.Basic.Text.LRText import Wumpus.Basic.Utils.Intersection  import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space -import Control.Applicative   -- An existential thing that supports anchors.@@ -139,9 +137,15 @@     fn theta =  maybe ctr id $ findIntersect ctr theta                               $ rectangleLines ctr hw hh +bboxRectAnchor  :: (Real u, Floating u) => BoundingBox u -> DotAnchor u+bboxRectAnchor (BBox bl@(P2 x1 y1) (P2 x2 y2)) =+   let hw = 0.5 * (x2 - x1)+       hh = 0.5 * (y2 - y1)+   in rectangleAnchor hw hh (bl .+^ vec hw hh)+ rectangleLDO :: (Real u, Floating u) -             => u -> u -> LocDrawingR u (DotAnchor u)-rectangleLDO w h pt = pure $ rectangleAnchor (w*0.5) (h*0.5) pt+             => u -> u -> LocDrawingInfo u (DotAnchor u)+rectangleLDO w h = promote1 $ \pt -> wrap $ rectangleAnchor (w*0.5) (h*0.5) pt   circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u@@ -149,8 +153,9 @@                                  (\theta -> ctr .+^ (avec theta rad))                                  (radialCardinal rad ctr) -circleLDO :: (Floating u, FromPtSize u) => LocDrawingR u (DotAnchor u)-circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> markHeight +circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u)+circleLDO = bind1 (static1 markHeight) $ \diam -> +    promote1 $ \pt -> wrap $ circleAnchor (diam * 0.5) pt   @@ -162,16 +167,23 @@  dotChar :: (Floating u, Real u, FromPtSize u)          => Char -> DotLocImage u-dotChar ch = bindAsk (monoTextDimensions [ch]) $  \(w,h) -> -    intoLocImage (rectangleLDO w h) (markChar ch)+dotChar ch = dotText [ch]  +-- | Note - dots now use font metrics...+-- dotText :: (Floating u, Real u, FromPtSize u)          => String -> DotLocImage u -dotText ss = bindAsk (monoTextDimensions ss) $ \(w,h) -> -    intoLocImage (rectangleLDO w h) (markText ss) +dotText ss = locImageMapL bboxRectAnchor (singleLineCC ss)  +-- Is this generally useful? ...+--+locImageMapL :: (a -> b) -> LocImage u a -> LocImage u b+locImageMapL f = postpro1 $ \(a,prim) -> (f a, prim)+++ dotHLine :: (Floating u, FromPtSize u) => DotLocImage u dotHLine = intoLocImage circleLDO markHLine @@ -202,7 +214,7 @@   dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u-dotSquare = bindAsk markHeight $ \ h ->+dotSquare = bind1 (static1 markHeight) $ \ h ->     intoLocImage (rectangleLDO h h) markSquare  

@@ -48,7 +48,7 @@   import Wumpus.Basic.Graphic-import Wumpus.Basic.Utils.Combinators+import Wumpus.Basic.Text.LRText  import Wumpus.Core                      -- package: wumpus-core @@ -81,7 +81,7 @@   shiftOrigin :: Num u => u -> u -> LocGraphic u -> LocGraphic u-shiftOrigin dx dy f = \pt -> f (displace dx dy pt)+shiftOrigin dx dy = prepro1 (displace dx dy)  markChar :: (Fractional u, Ord u, FromPtSize u) => Char -> LocGraphic u markChar ch = markText [ch]@@ -90,7 +90,7 @@   markText :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u-markText ss = centermonoTextline ss+markText ss = postpro1 (\(_,b) -> b) $ singleLineCC ss   @@ -103,15 +103,15 @@   markHLine :: (Fractional u, FromPtSize u) => LocGraphic u -markHLine = bindAsk markHeight $ \h -> axialLine (hvec h)+markHLine = bind1 (static1 markHeight) $ \h -> axialLine (hvec h)   markVLine :: (Fractional u, FromPtSize u) => LocGraphic u -markVLine = bindAsk markHeight $ \h -> axialLine (vvec h) +markVLine = bind1 (static1 markHeight) $ \h -> axialLine (vvec h)    markX :: (Fractional u, FromPtSize u) => LocGraphic u-markX = bindAsk markHeight $ \h -> +markX = bind1 (static1 markHeight) $ \h ->      let w = 0.75 * h in axialLine (vec w h) `oplus` axialLine (vec (-w) h)  @@ -121,7 +121,7 @@   markCross :: (Floating u, FromPtSize u) =>  LocGraphic u-markCross = bindAsk markHeight $ \h ->  +markCross = bind1 (static1 markHeight) $ \h ->       (axialLine $ avec ang h) `oplus` (axialLine $ avec (-ang) h)   where     ang = pi*0.25  @@ -129,23 +129,25 @@ -- needs horizontal pinch...  pathDiamond :: (Fractional u, FromPtSize u) -            => Point2 u -> DrawingR (PrimPath u)-pathDiamond pt = (\h -> let hh    = 0.66 * h; hw = 0.5 * h -                        in vertexPath [dvs hh, dve hw,dvn hh, dvw hw])-                   <$> markHeight-  where-    dvs hh = pt .+^ vvec (-hh)-    dve hw = pt .+^ hvec hw-    dvn hh = pt .+^ vvec hh-    dvw hw = pt .+^ hvec (-hw)+            => LocCF u (PrimPath u)+pathDiamond = bind1 (static1 markHeight) $ \h -> promote1 $ \pt ->+    let hh    = 0.66 * h; hw = 0.5 * h +        s     = pt .+^ vvec (-hh)+        e     = pt .+^ hvec hw+        n     = pt .+^ vvec hh+        w     = pt .+^ hvec (-hw)+    in pure $ vertexPath [s,e,n,w]  +-- closedStroke :: (a -> ctx -> prim) +-- pathDiamond  :: (ctx -> pt -> a)+-- ans          :: (ctx -> pt -> prim)  markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markDiamond = pathDiamond `bindInto` closedStroke  +markDiamond = pathDiamond `bind1` (static1 . closedStroke)  markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markFDiamond = pathDiamond `bindInto` filledPath+markFDiamond = pathDiamond `bind1` (static1 . filledPath)   -- Note - the (const . fn) composition doesn\'t /tell/ much about@@ -156,43 +158,43 @@ --  markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markBDiamond = pathDiamond `bindInto` borderedPath+markBDiamond = pathDiamond `bind1` (static1 . borderedPath)   -- | Note disk is filled. -- markDisk :: (Fractional u, FromPtSize u) => LocGraphic u-markDisk = bindAsk markHalfHeight filledDisk +markDisk = bind1 (static1 markHalfHeight) filledDisk     markSquare :: (Fractional u, FromPtSize u) => LocGraphic u-markSquare = bindAsk markHeight $ \h -> +markSquare = bind1 (static1 markHeight) $ \h ->      let d = 0.5*(-h) in shiftOrigin d d $ strokedRectangle h h        markCircle :: (Fractional u, FromPtSize u) => LocGraphic u-markCircle = bindAsk markHalfHeight strokedDisk +markCircle = bind1 (static1 markHalfHeight) strokedDisk    markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u-markBCircle = bindAsk markHalfHeight borderedDisk +markBCircle = bind1 (static1 markHalfHeight) borderedDisk     markPentagon :: (Floating u, FromPtSize u) => LocGraphic u-markPentagon = bindAsk markHeight $ \h ->-    closedStroke . vertexPath . polygonPoints 5 (0.5*h)+markPentagon = bind1 (static1 markHeight) $ \h ->+    promote1 $ \pt -> closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt      markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar pt = markHeight >>= \h -> -              let ps = polygonPoints 5 (0.5*h) pt in step $ map fn ps+markStar = bind1 (static1 markHeight) $ \h -> +    promote1 $ \pt -> let ps = polygonPoints 5 (0.5*h) pt in step $ map (fn pt) ps   where-    fn p1       = openStroke $ path pt [lineTo p1] +    fn st p1    = openStroke $ primPath st [lineTo p1]      step (x:xs) = oconcat x xs     step _      = error "markStar - unreachable" @@ -200,7 +202,7 @@ -- Note - relies on the functional instance of OPlus  markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u-markAsterisk = bindAsk markHeight $ \h -> +markAsterisk = bind1 (static1 markHeight) $ \h ->      lineF1 h `oplus` lineF2 h `oplus` lineF3 h   where     ang       = (pi*2) / 6

@@ -0,0 +1,458 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.DrawingComposition+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Composition operators for Drawings.+--+-- Note - some operations can produce empty drawings...+--+--------------------------------------------------------------------------------++module Wumpus.Basic.DrawingComposition+  (+  -- * Composition+    over +  , under++  , centric+  , nextToH+  , nextToV+  +  , atPoint +  , centeredAt++  , zconcat++  , hcat +  , vcat+++  , hspace+  , vspace+  , hsep+  , vsep+ +  -- * Compose with alignment+  , alignH+  , alignV+  , alignHSep+  , alignVSep+  , hcatA+  , vcatA+  , hsepA+  , vsepA+++  ) where++import Wumpus.Basic.Graphic++import Wumpus.Core                              -- package: wumpus-core++import Data.AdditiveGroup+import Data.AffineSpace++import Data.List ( foldl' )++++--------------------------------------------------------------------------------+-- Extract anchors++boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a+boundaryExtr f = f . boundary++-- Operations on bounds++-- | The center of a picture.+--+boundaryCenter :: Fractional u => Picture u -> Point2 u+boundaryCenter = boundaryExtr center++++-- | Extract the mid point of the top edge.+--+boundaryN :: Fractional u => Picture u -> Point2 u+boundaryN = boundaryExtr north++-- | Extract the mid point of the bottom edge.+--+boundaryS :: Fractional u => Picture u -> Point2 u+boundaryS = boundaryExtr south++-- | Extract the mid point of the left edge.+--+boundaryE :: Fractional u => Picture u -> Point2 u+boundaryE = boundaryExtr east++-- | Extract the mid point of the right edge.+--+boundaryW :: Fractional u => Picture u -> Point2 u+boundaryW = boundaryExtr west+++-- | Extract the top-left corner.+--+boundaryNW :: Fractional u => Picture u -> Point2 u+boundaryNW = boundaryExtr northwest++-- | Extract the top-right corner.+--+boundaryNE :: Picture u -> Point2 u+boundaryNE = boundaryExtr ur_corner++-- | Extract the bottom-left corner.+--+boundarySW :: Picture u -> Point2 u+boundarySW = boundaryExtr ll_corner++-- | Extract the bottom-right corner.+--+boundarySE :: Fractional u => Picture u -> Point2 u+boundarySE = boundaryExtr southeast+++boundaryLeftEdge :: Picture u -> u+boundaryLeftEdge = boundaryExtr (point_x . ll_corner)++boundaryRightEdge :: Picture u -> u+boundaryRightEdge = boundaryExtr (point_x . ur_corner)++boundaryBottomEdge :: Picture u -> u+boundaryBottomEdge = boundaryExtr (point_y . ll_corner)+++boundaryTopEdge :: Picture u -> u+boundaryTopEdge = boundaryExtr (point_y . ur_corner)+++++  +-- Note - do not export the empty drawing. It is easier to +-- pretend it doesn't exist.+-- +empty_drawing :: (Real u, Floating u, FromPtSize u) => Drawing u+empty_drawing = drawTracing $ return ()++++--------------------------------------------------------------------------------+-- Composition operators++-- Note - the megaCombR operator is in some way an+-- /anti-combinator/. It seems easier to think about composing +-- drawings if we do work on the result Pictures directly rather +-- than build combinators to manipulate Drawings.+--+-- The idea of combining pre- and post- operating combinators+-- makes me worry about circular programs even though I know +-- lazy evaluation allows me to write them (in some cicumstances).+--+++-- Picture /mega-combiner/ - moves only the second argument aka the +-- right picture.+--+megaCombR :: (Num u, Ord u)+          => (Picture u -> a) -> (Picture u -> a) +          -> (a -> a -> Picture u -> Picture u) +          -> Drawing u -> Drawing u+          -> Drawing u+megaCombR qL qR trafoR = drawingConcat fn+  where+    fn pic1 pic2 = let a    = qL pic1+                       b    = qR pic2+                       p2   = trafoR a b pic2+                   in pic1 `picOver` p2+++++-- | > a `over` b+-- +-- Place \'drawing\' a over b. The idea of @over@ here is in +-- terms z-ordering, nither picture a or b are actually moved.+--+over    :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u+over    = drawingConcat picOver++++-- | > a `under` b+--+-- Similarly @under@ draws the first drawing behind +-- the second but move neither.+--+under :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u+under = flip over++++-- | Move in both the horizontal and vertical.+--+move :: (Num u, Ord u) => Vec2 u -> Drawing u -> Drawing u+move v = modifyDrawing (\p -> p `picMoveBy` v)+++++--------------------------------------------------------------------------------+-- Composition++infixr 5 `nextToV`+infixr 6 `nextToH`, `centric`+++++-- | Draw @a@, move @b@ so its center is at the same center as +-- @a@, @b@ is drawn over underneath in the zorder.+--+-- > a `centeric` b +--+--+centric :: (Fractional u, Ord u) => Drawing u -> Drawing u -> Drawing u+centric = megaCombR boundaryCenter boundaryCenter moveFun+  where+    moveFun p1 p2 pic =  let v = p1 .-. p2 in pic `picMoveBy` v++++-- | > a `nextToH` b+-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@.+-- +nextToH :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u+nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun+  where +    moveFun a b pic = pic `picMoveBy` hvec (a - b)++++-- | > a `nextToV` b+--+-- Vertical composition - move @b@, placing it below @a@.+--+nextToV :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u+nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun+  where +    moveFun a b drw = drw `picMoveBy` vvec (a - b)+++-- | Place the picture at the supplied point.+--+-- `atPoint` was previous the `at` operator.+-- +atPoint :: (Num u, Ord u) => Drawing u -> Point2 u  -> Drawing u+p `atPoint` (P2 x y) = move (V2 x y) p++++-- | Center the picture at the supplied point.+--+centeredAt :: (Fractional u, Ord u) => Drawing u -> Point2 u -> Drawing u+centeredAt d (P2 x y) = modifyDrawing fn d+  where+    fn p = let bb = boundary p+               dx = x - (boundaryWidth  bb * 0.5)+               dy = y - (boundaryHeight bb * 0.5)+           in p `picMoveBy` vec dx dy+++-- | Concatenate the list of drawings. +--+-- No pictures are moved. +--+zconcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u+zconcat []     = empty_drawing+zconcat (d:ds) = foldl' over d ds+++++-- | Concatenate the list pictures @xs@ horizontally.+-- +hcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u+hcat []     = empty_drawing+hcat (d:ds) = foldl' nextToH d ds+++-- | Concatenate the list of pictures @xs@ vertically.+--+vcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u+vcat []     = empty_drawing+vcat (d:ds) = foldl' nextToV d ds+++++--------------------------------------------------------------------------------+++++-- | > hspace n a b+--+-- Horizontal composition - move @b@, placing it to the right +-- of @a@ with a horizontal gap of @n@ separating the pictures.+--+hspace :: (Num u, Ord u) => u -> Drawing u -> Drawing u -> Drawing u+hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun+  where+    moveFun a b pic = pic `picMoveBy` hvec (n + a - b)++    ++++-- | > vspace n a b+--+-- Vertical composition - move @b@, placing it below @a@ with a+-- vertical gap of @n@ separating the pictures.+--+vspace :: (Num u, Ord u) => u -> Drawing u -> Drawing u -> Drawing u+vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun+  where +    moveFun a b pic = pic `picMoveBy`  vvec (a - b - n)++++-- | > hsep n xs+--+-- Concatenate the list of pictures @xs@ horizontally with +-- @hspace@ starting at @x@. The pictures are interspersed with +-- spaces of @n@ units.+--+hsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u+hsep _ []     = empty_drawing+hsep n (d:ds) = foldl' (hspace n) d ds++++-- | > vsep n xs+--+-- Concatenate the list of pictures @xs@ vertically with +-- @vspace@ starting at @x@. The pictures are interspersed with +-- spaces of @n@ units.+--+vsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u+vsep _ []     = empty_drawing+vsep n (d:ds) = foldl' (vspace n) d ds+++--------------------------------------------------------------------------------+-- Aligning pictures++alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u+alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2)++++-- | > alignH align a b+-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@ and align it with the top, center or bottom of @a@.+-- +alignH :: (Fractional u, Ord u) +       =>  HAlign -> Drawing u -> Drawing u -> Drawing u+alignH HTop     = megaCombR boundaryNE    boundaryNW     alignMove+alignH HCenter  = megaCombR boundaryE    boundaryW     alignMove+alignH HBottom  = megaCombR boundarySE boundarySW  alignMove+++-- | > alignV align a b+-- +-- Vertical composition - move @b@, placing it below @a@ +-- and align it with the left, center or right of @a@.+-- +alignV :: (Fractional u, Ord u) +       => VAlign -> Drawing u -> Drawing u -> Drawing u+alignV VLeft    = megaCombR boundarySW  boundaryNW   alignMove+alignV VCenter  = megaCombR boundaryS   boundaryN    alignMove+alignV VRight   = megaCombR boundarySE boundaryNE  alignMove++++alignMove2 :: (Num u, Ord u) +           => Vec2 u ->  Point2 u -> Point2 u -> Picture u -> Picture u+alignMove2 v p1 p2 pic = pic `picMoveBy` (v ^+^ (p1 .-. p2))++++-- | > alignHSep align sep a b+-- +-- Spacing version of alignH - move @b@ to the right of @a@ +-- separated by @sep@ units, align @b@ according to @align@.+-- +alignHSep :: (Fractional u, Ord u) +          => HAlign -> u -> Drawing u -> Drawing u -> Drawing u+alignHSep HTop    dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))+alignHSep HCenter dx = megaCombR boundaryE  boundaryW  (alignMove2 (hvec dx))+alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))+++-- | > alignVSep align sep a b+-- +-- Spacing version of alignV - move @b@ below @a@ +-- separated by @sep@ units, align @b@ according to @align@.+-- +alignVSep :: (Fractional u, Ord u) +          => VAlign -> u -> Drawing u -> Drawing u -> Drawing u+alignVSep VLeft   dy = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) +alignVSep VCenter dy = megaCombR boundaryS  boundaryN  (alignMove2 $ vvec (-dy)) +alignVSep VRight  dy = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy))+++-- | Variant of 'hcat' that aligns the pictures as well as+-- concatenating them.+--+hcatA :: (Real u, Floating u, FromPtSize u) +      => HAlign -> [Drawing u] -> Drawing u+hcatA _  []     = empty_drawing+hcatA ha (d:ds) = foldl' (alignH ha) d ds++++-- | Variant of 'vcat' that aligns the pictures as well as+-- concatenating them.+--+vcatA :: (Real u, Floating u, FromPtSize u) +      => VAlign -> [Drawing u] -> Drawing u+vcatA _  []     = empty_drawing+vcatA va (d:ds) = foldl' (alignV va) d ds+++-- | Variant of @hsep@ that aligns the pictures as well as+-- concatenating and spacing them.+--+hsepA :: (Real u, Floating u, FromPtSize u) +      => HAlign -> u -> [Drawing u] -> Drawing u+hsepA _  _ []     = empty_drawing+hsepA ha n (d:ds) = foldl' op d ds+  where +    a `op` b = alignHSep ha n a b +++-- | Variant of @vsep@ that aligns the pictures as well as+-- concatenating and spacing them.+--+vsepA :: (Real u, Floating u, FromPtSize u) +      => VAlign -> u -> [Drawing u] -> Drawing u+vsepA _  _ []     = empty_drawing+vsepA va n (d:ds) = foldl' op d ds+  where +    a `op` b = alignVSep va n a b +++

@@ -0,0 +1,62 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.FontLoader.AfmLoader+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Font loader for the Adobe \"Core 14\" glyph metrics.+--+-- Use this loader if you have the Adode glyph metrics set+-- (AFM v4.1). This metrics set is avaiable from the Adobe +-- website.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.FontLoader.AfmLoader+  ( ++    module Wumpus.Basic.FontLoader.Base+  , module Wumpus.Basic.FontLoader.AfmV4Dot1Parser  ++  , loadAfmMetrics+  , afmV4Dot1Loader+  ++  +  ) where++import Wumpus.Basic.FontLoader.AfmV4Dot1Parser+import Wumpus.Basic.FontLoader.Base+import Wumpus.Basic.Graphic++import Wumpus.Core                              -- package: wumpus-core++++loadAfmMetrics :: FilePath -> [FontName] -> IO BaseGlyphMetrics+loadAfmMetrics font_dir_path ns = +    loadBaseGlyphMetrics (afmV4Dot1Loader font_dir_path) ns+++afmV4Dot1Loader :: FilePath -> FontLoader AfmUnit+afmV4Dot1Loader font_dir_path = +    FontLoader +      { unit_scale_fun      = afmUnitScale+      , path_to_font_dir    = font_dir_path+      , file_name_locator   = buildName+      , font_parser         = parseAfmV4Dot1File+      , post_process        = buildGlyphMetricsTable bbox (V2 600 0) 1000+      }+  where+    buildName :: FontName -> FilePath+    buildName font = font ++ ".afm"++    bbox           = BBox (P2 (-23) (-250)) (P2 715 805)++

@@ -0,0 +1,215 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.FontLoader.AfmParserBase+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Common parsers for AFM files.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.FontLoader.AfmParserBase+  ( ++    afmFileParser+  , runQuery+  , textQuery++  , getFontBBox+  , getEncodingScheme+  , getCapHeight+  +  , charBBox+  , metric+  , keyStringPair+  , versionNumber  +  , startCharMetrics++  , keyName+  , newlineOrEOF+  , name+  , name1+  , semi+  , uptoNewline+  , number+  , cint+  , hexInt+  , octInt++  , lexeme+  , symbol+  , integer+  , int+  , double++  ) where++import Wumpus.Basic.FontLoader.Base+import Wumpus.Basic.Utils.ParserCombinators+import qualified Wumpus.Basic.Utils.TokenParsers as P++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative++import Data.Char+import qualified Data.Map               as Map++++afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile+afmFileParser pgm = do +    info <- (versionNumber    *> globalInfo) +    cms  <- (startCharMetrics *> many pgm)+    let mb_encoding = getEncodingScheme info+    let mb_cap      = getCapHeight      info+    let mb_bbox     = getFontBBox       info+    case mb_bbox of+      Nothing -> throwError "No FontBBox field in the AFM file."+      Just bb -> return $ AfmFile +                            { afm_encoding        = mb_encoding+                            , afm_font_bbox       = bb+                            , afm_cap_height      = mb_cap+                            , afm_glyph_metrics   = cms+                            }++globalInfo :: CharParser GlobalInfo+globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) +               <$> manyTill keyStringPair (peek startCharMetrics)+++ +runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a+runQuery field_name p table = +    Map.lookup field_name table >>= extr . runParser p+  where+    extr (Okay a _) = Just a+    extr _          = Nothing++textQuery :: String -> GlobalInfo -> Maybe String+textQuery = Map.lookup+++-- | Strictly speaking a fontBBox is measured in integer units.+--+getFontBBox            :: GlobalInfo -> Maybe AfmBoundingBox+getFontBBox            = runQuery "FontBBox" fontBBox++getEncodingScheme      :: GlobalInfo -> Maybe String+getEncodingScheme      = textQuery "EncodingScheme"++getCapHeight           :: GlobalInfo -> Maybe AfmUnit+getCapHeight           = runQuery "CapHeight" number+++charBBox :: CharParser AfmBoundingBox+charBBox = symbol "B" *> fontBBox <* semi++fontBBox :: CharParser AfmBoundingBox+fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury))+              <$> number <*> number <*> number <*> number++++metric :: String -> a -> CharParser a -> CharParser a+metric iden dfault p = option dfault go+  where+    go = symbol iden *> p <* semi++++keyStringPair :: CharParser (AfmKey,String)+keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF +             <?> "key-value line"++versionNumber :: CharParser String+versionNumber = +    symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF+      <?> "StartFontMetrics"+++startCharMetrics :: CharParser Int+startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF+                <?> "StartCharMetrics failed"++++--------------------------------------------------------------------------------+++keyName :: CharParser AfmKey+keyName = lexeme (many1 $ satisfy isAlphaNum) +++newlineOrEOF :: CharParser ()+newlineOrEOF = skipOne (lexeme newline) <|> eof+++uptoNewline :: CharParser String+uptoNewline = many1 (noneOf ['\n'])+++name :: CharParser String+name = lexeme $ many (noneOf ";\n")++name1 :: CharParser String+name1 = lexeme $ many (noneOf "; \t\n")++++semi :: CharParser Char+semi = lexeme $ char ';'+++++number :: CharParser AfmUnit+number = liftA realToFrac double+++cint :: CharParser Int+cint = hexInt <|> octInt <|> int+++hexInt :: CharParser Int+hexInt = lexeme $ between (char '<') (char '>') P.hexBase+++octInt :: CharParser Int+octInt = lexeme $ char '\\' *> P.octBase++++--------------------------------------------------------------------------------++-- no newline in whitespace+++lp :: P.LexemeParser+lp = P.commentLineLexemeParser "Comment" [' ', '\t']+++lexeme          :: CharParser a -> CharParser a+lexeme          = P.lexeme lp++symbol          :: String -> CharParser String+symbol          = lexeme . string++-- whiteSpace      :: CharParser ()+-- whiteSpace      = P.whiteSpace lp+++integer         :: CharParser Integer+integer         = lexeme P.integer++int             :: CharParser Int+int             = fromIntegral <$> integer++double          :: CharParser Double+double          = lexeme P.double

@@ -0,0 +1,67 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.FontLoader.AfmV2+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- AFM file parser for Version 2.0.+--+-- Note - AFM Version 2.0 used by GhostScript and Version 3.0++-- have numerous differences. +-- +--------------------------------------------------------------------------------++module Wumpus.Basic.FontLoader.AfmV2Parser+  ( ++     parseAfmV2File+  +  ) where++import Wumpus.Basic.FontLoader.AfmParserBase+import Wumpus.Basic.FontLoader.Base+import Wumpus.Basic.Utils.ParserCombinators++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+++++--------------------------------------------------------------------------------+-- parser++parseAfmV2File :: FilePath -> IO (Either ParseError AfmFile)+parseAfmV2File filepath = runParserEither p <$> readFile filepath+  where+    p = afmFileParser charMetricsV2+++charMetricsV2 :: CharParser AfmGlyphMetrics+charMetricsV2 = AfmGlyphMetrics <$>+        metric "C" (-1) cint+    <*> widthVector+    <*> metric "N" "" name1+    <*  charBBox+    <*  many (symbol "L" *> ligature_body <* semi)+    <*  newlineOrEOF+  where+    ligature_body = ((,) <$> name <*> name)+    +widthVector :: CharParser (Vec2 AfmUnit)+widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)+           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)+++--------------------------------------------------------------------------------++++

@@ -0,0 +1,67 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.FontLoader.AfmV4Dot1Parser+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- AFM file parser for Version 4.1.+--+-- Adobe distributes font metrics for the /Core 14/ fonts as+-- AFM Version 4.1 files.  +--+--------------------------------------------------------------------------------++module Wumpus.Basic.FontLoader.AfmV4Dot1Parser+  ( +    +    parseAfmV4Dot1File+  +  ) where++import Wumpus.Basic.FontLoader.AfmParserBase+import Wumpus.Basic.FontLoader.Base+import Wumpus.Basic.Utils.ParserCombinators++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+++parseAfmV4Dot1File :: FilePath -> IO (Either ParseError AfmFile)+parseAfmV4Dot1File filepath = runParserEither p <$> readFile filepath+  where+    p = afmFileParser charMetricsV4Dot1++++charMetricsV4Dot1 :: CharParser AfmGlyphMetrics+charMetricsV4Dot1 = AfmGlyphMetrics <$>+        characterCode+    <*> widthVector+    <*> metric "N" "" name1+    <*  charBBox+    <*  many (symbol "L" *> ligature_body <* semi)+    <*  newlineOrEOF+  where+    ligature_body = ((,) <$> name <*> name)+++-- Note - there are many variants for width vectors in in 4.1.+-- Wumpus needs some thought about what to do for them, it also+-- needs some facility to tell how successful the parse has been.+    +widthVector :: CharParser (Vec2 AfmUnit)+widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)+           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)+++-- V4.1 allows C int or CH \<hex\>+--+characterCode :: CharParser Int+characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint  

@@ -0,0 +1,222 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.FontLoader.AfmV2+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- AFM file parser.+--+-- Note - AFM Version 2.0 used by GhostScript and Version 3.0++-- have numerous differences. +-- +--------------------------------------------------------------------------------++module Wumpus.Basic.FontLoader.Base+  (++  -- * Afm Unit+    AfmUnit+  , afmValue+  , afmUnitScale+  +  -- * Glyph metrics++  , PSCharCode+  , PSEncodingScheme+  , AfmBoundingBox++  , AfmKey+  , GlobalInfo+  , AfmFile(..)+  , AfmGlyphMetrics(..)++  -- * Font loading+  , FontLoadErr+  , FontLoadResult+  , FontLoader(..)+  , loadFont++  , BaseGlyphMetrics+  , loadBaseGlyphMetrics++  , buildGlyphMetricsTable++  ) where++import Wumpus.Basic.Graphic+++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Text.GlyphIndices++import Data.Foldable ( foldrM )+import qualified Data.IntMap            as IntMap+import qualified Data.Map as Map+import Data.Maybe++import System.Directory+import System.FilePath++++-- | Wrapped Double representing 1\/1000 of the scale factor+-- (Point size) of a font. AFM files encode all measurements +-- as these units. +-- +newtype AfmUnit = AfmUnit { getAfmUnit :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)++instance Show AfmUnit where+  showsPrec p d = showsPrec p (getAfmUnit d)+++-- | Compute the size of a measurement in Afm units scaled by the+-- point size of the font.+--+afmValue :: FromPtSize u => AfmUnit -> PtSize -> u+afmValue u pt = fromPtSize $ (realToFrac $ getAfmUnit u) * (pt / 1000)++afmUnitScale :: AfmUnit -> PtSize +afmUnitScale u = (realToFrac $ getAfmUnit u / 1000)+++--------------------------------------------------------------------------------++-- | Afm files index glyphs by /PostScript character code/. This +-- is not the same as Unicode, ASCII...+--+-- It is expected to be determined by @EncodingScheme@ in the+-- Global Font Information Section.+--+type PSCharCode         = Int++type PSEncodingScheme   = String++type AfmBoundingBox     = BoundingBox AfmUnit++type AfmKey         = String+type GlobalInfo     = Map.Map AfmKey String++++-- | Wumpus needs a very small subset of AFM files, common to both+-- version 2.0 and version 4.1.+--+-- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1+-- +-- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus +-- uses cap height in calculations, glyph metrics must be build +-- with an arbitrary value if it is not present.+--+-- Encoding Scheme is optional in AFM files.+--+data AfmFile = AfmFile +      { afm_encoding        :: Maybe String+      , afm_font_bbox       :: AfmBoundingBox+      , afm_cap_height      :: Maybe AfmUnit+      , afm_glyph_metrics   :: [AfmGlyphMetrics]+      }+  deriving (Show) ++-- Note BBox is a required field for version 4.1.+++data AfmGlyphMetrics = AfmGlyphMetrics+      { afm_char_code       :: !PSCharCode+      , afm_width_vector    :: !(Vec2 AfmUnit)+      , afm_char_name       :: !String+      }+  deriving (Eq,Show)++++-- Maybe the CharMetricsTable should be scaled to Wumpus units as +-- the last part of the parsing process...+--+-- No it shouldn\'t - this would disallow drawings in centimeters+-- ++type FontLoadErr        = String+type FontLoadResult cu  = Either FontLoadErr (GlyphMetricsTable cu)++data FontLoader cu = forall interim. FontLoader +      { unit_scale_fun      :: cu -> PtSize+      , path_to_font_dir    :: FilePath+      , file_name_locator   :: FontName -> FilePath+      , font_parser         :: FilePath -> IO (Either String interim)+      , post_process        :: interim -> GlyphMetricsTable cu+      }+++loadFont :: FontLoader cu -> FontName -> IO (FontLoadResult cu)+loadFont loader font_name = +    locateStep loader font_name >>= \ans -> case ans of+      Nothing        -> return $ Left $ "Cannot find font " ++ font_name+      Just full_path -> parseStep loader full_path++locateStep :: FontLoader cu -> FontName -> IO (Maybe FilePath)+locateStep loader font_name = +    doesFileExist full_path >>= \check -> +    if check then return $ Just full_path+             else return $ Nothing+  where+    full_path = normalise $ path_to_font_dir loader +                             </> file_name_locator loader font_name+++parseStep :: FontLoader cu -> FilePath -> IO (FontLoadResult cu)+parseStep (FontLoader _ _ _ parser post) valid_path = +    fmap (either Left (Right . post)) $ parser valid_path++--------------------------------------------------------------------------------++++loadBaseGlyphMetrics :: FontLoader u -> [FontName] -> IO BaseGlyphMetrics+loadBaseGlyphMetrics loader xs = foldrM fn Map.empty xs+  where+    fn font_name acc = loadFont loader font_name >>= \ans -> +                       case ans of+                         Left err -> reportBaseError font_name err >> return acc+                         Right table -> return $ +                             Map.insert font_name (tableToGM table) acc++    tableToGM = buildMetrics (unit_scale_fun loader)  +    +reportBaseError :: FontName -> FontLoadErr -> IO ()+reportBaseError font_name err = do +    putStrLn $ "The font " ++ font_name ++ " failed to load, with the error:"+    putStrLn $ err+++++buildGlyphMetricsTable :: BoundingBox AfmUnit +                       -> Vec2 AfmUnit +                       -> AfmUnit+                       -> AfmFile +                       -> GlyphMetricsTable AfmUnit+buildGlyphMetricsTable bbox dflt_vec dflt_cap_height afm = +    GlyphMetricsTable +      { glyph_bounding_box    = bbox+      , glyph_default_adv_vec = dflt_vec+      , glyph_adv_vecs        = makeAdvVecs $ afm_glyph_metrics afm+      , glyph_cap_height      = fromMaybe dflt_cap_height $ afm_cap_height afm+      }  +++makeAdvVecs :: [AfmGlyphMetrics] -> IntMap.IntMap (Vec2 AfmUnit)+makeAdvVecs  = foldr fn IntMap.empty+  where+    fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of+        Nothing -> table+        Just i  -> IntMap.insert i v table+

@@ -0,0 +1,87 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.FontLoader.GSFontMap+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- GhostScript Font map.+--+-- GhostScript aliases the /Core 14/ PostScript fonts to fonts+-- it can freely distribute. This module provides aliases to +-- Wumpus so the font loader can find the equivalent GhostScript+-- files to the Core 14 set.+--+-- The data in this file matches GhostScript 8.63. Other versions+-- of GhostScript may need different aliases.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.FontLoader.GSFontMap+  (+   +    ghostscript_version  ++  , GSFontMap+  , gsMetricsFile+  , gsFontAlias+  , core14_alias_table++  ) where+++import Data.Map ( Map )+import qualified Data.Map as Map+++-- | GhostScript version that the aliases were derived from.+-- +ghostscript_version :: String+ghostscript_version = "gs8.54"++type GSFontMap = Map String (String, FilePath)+++-- | Get the @.afm@ metrics file.+--+-- Note this return only the file name and not the path to it.+-- The full path must be resolved in client code.+--+gsMetricsFile :: GSFontMap -> String -> Maybe FilePath+gsMetricsFile mp name = fmap snd $ Map.lookup name mp++-- | Get the GhostScript font name alias.+--+gsFontAlias :: GSFontMap -> String -> Maybe String+gsFontAlias mp name = fmap fst $ Map.lookup name mp++-- | Map from PostScript font name to the corresponding +-- GhostScript name and file.+--+core14_alias_table :: GSFontMap+core14_alias_table = Map.fromList $ +  [ ("Courier",                 ("NimbusMonL-Regu",         "n022003l.afm"))+  , ("Courier-Oblique",         ("NimbusMonL-ReguObli",     "n022023l.afm"))+  , ("Courier-Bold",            ("NimbusMonL-Bold",         "n022004l.afm"))+  , ("Courier-BoldOblique",     ("NimbusMonL-BoldObli",     "n022024l.afm"))+  +  , ("Helvetica",               ("NimbusSanL-Regu",         "n019003l.afm"))+  , ("Helvetica-Oblique",       ("NimbusSanL-ReguItal",     "n019023l.afm"))+  , ("Helvetica-Bold",          ("NimbusSanL-Bold",         "n019004l.afm"))+  , ("Helvetica-BoldOblique",   ("NimbusSanL-BoldItal",     "n019024l.afm"))++  , ("Times-Roman",             ("NimbusRomNo9L-Regu",      "n021003l.afm"))+  , ("Times-Italic",            ("NimbusRomNo9L-ReguItal",  "n021023l.afm"))+  , ("Times-Bold",              ("NimbusRomNo9L-Medi",      "n021004l.afm"))+  , ("Times-BoldItalic",        ("NimbusRomNo9L-MediItal",  "n021024l.afm"))++  , ("Symbol",                  ("StandardSymL",            "s050000l.afm"))++  , ("ZapfDingbats",            ("Dingbats",                "d050000l.afm"))+  ]+

@@ -0,0 +1,63 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.FontLoader.GSLoader+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Font loader for GhostScript glyph metrics.+--+-- Use this loader if you have GhostScript installed and you want +-- to use the (AFM v2.0) metrics that are distributed with +-- GhostScript.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.FontLoader.GSLoader+  ( ++    module Wumpus.Basic.FontLoader.Base+  , module Wumpus.Basic.FontLoader.AfmV2Parser  ++  , loadGSMetrics+  , gsFontLoader+  ++  +  ) where++import Wumpus.Basic.FontLoader.AfmV2Parser+import Wumpus.Basic.FontLoader.Base+import Wumpus.Basic.FontLoader.GSFontMap+import Wumpus.Basic.Graphic++import Wumpus.Core                              -- package: wumpus-core++import Data.Maybe+++loadGSMetrics :: FilePath -> [FontName] -> IO BaseGlyphMetrics+loadGSMetrics font_dir_path ns = +    loadBaseGlyphMetrics (gsFontLoader font_dir_path) ns+    ++gsFontLoader :: FilePath -> FontLoader AfmUnit+gsFontLoader font_dir_path = FontLoader+      { unit_scale_fun      = afmUnitScale+      , path_to_font_dir    = font_dir_path+      , file_name_locator   = buildName+      , font_parser         = parseAfmV2File+      , post_process        = buildGlyphMetricsTable bbox (V2 600 0) 1000+      }+  where+    buildName :: FontName -> FilePath+    buildName font = fromMaybe font $ gsMetricsFile core14_alias_table font++    bbox           = BBox (P2 (-23) (-250)) (P2 715 805)++

@@ -17,17 +17,27 @@  module Wumpus.Basic.Graphic   (-    module Wumpus.Basic.Graphic.Base+    module Wumpus.Basic.Graphic.Anchors+  , module Wumpus.Basic.Graphic.Base+  , module Wumpus.Basic.Graphic.ContextFunction   , module Wumpus.Basic.Graphic.Drawing   , module Wumpus.Basic.Graphic.DrawingContext-  , module Wumpus.Basic.Graphic.PrimGraphic+  , module Wumpus.Basic.Graphic.GlyphMetrics+  , module Wumpus.Basic.Graphic.GraphicOperations+  , module Wumpus.Basic.Graphic.GraphicTypes   , module Wumpus.Basic.Graphic.Query   , module Wumpus.Basic.Graphic.ScalingContext+  , module Wumpus.Basic.Graphic.TraceDrawing   ) where  import Wumpus.Basic.Graphic.Base+import Wumpus.Basic.Graphic.Anchors+import Wumpus.Basic.Graphic.ContextFunction import Wumpus.Basic.Graphic.Drawing import Wumpus.Basic.Graphic.DrawingContext-import Wumpus.Basic.Graphic.PrimGraphic+import Wumpus.Basic.Graphic.GlyphMetrics+import Wumpus.Basic.Graphic.GraphicOperations+import Wumpus.Basic.Graphic.GraphicTypes import Wumpus.Basic.Graphic.Query import Wumpus.Basic.Graphic.ScalingContext+import Wumpus.Basic.Graphic.TraceDrawing

@@ -0,0 +1,158 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.Anchors+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Anchor points on shapes.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.Anchors+  ( ++  -- * Anchors+    CenterAnchor(..)+  , CardinalAnchor(..)+  , CardinalAnchor2(..)+  , RadialAnchor(..)++  -- * Extended anchor points+  , northwards+  , southwards+  , eastwards+  , westwards+  , northeastwards+  , southeastwards+  , southwestwards+  , northwestwards++  , radialConnectorPoints++  ) where++import Wumpus.Core                      -- package: wumpus-core++import Data.AffineSpace                 -- package: vector-space++class CenterAnchor t where+  center :: DUnit t ~ u => t -> Point2 u++-- | Note - in TikZ cardinal anchors are not necessarily at the+-- equivalent radial position, for instance reactangle north-east+-- is the top-right corner whether or not this is incident at +-- 45deg.+--+class CardinalAnchor t where+  north :: DUnit t ~ u => t -> Point2 u+  south :: DUnit t ~ u => t -> Point2 u+  east  :: DUnit t ~ u => t -> Point2 u+  west  :: DUnit t ~ u => t -> Point2 u++class CardinalAnchor2 t where+  northeast :: DUnit t ~ u => t -> Point2 u+  southeast :: DUnit t ~ u => t -> Point2 u+  southwest :: DUnit t ~ u => t -> Point2 u+  northwest :: DUnit t ~ u => t -> Point2 u+++-- | Anchor on a border that can be identified with and angle.+--+class RadialAnchor t where+  radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u+++extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u+extendPtDist d p1 p2 = let v   = pvec p1 p2+                           ang = direction v+                           len = vlength v+                       in p1 .+^ avec ang (len+d)++++northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t+              , u ~ DUnit t ) +           => u -> t -> Point2 u+northwards u a = extendPtDist u (center a) (north a)+++southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t+              , u ~ DUnit t ) +           => u -> t -> Point2 u+southwards u a = extendPtDist u (center a) (south a)++eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t+             , u ~ DUnit t ) +          => u -> t -> Point2 u+eastwards u a = extendPtDist u (center a) (east a)++westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t+             , u ~ DUnit t ) +          => u -> t -> Point2 u+westwards u a = extendPtDist u (center a) (west a)+++northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t+                  , u ~ DUnit t ) +               => u -> t -> Point2 u+northeastwards u a = extendPtDist u (center a) (northeast a)+++southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t+                  , u ~ DUnit t ) +               => u -> t -> Point2 u+southeastwards u a = extendPtDist u (center a) (southeast a)++southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t+                  , u ~ DUnit t ) +               => u -> t -> Point2 u+southwestwards u a = extendPtDist u (center a) (southwest a)++northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t+                  , u ~ DUnit t ) +               => u -> t -> Point2 u+northwestwards u a = extendPtDist u (center a) (northwest a)+++--------------------------------------------------------------------------------++radialConnectorPoints :: ( Real u, Floating u+                         , CenterAnchor t1, RadialAnchor t1+                         , CenterAnchor t2, RadialAnchor t2+                         , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) +                      => t1 -> t2 -> (Point2 u, Point2 u) +radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b)+  where+    theta = direction $ pvec (center a) (center b)+    ++--------------------------------------------------------------------------------+-- Instances ++instance Fractional u => CenterAnchor (BoundingBox u) where+  center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y +     where+       x = xl+0.5*(xr-xl)+       y = ylo+0.5*(yhi-ylo)+       ++instance Fractional u => CardinalAnchor (BoundingBox u) where+  north (BBox (P2 xl _  ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi+  south (BBox (P2 xl ylo) (P2 xr _  )) = P2 (xl+0.5*(xr-xl)) ylo+  east  (BBox (P2 _  ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo))+  west  (BBox (P2 xl ylo) (P2 _  yhi)) = P2 xl (ylo+0.5*(yhi-ylo))+++instance Fractional u => CardinalAnchor2 (BoundingBox u) where+  northeast (BBox _ ur)                 = ur+  southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo+  southwest (BBox ll _)                 = ll+  northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi +

@@ -13,32 +13,12 @@ -- Stability   :  highly unstable -- Portability :  GHC  ----- Base types for Drawing Objects, Graphics / Images (a Graphic --- that also returns an answer), etc.+-- The common base drawing objects in Wumpus-Basic - a +-- semigroup class, monad classes (TraceM analogue to Writer,+-- DrawingCtxM analogue to Reader), a wrapped Hughes list of+-- primitives.  -- --- Base classes for monadic drawing. ----- Notes on prefix and suffix names:------ Function types suffixed @F@ are functions from same-to-same, e.g.:------ > type Point2F u = Point2 u -> Point2 u------ Functional types subfixed @R@ are functions from some static --- context to the answer type (c.f the ReaderMonad), e.g.:------ > newtype DrawingR a = DrawingR { getDrawingR :: DrawingContext -> a }------ The suffix @M@ is used for classes defining monadic actions.------ The prefix @Loc@ indicates a functional type --- /from Point2 to something.../--- --- The prefix @ThetaLoc@ indicates a functional type --- /from Direction (radian) then Point to something.../------ \*\* WARNING \*\* - some names are expected to change.--- --------------------------------------------------------------------------------  module Wumpus.Basic.Graphic.Base@@ -50,6 +30,10 @@   , anterior       , superior +  -- * Alignment.+  , HAlign(..)+  , VAlign(..)  +   -- * Drawing monads.   , MonUnit   , TraceM(..)@@ -64,75 +48,14 @@   , hprimToList   , singleH -  , Point2F-  , DPoint2F--  , DrawingR-  , LocDrawingR-  , DLocDrawingR--  , DrawingTrafoF --  , runDrawingR-   , PrimGraphic   , getPrimGraphic-  , wrapPrim-+  , primGraphic   , collectH -  , Graphic-  , DGraphic-  , GraphicTrafoF--  , superiorGraphic-  , anteriorGraphic  --  , runGraphic-  , xlinkGraphic--  , LocGraphic-  , DLocGraphic--  , Image-  , DImage--  , ImageTrafoF-  , intoImageTrafo-  , imageTrafoDrawing-  , imageTrafoGraphic--  , LocImage-  , DLocImage--  , runImage-  , intoImage-  , intoLocImage-  , xlinkImage--  , ConnectorDrawingR-  , DConnectorDrawingR-  , ConnectorGraphic-  , DConnectorGraphic-  , ConnectorImage-  , DConnectorImage--  , intoConnectorImage--  , ThetaLocDrawingR-  , DThetaLocDrawingR-  , ThetaLocGraphic-  , DThetaLocGraphic-  , ThetaLocImage-  , DThetaLocImage--  , intoThetaLocImage--   ) where  import Wumpus.Basic.Graphic.DrawingContext-import Wumpus.Basic.Utils.Combinators import Wumpus.Basic.Utils.HList  import Wumpus.Core                      -- package: wumpus-core@@ -165,12 +88,8 @@   --- Note - this produces tall-skinny trees in Wumpus-core.--- This does not impact on the generated PostScript but it is --- (probably) inefficient for traversals in Wumpus.------ There is scope to modify the Primitive type in Wumpus-Core --- (make Group indepenent of XLink) so wider trees can be made.+instance Ord u => OPlus (BoundingBox u) where+  oplus = boundaryUnion  instance OPlus (Primitive u) where   a `oplus` b = primGroup [a,b]@@ -187,6 +106,21 @@   --------------------------------------------------------------------------------++-- Alignment++-- | Horizontal alignment - align to the top, center or bottom.+data HAlign = HTop | HCenter | HBottom+  deriving (Enum,Eq,Ord,Show)++-- | Vertical alignment - align to the left, center or bottom.+data VAlign = VLeft | VCenter | VRight+  deriving (Enum,Eq,Ord,Show)+++++-------------------------------------------------------------------------------- -- Monadic drawing  -- | DUnit is always for fully saturated type constructors, so @@ -214,9 +148,6 @@   --- -- | A monad that supplies points, e.g. a turtle monad.  -- class Monad m => PointSupplyM (m :: * -> *) where@@ -224,7 +155,7 @@    ----------------------------------------------------------------------------------- Base types+-- Lists of primitives...  -- | Graphics objects, even simple ones (line, arrow, dot) might  -- need more than one primitive (path or text label) for their@@ -257,86 +188,6 @@ singleH :: Primitive u -> HPrim u singleH = HPrim . wrapH  --- | Point transformation function.----type Point2F u = Point2 u -> Point2 u--type DPoint2F = Point2F Double----------------------------------------------------------------------------------------- | Drawings in Wumpus-Basic have an implicit /graphics state/ --- the @DrawingContext@, the most primitive building block is --- a function from the DrawingContext to some polymorphic answer.--- --- This functional type is represented concretely as @DrawingR@.--- --- > DrawingR :: DrawingContext -> a ----newtype DrawingR a = DrawingR { getDrawingR :: DrawingContext -> a }---instance Functor DrawingR where-  fmap f ma = DrawingR $ \ctx -> f $ getDrawingR ma ctx ---instance OPlus a => OPlus (DrawingR a)  where-  fa `oplus` fb = DrawingR $ \ctx -> -                      getDrawingR fa ctx `oplus` getDrawingR fb ctx---- The monoid instance seems sensible...----instance Monoid a => Monoid (DrawingR a) where -  mempty          = DrawingR $ \_   -> mempty-  fa `mappend` fb = DrawingR $ \ctx -> -                      getDrawingR fa ctx `mappend` getDrawingR fb ctx---- Applicative--instance Applicative DrawingR where-  pure a    = DrawingR $ \_   -> a-  mf <*> ma = DrawingR $ \ctx -> let f = getDrawingR mf ctx-                                     a = getDrawingR ma ctx-                                 in f a---- Monad --instance Monad DrawingR where-  return a  = DrawingR $ \_   -> a-  ma >>= k  = DrawingR $ \ctx -> let a = getDrawingR ma ctx-                                 in (getDrawingR . k) a ctx ---instance DrawingCtxM DrawingR where-  askDC           = DrawingR $ \ctx -> ctx-  localize upd df = DrawingR $ \ctx -> getDrawingR df (upd ctx)-  ---- | Run a /Drawing Function/ with the supplied /Drawing Context/.----runDrawingR :: DrawingContext -> DrawingR a -> a-runDrawingR ctx df = getDrawingR df ctx-----type LocDrawingR u a = Point2 u -> DrawingR a --type DLocDrawingR a = LocDrawingR Double a---type DrawingTrafoF a = DrawingR a -> DrawingR a------- Affine instances - cannot be manufactured. There is no --- DUnit @u@ to get a handle on.-------------------------------------------------------------------------------------- -- As of version 0.36.0, Wumpus-Core supports grouping primitives -- together (a common operation in vector drawing editors).  --@@ -373,204 +224,9 @@   translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic  -wrapPrim :: Primitive u -> PrimGraphic u -wrapPrim = PrimGraphic+primGraphic :: Primitive u -> PrimGraphic u +primGraphic = PrimGraphic  collectH :: PrimGraphic u -> HPrim u collectH = singleH . getPrimGraphic-------------------------------------------------------------------------------------- Simple drawing - produce a primitive, access the DrawingContext--- if required.--type Graphic u = DrawingR (PrimGraphic u)--type DGraphic = Graphic Double--type instance DUnit (Graphic u) = u---runGraphic :: DrawingContext -> Graphic u -> PrimGraphic u-runGraphic ctx gf = (getDrawingR gf) ctx---xlinkGraphic :: XLink -> Graphic u -> Graphic u-xlinkGraphic xlink gf = DrawingR $ \ctx -> -    let a = runGraphic ctx gf -    in PrimGraphic $ xlinkGroup xlink [getPrimGraphic a]----- Affine instances--instance (Real u, Floating u) => Rotate (Graphic u) where-  rotate ang = liftA (rotate ang) ---instance (Real u, Floating u) => RotateAbout (Graphic u) where-  rotateAbout ang pt = liftA (rotateAbout ang pt)---instance Num u => Scale (Graphic u) where-  scale sx sy = liftA (scale sx sy)---instance Num u => Translate (Graphic u) where-  translate dx dy = liftA (translate dx dy)-----type GraphicTrafoF u = Graphic u -> Graphic u--anteriorGraphic :: Graphic u -> GraphicTrafoF u-anteriorGraphic = anterior--superiorGraphic :: Graphic u -> GraphicTrafoF u-superiorGraphic = superior------------------------------------------------------------------------------------------ | Commonly graphics take a start point as well as a drawing --- context.--- --- Here they are called a LocGraphic - graphic with a (starting) --- location.----type LocGraphic u = Point2 u -> Graphic u--type DLocGraphic = LocGraphic Double------------------------------------------------------------------------------------------ | Images return a value as well as drawing. A /node/ is a --- typical example - nodes are drawing but the also support --- taking anchor points.----type Image u a = DrawingR (a, PrimGraphic u)--type DImage a = Image Double a--type instance DUnit (Image u a) = u----runImage :: DrawingContext -> Image u a -> (a, PrimGraphic u)-runImage ctx img = (getDrawingR img) ctx---intoImage :: DrawingR a -> Graphic u -> Image u a-intoImage f g = forkA f g----- Affine instances--instance (Real u, Floating u, Rotate a, DUnit a ~ u) => -    Rotate (Image u a) where-  rotate ang = liftA (prod (rotate ang) (rotate ang))---instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => -    RotateAbout (Image u a) where-  rotateAbout ang pt = liftA (prod (rotateAbout ang pt) (rotateAbout ang pt))---instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where-  scale sx sy = liftA (prod (scale sx sy) (scale sx sy))---instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where-  translate dx dy = liftA (prod (translate dx dy) (translate dx dy))----type ImageTrafoF u a = Image u a -> Image u a-----intoImageTrafo :: DrawingTrafoF a -> GraphicTrafoF u -> ImageTrafoF u a-intoImageTrafo df gf img = img >>= \(a,prim) -> -    intoImage (df $ pure a) (gf $ pure prim)--imageTrafoDrawing :: DrawingTrafoF a -> ImageTrafoF u a-imageTrafoDrawing df = intoImageTrafo df id--imageTrafoGraphic :: GraphicTrafoF u -> ImageTrafoF u a-imageTrafoGraphic gf = intoImageTrafo id gf----type LocImage u a = Point2 u -> Image u a--type DLocImage a = LocImage Double a--intoLocImage :: LocDrawingR u a -> LocGraphic u -> LocImage u a-intoLocImage f g pt = forkA (f pt) (g pt)---xlinkImage :: XLink -> Image u a -> Image u a-xlinkImage xlink img = DrawingR $ \ctx -> -    let (a,pg) = runImage ctx img -    in (a, PrimGraphic $ xlinkGroup xlink [getPrimGraphic pg])---------------------------------------------------------------------------------------type ConnectorDrawingR u a = Point2 u -> Point2 u -> DrawingR a--type DConnectorDrawingR a = ConnectorDrawingR Double a---- | ConnectorGraphic is a connector drawn between two points --- contructing a Graphic.----type ConnectorGraphic u = Point2 u -> Point2 u -> Graphic u--type DConnectorGraphic = ConnectorGraphic Double---- | ConnectorImage is a connector drawn between two points --- constructing an Image.------ Usually the answer type of a ConnectorImage will be a Path so--- the Points ar @midway@, @atstart@ etc. can be taken on it.----type ConnectorImage u a = Point2 u -> Point2 u -> Image u a--type DConnectorImage a = ConnectorImage Double a---intoConnectorImage :: ConnectorDrawingR u a -                   -> ConnectorGraphic u -                   -> ConnectorImage u a-intoConnectorImage f g p1 p2 = forkA (f p1 p2) (g p1 p2)---type ThetaLocDrawingR u a = Radian -> LocDrawingR u a --type DThetaLocDrawingR a = ThetaLocDrawingR Double a---- | A function from /Radian -\> Point -\> Graphic/...----type ThetaLocGraphic u = Radian -> LocGraphic u--type DThetaLocGraphic = ThetaLocGraphic Double--type ThetaLocImage u a = Radian -> LocImage u a--type DThetaLocImage a = ThetaLocImage Double a ---intoThetaLocImage :: ThetaLocDrawingR u a -                  -> ThetaLocGraphic u -                  -> ThetaLocImage u a-intoThetaLocImage f g theta pt = forkA (f theta pt) (g theta pt) - 

@@ -0,0 +1,718 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.ContextFunction+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- The primary drawing type and base combinators to manipulate it. +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.ContextFunction+  (++    CF++  , LocCF+  , LocThetaCF+  , ConnectorCF+  , DLocCF+  , DLocThetaCF+  , DConnectorCF++++  -- * Run functions+  , runCF++  -- * Extractors+  , drawingCtx+  , queryCtx+  , locCtx+  , locPoint+  , locThetaCtx+  , locThetaPoint+  , locThetaAng+  , connCtx+  , connStart+  , connEnd++  -- * Reducers+  , unLoc+  , unTheta+  , unLocTheta+  , unConnector++  , unCF1+  , unCF2++  -- * Combinators+  , wrap+  , wrap1+  , wrap2++  , promote1+  , promote2++  , raise+  , raise1+  , raise2++  , static1 +  , static2+  , dblstatic++  , bind+  , bind1+  , bind2+++  , situ1+  , situ2++  , apply+  , apply1+  , apply2++  -- * Pre-transformers+  , prepro1+  , prepro2+  , prepro2a+  , prepro2b++  -- * Post-transformers+  , postpro+  , postpro1+  , postpro2++  -- * Post-combiners+  , postcomb+  , postcomb1+  , postcomb2++  , accumulate1+  , accumulate2+++  ) where++-- import Wumpus.Basic.Graphic.Anchors+import Wumpus.Basic.Graphic.Base+import Wumpus.Basic.Graphic.DrawingContext++import Wumpus.Core                      -- package: wumpus-core+++import Control.Applicative+import Data.Monoid+++--------------------------------------------------------------------------------+--++-- | Most drawing operations in Wumpus-Basic have an implicit +-- /graphics state/ the @DrawingContext@, so the most primitive +-- building block is a function from the DrawingContext to some +-- polymorphic answer.+-- +-- This functional type is represented concretely as the initials +-- @CF@ for /contextual function/.+-- +-- > CF :: DrawingContext -> a +--+newtype CF a = CF { getCF :: DrawingContext -> a }+++type LocCF          u a = CF (Point2 u -> a)++type LocThetaCF     u a = LocCF u (Radian -> a)++type ConnectorCF    u a = LocCF u (Point2 u -> a)++++type DLocCF a           = LocCF       Double a+type DLocThetaCF a      = LocThetaCF  Double a+type DConnectorCF a     = ConnectorCF Double a++++--------------------------------------------------------------------------------+-- Drawing instances++instance Functor CF where+  fmap f ma = CF $ \ctx -> f $ getCF ma ctx +++instance OPlus a => OPlus (CF a)  where+  fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx++-- The monoid instance seems sensible...+--+instance Monoid a => Monoid (CF a) where +  mempty          = CF $ \_   -> mempty+  fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx++-- Applicative++instance Applicative CF where+  pure a    = CF $ \_   -> a+  mf <*> ma = CF $ \ctx -> let f = getCF mf ctx+                               a = getCF ma ctx+                           in f a+-- Monad ++instance Monad CF where+  return a  = CF $ \_   -> a+  ma >>= k  = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx +++instance DrawingCtxM CF where+  askDC           = CF $ \ctx -> ctx+  localize upd df = CF $ \ctx -> getCF df (upd ctx)+  ++++--------------------------------------------------------------------------------+-- Run functions++++-- | Run a /CF/ (context function) with the supplied /DrawingContext/.+--+runCF :: DrawingContext -> CF a -> a+runCF ctx df = getCF df ctx+++--------------------------------------------------------------------------------+-- extractors ++-- | Extract the drawing context from a CtxFun.+--+-- > (ctx -> ctx)+-- +drawingCtx      :: CF DrawingContext+drawingCtx      = CF $ \ctx -> ctx++-- | Apply the projection function to the drawing context.+--+-- > (ctx -> a) -> (ctx -> a)+--+queryCtx        :: (DrawingContext -> a) -> CF a+queryCtx f      = CF $ \ctx -> f ctx+++-- | Extract the drawing context from a LocCF.+--+-- > (ctx -> pt -> ctx)+--+locCtx          :: LocCF u DrawingContext+locCtx          = CF $ \ctx _  -> ctx++-- | Extract the /start/ point from a LocCF.+--+-- > (ctx -> pt -> pt)+--+locPoint        :: LocCF u (Point2 u)+locPoint        = CF $ \_ pt -> pt+++-- | Extract the drawing context from a LocThetaCF.+--+-- > (ctx -> pt -> ang -> ctx)+--+locThetaCtx     :: LocThetaCF u DrawingContext+locThetaCtx     = CF $ \ctx _ _ -> ctx+++-- | Extract the /start/ point from a LocThetaCF.+--+-- > (ctx -> pt -> ang -> pt)+--+locThetaPoint   :: LocThetaCF u (Point2 u)+locThetaPoint   = CF $ \_ pt _ -> pt++-- | Extract the angle from a LocThetaCF.+--+-- > (ctx -> pt -> ang -> ang)+--+locThetaAng     :: LocThetaCF u Radian+locThetaAng     = CF $ \_ _ ang -> ang++-- | Extract the drawing context from a ConnectorCF.+--+-- > (ctx -> pt1 -> pt2 -> ctx)+--+connCtx         :: ConnectorCF u DrawingContext+connCtx         = CF $ \ctx _ _ -> ctx++-- | Extract the start point from a ConnectorCF.+--+-- > (ctx -> pt1 -> pt2 -> pt1)+--+connStart       :: ConnectorCF u (Point2 u) +connStart       = CF $ \_ pt _ -> pt++-- | Extract the end point from a ConnectorCF.+--+-- > (ctx -> pt1 -> pt2 -> pt2)+--+connEnd         :: ConnectorCF u (Point2 u) +connEnd         = CF $ \_ _ pt -> pt+++--------------------------------------------------------------------------------+-- /Reducers/++-- | This is unCF1 at a specific type.+--+unLoc :: Point2 u -> LocCF u a -> CF a+unLoc pt mf = CF $ \ctx -> getCF mf ctx pt++unTheta :: Radian -> LocThetaCF u a -> LocCF u a+unTheta theta mf = CF $ \ctx pt -> getCF mf ctx pt theta++unLocTheta :: Point2 u -> Radian -> LocThetaCF u a -> CF a+unLocTheta pt theta mf = CF $ \ctx -> getCF mf ctx pt theta++unConnector :: Point2 u -> Point2 u -> ConnectorCF u a -> CF a+unConnector p0 p1 mf = CF $ \ctx -> getCF mf ctx p0 p1+++unCF1 :: r1 -> CF (r1 -> a) -> CF a+unCF1 a mf = CF $ \ctx -> getCF mf ctx a++unCF2 :: r1 -> r2 ->  CF (r1 -> r2 -> a) -> CF a+unCF2 a b mf = CF $ \ctx -> getCF mf ctx a b+++++--------------------------------------------------------------------------------+-- Combinators++-- | Lift a pure value into a Context functional. The +-- DrawingContext is ignored.+--+-- > ans -> (ctx -> ans)+--+-- Without any other arguments, this is the same as the 'raise' +-- combinator for raising into the Context functional. However, +-- the /arity family/ of @wrap@ combinators is different.+--+wrap :: a -> CF a+wrap = pure+++-- | Lift a pure value into a Context functional, ignoring both +-- the DrawingContext and the /static/ argument, e.g. this would+-- ingnore start point for a @LocDrawing@).+--+-- > ans -> (ctx -> r1 -> ans)+--+wrap1 :: a -> CF (r1 -> a)+wrap1 = pure . pure++-- | Lift a pure value into a Context functional, ignoring both +-- the DrawingContext and the two /static/ arguments, e.g. this +-- would ignore the start point and angle for a @LocThetaDrawing@.+--+-- > ans -> (ctx -> r1 -> r2 -> ans)+--+wrap2 :: a -> CF (r1 -> r2 -> a)+wrap2 = pure . pure . pure++   ++-- | Promote a Context functional with one argument /outside/+-- the functional so that the the argument is /inside/ the +-- Context functional.+--+-- The type signature is probably more illustrative of the +-- operation than this description:+--+-- > (r1 -> ctx -> ans) -> (ctx -> r1 -> ans)+--+-- This is essentially the @cardinal@ combinator - @flip@+-- in Haskell.+--+promote1 :: (r1 -> CF ans) -> CF (r1 -> ans)+promote1 f = CF $ \ctx a -> getCF (f a) ctx+++-- | Promote a Context functional with two arguments /outside/+-- the functional so that the two arguments are /inside/ the +-- Context functional.+--+-- The type signature is probably more illustrative of the +-- operation than this description:+--+-- > (r1 -> r2 -> ctx -> ans) -> (ctx -> r1 -> r2 -> ans)+--+promote2 :: (r1 -> r2 -> CF ans) -> CF (r1 -> r2 -> ans)+promote2 df = CF $ \ctx a b -> getCF (df a b) ctx+++-- | Lift a value into a Context functional.+--+-- > ans -> (ctx -> ans)+--+-- Essentially this is the @kestrel@ combinator - @const@ in +-- Haskell, though due to newtype wrapping it is @pure@ from the+-- Applicative class.+--+raise :: a -> CF a+raise = pure+++-- | Lift a one argument function into a Context functional.+--+-- This is Applicative\'s 'pure' with a specialized type +-- signature. +--+raise1 :: (r1 -> ans) -> CF (r1 -> ans) +raise1 = pure++-- | Lift a two argument function into a Context functional.+--+-- This is Applicative\'s 'pure' with a specialized type +-- signature.+--+raise2 :: (r1 -> r2 -> ans) -> CF (r1 -> r2 -> ans) +raise2 = pure+++-- | Extend the arity of a /Context functional/, the original +-- function is oblivious to the added argument.+--+-- Typically this combinator is used to take a @Graphic@ to a+-- @LocGraphic@ ingoring the start point (figuratively a @Graphic@ +-- is not /coordinate free/). +--+-- > (ctx -> ans) -> (ctx -> r1 -> ans)+--+-- This was called the J-combinator by Joy, Rayward-Smith and+-- Burton (ref. /Compling Functional Languages/ by Antoni +-- Diller), however it is not the J combinator commonly in the +-- Literature. +--+static1 :: CF ans -> CF (r1 -> ans)+static1 df = CF $ \ctx _ -> getCF df ctx+++-- | Extend the arity of a /Context functional/, the original +-- function is oblivious to the added argument.+--+-- Typically this combinator is used to take a @LocGraphic@ to a+-- @LocThetaGraphic@ ingoring the angle of direction.+--+-- > (ctx -> r1 -> ans) -> (ctx -> r1 -> r2 -> ans)+--+-- This was called the J-Prime combinator by Joy, Rayward-Smith +-- and Burton (ref. /Compling Functional Languages/ by Antoni +-- Diller). +--+static2 :: CF (r1 -> ans) -> CF (r1 -> r2 -> ans)+static2 df = CF $ \ctx a _ -> getCF df ctx a+++-- | Complementary combinator to static2. +--+-- This combinator raises a function two levels rather than one.+--+-- > (ctx -> ans) -> (ctx -> r1 -> r2 -> ans)+--+dblstatic :: CF ans -> CF (r1 -> r2 -> ans)+dblstatic df = CF $ \ctx _ _ -> getCF df ctx+++infixl 1 `bind`, `bind1`, `bind2`+++-- | Supply the output from the first function to the second +-- function.+--+-- This is just monadic bind - specialized to the CF functional +-- type.+--+-- > (ctx -> a) -> (a -> ctx -> ans) -> (ctx -> ans)+-- +bind :: CF a -> (a -> CF ans) -> CF ans+bind df dk = CF $ \ctx -> let z = getCF df ctx in getCF (dk z) ctx+++-- | Supply the output from the first function to the second +-- function, /sharing/ the drawing context and the static +-- argument @r1@.+--+-- > (ctx -> r1 -> a) -> (a -> ctx -> -> r1 -> ans) -> (ctx -> r1 -> ans)+-- +bind1 :: CF (r1 -> a) -> (a -> CF (r1 -> ans)) -> CF (r1 -> ans)+bind1 df dk = CF $ \ctx a -> let z = getCF df ctx a in getCF (dk z) ctx a++-- | Supply the output from the first function to the second +-- function, /sharing/ the DrawingContext and the two static +-- arguments @r1@ and @r2@.+--+-- > (ctx -> r1 -> r2 -> a) -> (a -> ctx -> -> r1 -> r2 -> ans) -> (ctx -> r1 -> r2 -> ans)+-- +bind2 :: CF (r1 -> r2 -> a) -> (a -> CF (r1 -> r2 -> ans)) +      -> CF (r1 -> r2 -> ans)+bind2 df dk = CF $ \ctx a b -> +    let z = getCF df ctx a b in getCF (dk z) ctx a b+++-- idstar  :: (r1 -> r2 -> ans) -> r1 -> r2 -> ans++-- | Supply the arguments to an arity 1 Context functional so it +-- can be /situated/. Typically this is supplying the start point +-- to a @LocGraphic@ or @LocImage@.+--+-- > (ctx -> r1 -> ans) -> r1 -> (ctx -> ans)+--+-- This is equivalent to the @id**@ combinator.+--+situ1 :: CF (r1 -> ans) -> r1 -> CF ans+situ1 df a = CF $ \ctx -> getCF df ctx a++++-- | Supply the arguments to an arity 2 Conterxt functional so +-- it can be /situated/. Typically this is supplying the start +-- point and angle to a @LocThetaGraphic@ or @LocThetaImage@.+--+-- > (ctx -> r1 -> r2 -> ans) -> r1 -> r2 -> (ctx -> ans)+--+situ2 :: CF (r1 -> r2 -> ans) -> r1 -> r2 -> CF ans+situ2 df a b = CF $ \ctx -> getCF df ctx a b+++-- | Apply the the functional produced by the first argument to+-- the value produced by the second.+--+-- > (ctx -> a -> ans) -> (ctx -> a) -> (ctx -> ans) +--+apply :: CF (a -> ans) -> CF a -> CF ans+apply df da = CF $ \ctx -> getCF df ctx (getCF da ctx)+++-- | Apply the the functional produced by the first argument to+-- the value produced by the second /sharing/ the context of the +-- first functional argument @r1@ (usually a Point2) as well as +-- the DrawingContext.+--+-- > (ctx -> r1 -> a -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> ans) +--+apply1 :: CF (r1 -> a -> ans) -> CF (r1 -> a) -> CF (r1 -> ans)+apply1 df da = CF $ \ctx a -> getCF df ctx a (getCF da ctx a)+++-- | Apply the the functional produced by the first argument to+-- the value produced by the second /sharing/ the context of the +-- two functional arguments @r1@ and @r2@ as well as the +-- DrawingContext.+--+-- > (ctx -> r1 -> r2 -> a -> ans) -> (ctx -> r1 -> r2 -> a) -> (ctx -> r1 -> r2 -> ans) +--+apply2 :: CF (r1 -> r2 -> a -> ans) -> CF (r1 -> r2 -> a) +       -> CF (r1 -> r2 -> ans)+apply2 df da = CF $ \ctx a b -> getCF df ctx a b (getCF da ctx a b)+++--------------------------------------------------------------------------------+-- Pre-transformers++-- The primary /pre-transformation/ function is @localize@, here +-- it is without the newtype wrapper or the specific types:+--+-- > fn :: (ctx -> ctx) -> (ctx -> ans) -> ctx -> ans+-- > fn f g = \ctx -> g (f ctx)+--+-- This a a type restricted version of reverse appliction, the T+-- combinator sometimes called queer, sometings @(#)@ in Haskell.+-- In Wumpus-Basic it is @localize@ which is overloaded for the+-- CF newtype and TraceDrawing monads.+--+-- > localizeDR :: (DrawingContext -> DrawingContext) -> CF a -> CF a+-- > localizeDR = localize+--+-- Figuartively speaking this is an opposite of the fmap function +-- instance. Instead of (post-) transforming the output, ... +-- (pre-) transforms  the input.+-- +-- Due to Context functionals being stacked in a particular way+-- @localize@ always pre-transforms the DrawingContext regardless+-- of the arity of the functional:+--+-- > localizeDR2 :: (DrawingContext -> DrawingContext) +-- >             -> CF (r -> a) -> CF (r -> a)+-- > localizeDR2 = localize+-- +++-- | Apply the static argument transfomer @(r1 -> a)@ to the +-- static argument /before/ applying the Context functional.+--+-- > (r1 -> a) -> (ctx -> a -> ans) -> (ctx -> r1 -> ans)+-- +prepro1 :: (r1 -> a) -> CF (a -> ans) -> CF (r1 -> ans)+prepro1 f mf = CF $ \ctx a -> getCF mf ctx (f a)+++-- | Apply the static argument transfomers to their respective+-- static arguments /before/ applying the Context functional.+--+-- > (r1 -> a) -> (r2 -> b) -> (ctx -> a -> b -> ans) -> (ctx -> r1 -> r2 -> ans)+-- +prepro2 :: (r1 -> a) -> (r2 -> b) -> CF (a -> b -> ans) -> CF (r1 -> r2 -> ans)+prepro2 f g mf = CF $ \ctx a b -> getCF mf ctx (f a) (g b)+++-- | Apply the static argument transfomer to the first static+-- argument of a two static argument functional /before/ applying +-- the Context functional.+--+-- > (r1 -> a) -> (ctx -> a -> r2 -> ans) -> (ctx -> r1 -> r2 -> ans)+-- +prepro2a :: (r1 -> a) -> CF (a -> r2 -> ans) -> CF (r1 -> r2 -> ans)+prepro2a f mf = CF $ \ctx a b -> getCF mf ctx (f a) b++-- | Apply the static argument transfomer to the second static+-- argument of a two static argument functional /before/ applying +-- the Context functional.+--+-- > (r2 -> a) -> (ctx -> r1 -> a -> ans) -> (ctx -> r1 -> r2 -> ans)+-- +prepro2b :: (r2 -> a) -> CF (r1 -> a -> ans) -> CF (r1 -> r2 -> ans)+prepro2b f mf = CF $ \ctx a b -> getCF mf ctx a (f b)++------------------------------------------------------------------------------+-- Post-transfomers++-- | Apply the post-transformer to the result of the Context+-- functional.+--+-- > (a -> ans) -> (ctx -> a) -> (ctx -> ans) +--+postpro :: (a -> ans) -> CF a -> CF ans+postpro = fmap++-- | Apply the post-transformer to the result of the Context+-- functional. Version for one static argument.+--+-- Note - the DrawingContext is always present so it is never +-- counted as a static argument.+--+-- > (a -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> ans) +--+postpro1 :: (a -> ans) -> CF (r1 -> a) -> CF (r1 -> ans)+postpro1 = postpro . fmap  ++-- | Apply the post-transformer to the result of the Context+-- functional. Version for two static arguments.+--+-- Note - the DrawingContext is always present so it is never +-- counted as a static argument.+--+--+-- > (a -> ans) -> (ctx -> r1 -> r2 -> a) -> (ctx -> r1 -> r2 -> ans) +--+postpro2 :: (a -> ans) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> ans)+postpro2 = postpro1 . fmap  +++--------------------------------------------------------------------------------+-- Post-combiners++-- | Combine the results of the two Context Functions with the +-- supplied operator.+--+-- > (a -> b -> ans) -> (ctx -> a) -> (ctx -> b) -> (ctx -> ans)+--+postcomb :: (a -> b -> ans) -> CF a -> CF b -> CF ans+postcomb op df dg = CF $ \ctx ->  getCF df ctx `op` getCF dg ctx++-- | Combine the results of the two one-static-argument Context +-- Functions with the supplied operator.+--+-- > (a -> b -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> b) -> (ctx -> r1 -> ans)+--+postcomb1 :: (a -> b -> c) -> CF (r1 -> a) -> CF (r1 -> b) -> CF (r1 -> c)+postcomb1 op df dg = CF $ \ctx a -> getCF df ctx a `op` getCF dg ctx a+++-- | Combine the results of the two two-static-argument Context +-- Functions with the supplied operator.+--+-- > (a -> b -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> b) -> (ctx -> r1 -> ans)+--+postcomb2 :: (a -> b -> ans) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> b) +          -> CF (r1 -> r2 -> ans)+postcomb2 op df dg = CF $ \ctx a b -> +    getCF df ctx a b `op` getCF dg ctx a b++++-- | Iteration combinator - the initial argument @s1@ is not +-- shared bewteen the drawings.+--+-- Evaluate the first Context Function with the drawing context +-- and the /initial state/ @st0@. The result of the evaluation is +-- a new /state/ @st1@ and and answer @a1@. +--+-- Evaluate the second Context Function with the drawing context +-- and the new state @st1@, producing a new state @s2@ and an +-- answer @a2@.+--+-- Return the result of combining the answers with +-- @op :: (ans -> ans -> ans)@ and the second state @s2@.+--+-- @ (ans -> ans -> ans) -> (ctx -> s1 -> (s1,ans)) @+-- @                     -> (ctx -> s1 -> (s1,ans)) -> (ctx -> s1 -> (s1,ans)) @+--+-- This models chaining start points together, which is the model+-- PostScript uses for text output when succesively calling the +-- @show@ operator.+-- +accumulate1 :: (ans -> ans -> ans) +            -> CF (s1 -> (s1,ans)) -> CF (s1 -> (s1,ans)) +            -> CF (s1 -> (s1,ans)) +accumulate1 op f g = CF $ \ctx s -> +                        let (s1,a1) = getCF f ctx s+                            (s2,a2) = getCF g ctx s1+                        in (s2, a1 `op` a2)++++-- | Arity two version of accumulate1 - this is not expected to be+-- useful!+--+-- @ (ans -> ans -> ans) -> (ctx -> s1 -> -> s2 (s1,s2,ans)) @+-- @     -> (ctx -> s1 -> s2 -> (s1,s2,ans)) @+-- @     -> (ctx -> s1 -> s2 -> (s1,s2,ans)) @+--+accumulate2 :: (ans -> ans -> ans) +            -> CF (s1 -> s2 -> (s1,s2,ans)) +            -> CF (s1 -> s2 -> (s1,s2,ans)) +            -> CF (s1 -> s2 -> (s1,s2,ans)) +accumulate2 op f g = CF $ \ctx s t -> +                        let (s1,t1,a1) = getCF f ctx s t+                            (s2,t2,a2) = getCF g ctx s1 t1+                        in (s2, t2, a1 `op` a2)++++++--------------------------------------------------------------------------------+{-+instance CenterAnchor a => CenterAnchor (CF a) where+  center = postpro center+-}

@@ -1,7 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -14,353 +11,114 @@ -- Stability   :  unstable -- Portability :  GHC  ----- Drawing with /trace/ - a Writer like monad collecting --- intermediate graphics - and /drawing context/ - a reader monad--- of attributes - font_face, fill_colour etc.---+-- A Drawing object. +-- +-- This is the corresponding type to Picture in the Wumpus-Core.+-- +-- Drawing is a function from the DrawingContext to a Picture.+-- Internally the result is actually a (Maybe Picture) and not a +-- Picture, this is a trick to promote the extraction from +-- possibly empty drawings (created by TraceDrawing) to the +-- top-level of the type hierarchy where client code can deal +-- with empty drawings explicitly (empty Pictures cannot be +-- rendered by Wumpus-Core).+--  --------------------------------------------------------------------------------  module Wumpus.Basic.Graphic.Drawing   (      Drawing-  , DrawingT+  , DDrawing   , runDrawing-  , execDrawing-  , evalDrawing-  , runDrawingT-  , execDrawingT-  , evalDrawingT--  , runFdcDrawing-  , execFdcDrawing-  , runFdcDrawingT-  , execFdcDrawingT--  , liftToPictureU-  , liftToPictureMb-  , mbPictureU- -  , draw-  , xdraw-  , drawi-  , drawi_-  , xdrawi-  , xdrawi_--  , at+  , runDrawingU+  , drawTracing -  , node-  , nodei+  , clipDrawing+  , modifyDrawing+  , drawingConcat    ) where --import Wumpus.Basic.Graphic.Base+import Wumpus.Basic.Graphic.ContextFunction import Wumpus.Basic.Graphic.DrawingContext--- import Wumpus.Basic.Utils.HList +import Wumpus.Basic.Graphic.TraceDrawing  import Wumpus.Core                              -- package: wumpus-core -import Control.Applicative-import Control.Monad-import Data.Monoid+newtype Drawing u = Drawing { getDrawing :: CF (Maybe (Picture u)) } +type DDrawing = Drawing Double  --- Note - Drawing run \once\ - it is supplied with the starting--- environment (DrawingContext) and returns a Picture.------ Other Wumpus monads (e.g. Turtle) will typically be run inside--- the Drawing monad as a local effect, rather than built into a --- transformer stack.---+type instance DUnit (Drawing u) = u  -newtype Drawing u a   = Drawing { -          getDrawing :: DrawingContext -> (a, HPrim u) } -newtype DrawingT u m a = DrawingT { -          getDrawingT :: DrawingContext -> m (a, HPrim u) } ---type instance MonUnit (Drawing u) = u-type instance MonUnit (DrawingT u m) = u------ Functor--instance Functor (Drawing u) where-  fmap f ma = Drawing $ \ctx -> -                let (a,w) = getDrawing ma ctx in (f a,w)---instance Monad m => Functor (DrawingT u m) where-  fmap f ma = DrawingT $ \ctx -> -                getDrawingT ma ctx >>= \(a,w) -> return (f a,w)------ Applicative--instance Applicative (Drawing u) where-  pure a    = Drawing $ \_   -> (a, mempty)-  mf <*> ma = Drawing $ \ctx -> let (f,w1) = getDrawing mf ctx-                                    (a,w2) = getDrawing ma ctx-                                in (f a, w1 `mappend` w2)---instance Monad m => Applicative (DrawingT u m) where-  pure a    = DrawingT $ \_   -> return (a,mempty)-  mf <*> ma = DrawingT $ \ctx -> getDrawingT mf ctx >>= \(f,w1) ->-                                 getDrawingT ma ctx >>= \(a,w2) ->-                                 return (f a, w1 `mappend` w2)---- Monad--instance Monad (Drawing u) where-  return a  = Drawing $ \_   -> (a, mempty)-  ma >>= k  = Drawing $ \ctx -> let (a,w1) = getDrawing ma ctx-                                    (b,w2) = (getDrawing . k) a ctx-                                in (b,w1 `mappend` w2)-                               ----instance Monad m => Monad (DrawingT u m) where-  return a  = DrawingT $ \_   -> return (a, mempty)-  ma >>= k  = DrawingT $ \ctx -> getDrawingT ma ctx      >>= \(a,w1) ->-                                 (getDrawingT . k) a ctx >>= \(b,w2) -> -                                 return (b, w1 `mappend` w2)-                                 ------ TraceM ------ Note -  @ state `mappend` a @ means the first expression in a --- monadic drawing is the first element in the output file. It is--- also \*\* at the back \*\* in the the Z-Order.------ Some control over the Z-Order, possibly by adding /layers/ to --- the drawing model would be valuable. --- --instance TraceM (Drawing u) where-  trace a = Drawing $ \_ -> ((), a)---instance Monad m => TraceM (DrawingT u m) where-  trace a = DrawingT $ \_ -> return ((), a)------ DrawingCtxM--instance DrawingCtxM (Drawing u) where-  askDC           = Drawing $ \ctx -> (ctx, mempty)-  localize upd ma = Drawing $ \ctx -> getDrawing ma (upd ctx)----instance Monad m => DrawingCtxM (DrawingT u m) where-  askDC           = DrawingT $ \ctx -> return (ctx,mempty)-  localize upd ma = DrawingT $ \ctx -> getDrawingT ma (upd ctx)------ Note - the result type of runDrawing and friends needs more --- thought and may change. ------ Possibly a wrapped HPrim that only supports concat and safe--- extraction is best.------ Or it could generate a picture, but then separate drawings--- need the picture combinators to put them together. --- ---runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u)-runDrawing ctx ma = getDrawing ma ctx---- | Run the drawing returning only the output it produces, drop--- any answer from the monadic computation.----execDrawing :: DrawingContext -> Drawing u a -> HPrim u-execDrawing ctx ma = snd $ runDrawing ctx ma---- | Run the drawing ignoring the output it produces, return the --- answer from the monadic computation.------ Note - this useful for testing, generally one would want the --- opposite behaviour (return the drawing, ignore than the --- answer).--- -evalDrawing :: DrawingContext -> Drawing u a -> a-evalDrawing ctx ma = fst $ runDrawing ctx ma----runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u) -runDrawingT ctx ma = getDrawingT ma ctx--execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u)-execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma---evalDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m a-evalDrawingT ctx ma = liftM fst $ runDrawingT ctx ma-+runDrawing :: DrawingContext -> Drawing u -> Maybe (Picture u)+runDrawing ctx drw = runCF ctx (getDrawing drw)    --- | Run the Drawing generating a Picture /within/ a --- \"font delta context\" using the font-family and font-size --- from the intial DrawingContext.------ Using a /font delta context/ can reduce the code size of the--- generated SVG file (PostScript ignores the FDC).----runFdcDrawing :: (Real u, Floating u, FromPtSize u)-             => DrawingContext -> Drawing u a -> (a, Maybe (Picture u))-runFdcDrawing ctx ma = -    let (a,hp) = runDrawing ctx ma-        ps     = hprimToList hp-        fdc    = font_props ctx-    in if null ps then (a, Nothing)-                 else (a, Just $ fontDeltaContext fdc $ frame ps)---- | /exec/ version of 'runFdcContext'.----execFdcDrawing :: (Real u, Floating u, FromPtSize u)-             => DrawingContext -> Drawing u a -> Maybe (Picture u)-execFdcDrawing ctx ma = snd $ runFdcDrawing ctx ma---- | Transformer version of 'runFdcDrawing'.----runFdcDrawingT :: (Real u, Floating u, FromPtSize u, Monad m)-             => DrawingContext -> DrawingT u m a -> m (a, Maybe (Picture u))-runFdcDrawingT ctx ma = -    runDrawingT ctx ma >>= \(a,hp) -> -    let ps     = hprimToList hp-        fdc    = font_props ctx-    in if null ps then return (a, Nothing)-                  else return (a, Just $ fontDeltaContext fdc $ frame ps)-  --- | Transformer version of 'execFdcDrawing'.---       -execFdcDrawingT :: (Real u, Floating u, FromPtSize u, Monad m)-             => DrawingContext -> DrawingT u m a -> m (Maybe (Picture u))-execFdcDrawingT ctx ma = liftM snd $ runFdcDrawingT ctx ma---- | /Unsafe/ promotion of @HPrim@ to @Picture@.------ If the HPrim is empty, a run-time error is thrown.--- -liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u-liftToPictureU hf = -    let prims = hprimToList hf in if null prims then errK else frame prims+runDrawingU :: DrawingContext -> Drawing u -> Picture u+runDrawingU ctx df = maybe fk id $ runDrawing ctx df   where-    errK = error "toPictureU - empty prims list."+    fk = error "runDrawingU - empty Drawing."    --- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.------ If the HPrim is empty, then @Nothing@ is returned.--- -liftToPictureMb :: (Real u, Floating u, FromPtSize u) -               => HPrim u -> Maybe (Picture u)-liftToPictureMb hf = let prims = hprimToList hf in -    if null prims then Nothing else Just (frame prims)  +drawTracing :: (Real u, Floating u, FromPtSize u) +            => TraceDrawing u a -> Drawing u+drawTracing mf = Drawing $ +    drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) ) --- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.++-- Note - cannot get an answer from a TraceDrawing with this +-- Drawing type. There is nowhere to put the answer in the type. ----- This is equivalent to:+-- If the type was extended: ----- > fromMaybe (error "empty") $ pic+-- > newtype Drawing u a = Drawing { getDrawing :: CF (a, Maybe (Picture u))) } ----- This function is solely a convenience, using it saves one --- import and a few characters.+-- It would make things difficult for the drawing composition +-- operators. @a@ could be monoidial but are there any types of +-- a where this would be useful (rather than just making things +-- more complicated)?  ----- If the supplied value is @Nothing@ a run-time error is thrown.--- -mbPictureU :: (Real u, Floating u, FromPtSize u) -           => Maybe (Picture u) -> Picture u-mbPictureU Nothing  = error "mbPictureU - empty picture."-mbPictureU (Just a) = a---- Note - need an equivalent to Parsec\`s parseTest that provides--- a very simple way to run graphics without concern for return --- type or initial drawing context.- -------------------------------------------------------------------------------- --- | Draw a Graphic taking the drawing style from the --- /drawing context/. ------ This operation is analogeous to @tell@ in a Writer monad.--- -draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()-draw gf = askDC >>= \ctx -> trace (collectH $ runGraphic ctx gf)+clipDrawing :: (Num u, Ord u) => (PrimPath u) -> Drawing u -> Drawing u+clipDrawing cpath = modifyDrawing (clip cpath) --- | Hyperlink version of 'draw'.----xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) -      => XLink -> Graphic u -> m ()-xdraw xl gf = draw (xlinkGraphic xl gf) +modifyDrawing :: (Picture u -> Picture u) -> Drawing u -> Drawing u+modifyDrawing pf = Drawing . postpro (fmap pf) . getDrawing +instance (Real u, Floating u) => Rotate (Drawing u) where +  rotate ang = modifyDrawing (rotate ang) --- | Draw an Image taking the drawing style from the --- /drawing context/. ------ The graphic representation of the Image is drawn in the Trace --- monad, and the result is returned.--- -drawi ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a-drawi img = askDC >>= \ctx -> -            let (a,o) = runImage ctx img in trace (collectH o) >> return a+instance (Real u, Floating u) => RotateAbout (Drawing u) where+  rotateAbout r pt = modifyDrawing (rotateAbout r pt) --- | Forgetful 'drawi'.----drawi_ ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m ()-drawi_ img = drawi img >> return ()+instance (Num u, Ord u) => Scale (Drawing u) where+  scale sx sy = modifyDrawing (scale sx sy) +instance (Num u, Ord u) => Translate (Drawing u) where+  translate dx dy = modifyDrawing (translate dx dy) --- | Hyperlink version of 'drawi'.----xdrawi ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) -       => XLink -> Image u a -> m a-xdrawi xl img = drawi (xlinkImage xl img)  --- | Forgetful 'xdrawi'.----xdrawi_ ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) -        => XLink -> Image u a -> m ()-xdrawi_ xl img = xdrawi xl img >> return ()  -infixr 1 `at`-at :: (Point2 u -> a) -> Point2 u -> a-at = ($)-+drawingConcat :: (Picture u -> Picture u -> Picture u) +              -> Drawing u -> Drawing u -> Drawing u+drawingConcat op a b = Drawing $ mbpostcomb op (getDrawing a) (getDrawing b)   -node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) -     => LocGraphic u -> m ()-node gfL = askDC    >>= \ctx -> -           position >>= \pt  -> -           trace (collectH $ runGraphic ctx $ gfL pt)---nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) -     => LocImage u a -> m a-nodei imgL = askDC   >>= \ctx -> -             position >>= \pt  -> -             let (a,o) = runImage ctx (imgL pt) -             in trace (collectH o) >> return a-+mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a)+mbpostcomb op = postcomb fn+  where+    fn (Just a) (Just b) = Just $ a `op` b+    fn a        Nothing  = a+    fn Nothing  b        = b