wumpus-basic 0.14.0 → 0.15.0

raw patch · 56 files changed

+1206/−9477 lines, 56 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• CHANGES +39/−0
• demo/ArrowCircuit.hs +0/−113
• demo/Arrowheads.hs +0/−82
• demo/ClipPic.hs +0/−103
• demo/ColourChartUtils.hs +0/−502
• demo/ColourCharts.hs +0/−56
• demo/Connectors.hs +0/−74
• demo/DotPic.hs +0/−117
• demo/DrawingCompo.hs +0/−151
• demo/FeatureModel.hs +0/−132
• demo/FontDeltaPic.hs +51/−0
• demo/FontLoaderUtils.hs +0/−95
• demo/FontPic.hs +0/−117
• demo/LeftRightText.hs +0/−195
• demo/PetriNet.hs +0/−158
• demo/Symbols.hs +0/−223
• src/Wumpus/Basic/Kernel.hs +2/−6
• src/Wumpus/Basic/Kernel/Base/Anchors.hs +2/−2
• src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +3/−1
• src/Wumpus/Basic/Kernel/Base/ContextFun.hs +20/−11
• src/Wumpus/Basic/Kernel/Base/DrawingContext.hs +49/−16
• src/Wumpus/Basic/Kernel/Base/QueryDC.hs +22/−0
• src/Wumpus/Basic/Kernel/Base/ScalingContext.hs +39/−130
• src/Wumpus/Basic/Kernel/Base/UpdateDC.hs +17/−1
• src/Wumpus/Basic/Kernel/Geometry/Intersection.hs +0/−172
• src/Wumpus/Basic/Kernel/Geometry/Paths.hs +0/−114
• src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs +563/−0
• src/Wumpus/Basic/Kernel/Objects/Drawing.hs +0/−563
• src/Wumpus/Basic/Kernel/Objects/Graphic.hs +9/−1
• src/Wumpus/Basic/Utils/JoinList.hs +349/−0
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• src/Wumpus/Drawing/Arrows.hs +0/−28
• src/Wumpus/Drawing/Arrows/Connectors.hs +0/−149
• src/Wumpus/Drawing/Arrows/Tips.hs +0/−505
• src/Wumpus/Drawing/Chains.hs +0/−29
• src/Wumpus/Drawing/Chains/Base.hs +0/−161
• src/Wumpus/Drawing/Chains/Derived.hs +0/−129
• src/Wumpus/Drawing/Colour/SVGColours.hs +0/−625
• src/Wumpus/Drawing/Colour/X11Colours.hs +0/−1282
• src/Wumpus/Drawing/Dots/AnchorDots.hs +0/−280
• src/Wumpus/Drawing/Dots/Marks.hs +0/−238
• src/Wumpus/Drawing/Paths.hs +0/−31
• src/Wumpus/Drawing/Paths/Base.hs +0/−529
• src/Wumpus/Drawing/Paths/Connectors.hs +0/−206
• src/Wumpus/Drawing/Paths/Construction.hs +0/−160
• src/Wumpus/Drawing/Paths/ControlPoints.hs +0/−189
• src/Wumpus/Drawing/Paths/RoundCorners.hs +0/−120
• src/Wumpus/Drawing/Shapes.hs +0/−27
• src/Wumpus/Drawing/Shapes/Base.hs +0/−227
• src/Wumpus/Drawing/Shapes/Coordinate.hs +0/−141
• src/Wumpus/Drawing/Shapes/Derived.hs +0/−371
• src/Wumpus/Drawing/Text/LRText.hs +0/−399
• src/Wumpus/Drawing/Text/SafeFonts.hs +0/−167
• src/Wumpus/Drawing/Turtle/TurtleClass.hs +0/−91
• src/Wumpus/Drawing/Turtle/TurtleMonad.hs +0/−140
• wumpus-basic.cabal +39/−116

@@ -1,4 +1,43 @@+0.13.0 to 0.14.0: +  * Re-organised module hierarchy, Wumpus-Basic is now divided +    into two layers - Basic (Font loader, utils, kernel drawing) +    and Drawing - /constructed/ graphic objects like arrows, dots, +    etc.++  * Re-designed the /ContextFunction/ function types. Context+    functions with different numbers of /static arguments/ are +    now separate newtypes. This has allowed a major cull of the +    combinators operating on context functions (@prepro@, +    @postpro@, @situ@, etc.) and now only a handful of special+    combinators are needed. As the newtypes are instances of +    Monad and Applicative the usual Applicative and Monad +    combinators are now more readily useful.++  * Work on the font loader code to improve its robustness, and +    improved error signalling on load failure. Loading glyph +    metrics now returns both the metrics (possibly fallback +    metrics if parsing failed) and a log.++0.12.0 to 0.13.0:++  * Major changes to @Basic.Graphic@ modules. @DrawingR@ is +    renamed @Drawing@ and is substantially re-worked. Graphic +    /functional/ types are now encapulated in the Drawing +    constructor @Drawing (ctx -> pt -> prim)@ rather than +    partially outside it @pt -> Drawing (ctx -> prim)@. +    @Drawing@ monad renamed @TraceDrawing@ and @DrawingT@ +    transformer renamed @TraceDrawingT@.++  * Rudimentary font loading added, only AFM files are supported.++  * @Basic.Shapes.Coordinate@ re-worked. The Coordinate type is +    now more like the Shapes types (excepting the intentional +    difference in drawing style).++  * @Basic.Shapes.Plaintext@ removed.++  * @Basic.Text.LRText@ completely redesigned.  0.11.0 to 0.12.0: 

@@ -1,113 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}----- Acknowledgment - the Arrow diagram is taken from Ross --- Paterson\'s slides /Arrows and Computation/.---module ArrowCircuit where--import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Paths -import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts--import Wumpus.Core                      -- package: wumpus-core--import FontLoaderUtils---import Data.AffineSpace--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, msgs) <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"]-    mapM_ putStrLn msgs-    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, msgs) <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"]-    mapM_ putStrLn msgs-    let pic1 = runDrawingU (makeCtx base_metrics) circuit_drawing-    writeEPS "./out/arrow_circuit02.eps" pic1-    writeSVG "./out/arrow_circuit02.svg" pic1 -- -makeCtx :: GlyphMetrics -> 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.-         -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 $ P2 120 60-    atext a2 "IF"-    a3 <- drawi $ strokedShape $ circle 16 $ P2 240 28-    atext a3 "+1"-    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)-    connWith connLine (north a2 .+^ vvec 40) (north a2)-    connWith connLine (north a3 .+^ vvec 16) (north a3)  -    connWith connRightVH  (south a3) (east a4)-    connWith (connRightHVH (-30)) (west a4)  (southwest a2)-    ptext (P2  40  10) "next"-    ptext (P2 152 100) "reset"-    ptext (P2 252  72) "output"-    return ()----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_ $ apply2R2 (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 pt = center ancr in-   drawi_ $ ctrCenterLine ss `at` pt---ptext :: ( Real u, Floating u, FromPtSize u-         , TraceM m, DrawingCtxM m, u ~ MonUnit m )-      => Point2 u -> String -> m ()-ptext pt ss = localize (fontAttr times_italic 14) $ -    drawi_ $ ctrCenterLine ss `at` pt

@@ -1,82 +0,0 @@-{-# OPTIONS -Wall #-}--module Arrowheads where---import Wumpus.Basic.Kernel-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Chains-import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths hiding ( length )--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Monad-import System.Directory--main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runDrawingU std_ctx arrow_drawing-    writeEPS "./out/arrowheads01.eps" pic1-    writeSVG "./out/arrowheads01.svg" pic1--arrow_drawing :: Drawing Double-arrow_drawing = drawTracing $ tableGraphic arrtable--arrtable :: [(Arrowhead Double, Arrowhead Double)]-arrtable = -    [ (tri90,       tri90)-    , (tri60,       tri60)-    , (tri45,       tri45)-    , (otri90,      otri90)-    , (otri60,      otri60)-    , (otri45,      otri45)-    , (revtri90,    revtri90)-    , (revtri60,    revtri60)-    , (revtri45,    revtri45)-    , (orevtri90,   orevtri90)-    , (orevtri60,   orevtri60)-    , (orevtri45,   orevtri45)-    , (barb90,      barb90)-    , (barb60,      barb60)-    , (barb45,      barb45)-    , (revbarb90,   revbarb90)-    , (revbarb60,   revbarb60)-    , (revbarb45,   revbarb45)-    , (perp,        perp)-    , (bracket,     bracket)-    , (diskTip,     diskTip)-    , (odiskTip,    odiskTip)-    , (squareTip,   squareTip)-    , (osquareTip,  osquareTip)-    , (diamondTip,  diamondTip)-    , (odiamondTip, odiamondTip)-    , (curveTip,    curveTip)-    , (revcurveTip, revcurveTip)-    ]--tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u ()-tableGraphic tips = zipWithM_ makeArrowDrawing tips ps-  where-    ps = unchain (coordinateScalingContext 120 24) $ tableDown 20 4--- -std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18----makeArrowDrawing :: (Real u, Floating u, FromPtSize u) -                 => (Arrowhead u, Arrowhead u) -> Point2 u -                 -> TraceDrawing u ()-makeArrowDrawing (arrl,arrr) p0 = -    drawi_ $ apply2R2 (strokeConnector (leftrightArrow connLine arrl arrr)) p0 p1-  where-    p1 = p0 .+^ hvec 100-  -

@@ -1,103 +0,0 @@-{-# OPTIONS -Wall #-}---- Note - how the background is built in this example is very --- expensive, i.e. it generates large PostScript and SVG files--- because the text elements are drawn many more times than they--- are actually seen.------ This example just illustrates that clipping-paths work and --- uses a complicated background to make that point.------module ClipPic where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains-import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths-import Wumpus.Drawing.Text.SafeFonts--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import System.Directory---main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    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---big_pic :: DDrawing-big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4]--fillPath :: Num u => Path u -> Graphic u-fillPath = filledPath . toPrimPath--pic1 :: DDrawing-pic1 = drawTracing $-         localize (fillColour medium_slate_blue) $ do-            draw $ fillPath path01-            localize (fillColour powder_blue) $ -                     draw $ fillPath path02-            draw $ fillPath path03-            draw $ fillPath path04---background :: RGBi -> DDrawing-background rgb = drawTracing $ -    localize (strokeColour rgb) $ mapM_ iheartHaskell ps-   where-     ps = unchain (coordinateScalingContext 86 16) $ tableDown 18 8--cpic1 :: DDrawing -cpic1 = clipDrawing (toPrimPath path01) (background black)-  -cpic2 :: DDrawing-cpic2 = clipDrawing (toPrimPath path02) (background medium_violet_red)--cpic3 :: DDrawing -cpic3 = clipDrawing (toPrimPath path03) (background black)--cpic4 :: DDrawing -cpic4 = clipDrawing (toPrimPath path04) (background black)---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-path01 = execPath zeroPt $ hline 80 >> rlineto (vec 112 160) -                                    >> rlineto (vec (-112) 160)-                                    >> hline (-80)-                                    >> rlineto (vec 112 (-160))-                                    >> rlineto (vec (-112) (-160))- --path02 :: Floating u => Path u-path02 = execPath (P2 112 0) $ hline 80 >> rlineto (vec 72 112)-                                        >> rlineto (vec 72 (-112))-                                        >> hline 80-                                        >> rlineto (vec (-224) 320)-                                        >> hline (-80)-                                        >> rlineto (vec 112 (-160))-                                        >> rlineto (vec (-112) (-160))--path03 :: Floating u => Path u-path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) --path04 :: Floating u => Path u-path04 = execPath (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) -

@@ -1,502 +0,0 @@-{-# 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.Drawing.Colour.SVGColours    as SVG-import qualified Wumpus.Drawing.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)-  ]----

@@ -1,56 +0,0 @@-{-# OPTIONS -Wall #-}--module ColourCharts where--import ColourChartUtils--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains--import Wumpus.Core                              -- package: wumpus-core--import Control.Monad-import System.Directory---main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    ---    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--draw_ctx :: DrawingContext-draw_ctx = (standardContext 9)--svg :: Drawing Double-svg = makeDrawing 52 all_svg_colours--x11_landscape :: Drawing Double-x11_landscape = makeDrawing 52 all_x11_colours--x11_portrait :: Drawing Double-x11_portrait = makeDrawing 72 all_x11_colours     --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 -> 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,74 +0,0 @@-{-# OPTIONS -Wall #-}--module Connectors where---import Wumpus.Basic.Kernel-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Chains-import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths hiding ( length )--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Monad-import System.Directory--main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runDrawingU std_ctx conn_drawing-    writeEPS "./out/connectors01.eps" pic1-    writeSVG "./out/connectors01.svg" pic1----conn_drawing :: Drawing Double-conn_drawing = drawTracing $ tableGraphic $ conntable--conntable :: [ConnectorPath Double]-conntable = -    [ connLine-    , connRightVH-    , connRightHV-    , connRightVHV 15-    , connRightHVH 15-    , connIsosceles 25-    , connIsosceles (-25)-    , connIsosceles2 15-    , connIsosceles2 (-15)-    , connLightningBolt 15-    , connLightningBolt (-15)-    , connIsoscelesCurve 25-    , connIsoscelesCurve (-25)-    , connSquareCurve-    , connUSquareCurve-    , connTrapezoidCurve 40 0.5-    , connTrapezoidCurve (-40) 0.5-    , connZSquareCurve   -    , connUZSquareCurve   -    ]--tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [ConnectorPath u] -> TraceDrawing u ()-tableGraphic conns = zipWithM_ makeConnDrawing conns ps-  where-    ps = unchain (coordinateScalingContext 120 52) $ tableDown 10 6--- -std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18----makeConnDrawing :: (Real u, Floating u, FromPtSize u) -                 => ConnectorPath u -> Point2 u -> TraceDrawing u ()-makeConnDrawing conn p0 = -    drawi_ $ connect (strokeConnector (dblArrow conn curveTip)) p0 p1-  where-    p1 = p0 .+^ vec 100 40-  -

@@ -1,117 +0,0 @@-{-# OPTIONS -Wall #-}--module DotPic where---import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Chains-import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Dots.AnchorDots-import Wumpus.Drawing.Text.SafeFonts--import FontLoaderUtils--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Monad-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, msgs) <- loadGSMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs-    let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing -    writeEPS "./out/dots01_gs.eps" pic1-    writeSVG "./out/dots01_gs.svg" pic1-- --makeAfmPicture :: FilePath -> IO ()-makeAfmPicture font_dir = do -    putStrLn "Using AFM 4.1 metrics..."-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs-    let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing -    writeEPS "./out/dots01_afm.eps" pic1-    writeSVG "./out/dots01_afm.svg" pic1-- -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fillColour peru . fontFace helvetica . metricsContext 24---dot_drawing :: Drawing Double-dot_drawing = drawTracing $ tableGraphic $ -    [ dotHLine-    , dotVLine-    , dotX-    , dotPlus-    , dotCross-    , dotDiamond-    , dotDisk-    , dotSquare-    , dotCircle-    , dotPentagon-    , dotStar-    , dotAsterisk-    , dotOPlus-    , dotOCross-    , dotFOCross-    , dotFDiamond-    , dotText "%" -    , dotTriangle-    ]---tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [DotLocImage u] -> TraceDrawing u ()-tableGraphic imgs = zipWithM_ makeDotDrawing imgs ps-  where-    ps = unchain (coordinateScalingContext 1 36) $ tableDown (length imgs) 1----makeDotDrawing :: (Real u, Floating u, FromPtSize u) -               => DotLocImage u -> Point2 u -> TraceDrawing u ()-makeDotDrawing dotF pt = do -    dashline-    mapM_ (\v -> drawi $ dotF `at` pt .+^ v) displacements-  where-    all_pts  = map (pt .+^) displacements-    dashline = localize attrUpd (draw $ openStroke $ vertexPath all_pts)--    attrUpd  :: DrawingContext -> DrawingContext-    attrUpd  =  dashPattern (evenDashes 1) . strokeColour cadet_blue---displacements :: Num u => [Vec2 u]-displacements = [V2 0 0, V2 64 20, V2 128 0, V2 192 20]----- Should these produce a DashPattern or a StrokeAttr?--evenDashes :: Int -> DashPattern -evenDashes n = Dash 0 [(n,n)]--dashOffset :: Int -> DashPattern -> DashPattern-dashOffset _ Solid       = Solid-dashOffset n (Dash _ xs) = Dash n xs-

@@ -1,151 +0,0 @@-{-# OPTIONS -Wall #-}--module DrawingCompo where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Colour.SVGColours--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))-

@@ -1,132 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}----module FeatureModel where--import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Paths -import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts--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, msgs) <- loadGSMetrics font_dir ["Courier-Bold"]-    mapM_ putStrLn msgs-    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, msgs) <- loadAfmMetrics font_dir ["Courier-Bold"]-    mapM_ putStrLn msgs-    let pic1 = runDrawingU (makeCtx base_metrics) feature_model -    writeEPS "./out/feature_model02.eps" pic1-    writeSVG "./out/feature_model02.svg" pic1 --makeCtx :: GlyphMetrics -> 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_ $ ctrCenterLine 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 <- getLineWidth-   let p0 = south b0-   let p1 = northwards (realToFrac lw) b1-   drawi $ apply2R2 (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,51 @@+{-# OPTIONS -Wall #-}++-- Note - this demo is not really exemplary - it is only here+-- to check the compilation of Wumpus-Basic. There are more +-- impressive demos in the @Wumpus-Drawing@ package.+-- ++module FontDeltaPic where++import Wumpus.Basic.Kernel++import Wumpus.Core                      -- package: wumpus-core++import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    putStrLn $ "Note - the SVG optimization that should be used here"+    putStrLn $ "has bit-rotted and is not currently in use.."+    --+    let pic1 = runCtxPictureU std_attr drawing01+    writeEPS "./out/font_delta01.eps" pic1+    writeSVG "./out/font_delta01.svg" pic1+++std_attr :: DrawingContext+std_attr = standardContext 24+++drawing01 :: DCtxPicture+drawing01 = drawTracing $ mf +++mf :: (Floating u, FromPtSize u) => TraceDrawing u ()+mf = do +    draw $ line1 `at` (P2 0 100)+    draw $ line2 `at` (P2 0  75)+    draw $ line3 `at` (P2 0  50)+    draw $ line4 `at` (P2 0  25)+    draw $ line5 `at` (P2 0   0) +  where+    line1 = textline "All the lines of this drawing" +    line2 = textline "should be grouped within a SVG"+    line3 = textline "g-element, from where they"+    line4 = textline "inherit the font-family and"+    line5 = textline "font-size attributes."++++

@@ -1,95 +0,0 @@-{-# 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-

@@ -1,117 +0,0 @@-{-# OPTIONS -Wall #-}--module FontPic where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains-import Wumpus.Drawing.Colour.SVGColours ( steel_blue )-import Wumpus.Drawing.Colour.X11Colours ( indian_red1 )-import Wumpus.Drawing.Text.SafeFonts--import Wumpus.Core                              -- package: wumpus-core--import Control.Monad--import System.Directory--main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    ---    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 (ps_font_name ff) . showChar ' ' . shows sz . showString "pt"---makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic-makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz)-  where-    upd = fillColour rgb . fontAttr ff sz ---- indian_red1--- steel_blue--point_sizes :: [Int]-point_sizes = [10, 12, 18, 24, 36, 48]--positions :: [Int]-positions = [0, 12, 27, 49, 78, 122] ---pointChain :: LocChain Int Int Double-pointChain = verticals positions--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---std_ctx :: DrawingContext-std_ctx = standardContext 10---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--------------------------------------------------------------------------------------- Times--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_drawing :: Drawing Double-helvetica_drawing = -    fontDrawing [ (steel_blue,  helvetica)-                , (indian_red1, helvetica_oblique)-                , (steel_blue,  helvetica_bold)-                , (indian_red1, helvetica_bold_oblique)-                ] --------------------------------------------------------------------------------------courier_drawing :: Drawing Double-courier_drawing = -    fontDrawing [ (steel_blue,  courier)-                , (indian_red1, courier_oblique)-                , (steel_blue,  courier_bold)-                , (indian_red1, courier_bold_oblique)-                ] -------------------------------------------------------------------------------------    -symbol_drawing :: Drawing Double-symbol_drawing = -    fontDrawing [ (steel_blue, symbol) ]

@@ -1,195 +0,0 @@-{-# 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.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Dots.Marks-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts--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, msgs) <- loadGSMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs-    let pic1 = runDrawingU (makeCtx gs_metrics) text_drawing -    writeEPS "./out/lr_text01.eps" pic1-    writeSVG "./out/lr_text01.svg" pic1--makeAfmPicture :: FilePath -> IO ()-makeAfmPicture font_dir = do-    putStrLn "Using AFM 4.1 metrics..."-    (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs-    let pic2 = runDrawingU (makeCtx afm_metrics) text_drawing -    writeEPS "./out/lr_text02.eps" pic2-    writeSVG "./out/lr_text02.svg" pic2-----makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace helvetica . metricsContext 18---text_drawing :: Drawing Double-text_drawing = drawTracing $ do -    drawi_ $ (fn left_text)       `at` P2   0 400-    drawi_ $ (fn center_text)     `at` P2 200 400-    drawi_ $ (fn right_text)      `at` P2 400 400-    drawi_ $ (fn blank_text)      `at` P2   0 300-    drawi_ $ (fn bl_oneline)      `at` P2 200 300-    drawi_ $ (fn cc_oneline)      `at` P2 400 300-    drawi_ $ (fn newblr)          `at` P2   0 200-    drawi_ $ (fn newblc)          `at` P2 200 200-    drawi_ $ (fn newbll)          `at` P2 400 200-    drawi_ $ (fn rnewblr)         `at` P2   0 100-    drawi_ $ (fn rnewblc)         `at` P2 200 100-    drawi_ $ (fn rnewbll)         `at` P2 400 100-    drawi_ $ (fn rleft_text)      `at` P2   0 (-75)-    drawi_ $ (fn rcenter_text)    `at` P2 200 (-75)-    drawi_ $ (fn rright_text)     `at` P2 400 (-75)-      - -    draw $ redPlus            `at` P2   0 400-    draw $ redPlus            `at` P2 200 400-    draw $ redPlus            `at` P2 400 400-    draw $ redPlus            `at` P2   0 300  -    draw $ redPlus            `at` P2 200 300 -    draw $ redPlus            `at` P2 400 300 -    draw $ redPlus            `at` P2   0 200  -    draw $ redPlus            `at` P2 200 200 -    draw $ redPlus            `at` P2 400 200  -    draw $ redPlus            `at` P2   0 100  -    draw $ redPlus            `at` P2 200 100 -    draw $ redPlus            `at` P2 400 100 -    draw $ redPlus            `at` P2   0 (-75)-    draw $ redPlus            `at` P2 200 (-75)-    draw $ redPlus            `at` P2 400 (-75)-      -  where-    fn = illustrateBoundedLocGraphic-   -redPlus :: (Fractional u, FromPtSize u) => LocGraphic u-redPlus = localize (strokeColour red) markPlus---newblc :: BoundedLocGraphic Double-newblc = -    localize (strokeColour dark_slate_gray) $ -        baseCenterLine "new baseline center"--newbll :: BoundedLocGraphic Double-newbll = -    localize (strokeColour dark_slate_gray) $ -        baseLeftLine "new baseline left"--newblr :: BoundedLocGraphic Double-newblr = -    localize (strokeColour dark_slate_gray) $ -        baseRightLine "new baseline right"---rnewblc :: BoundedLocGraphic Double-rnewblc = -    localize (strokeColour dark_slate_gray) $ -        rbaseCenterLine "baseline center" `rot` (0.25*pi)--rnewbll :: BoundedLocGraphic Double-rnewbll = -    localize (strokeColour dark_slate_gray) $ -        rbaseLeftLine "baseline left" `rot` (0.25*pi)--rnewblr :: BoundedLocGraphic Double-rnewblr = -    localize (strokeColour dark_slate_gray) $ -        rbaseRightLine "baseline right" `rot` (0.25 * pi)---bl_oneline :: BoundedLocGraphic Double-bl_oneline = -    localize (strokeColour dark_slate_gray) $ baseLeftLine "Baseline-left..."---cc_oneline :: BoundedLocGraphic Double-cc_oneline = -    localize (strokeColour dark_slate_gray) $ ctrCenterLine "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---rleft_text :: BoundedLocGraphic Double-rleft_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignLeft dummy_text `rot`   (0.25*pi)---rright_text :: BoundedLocGraphic Double-rright_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignRight dummy_text `rot`  (0.25*pi)--rcenter_text :: BoundedLocGraphic Double-rcenter_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignCenter dummy_text `rot` (0.25*pi)---dummy_text :: String -dummy_text = unlines $ [ "The quick brown"-                       , "fox jumps over"-                       , "the lazy dog."-                       ]

@@ -1,158 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}---- Acknowledgment - the petri net is taken from Claus Reinke\'s--- paper /Haskell-Coloured Petri Nets/.---module PetriNet where--import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths-import Wumpus.Drawing.Shapes.Base-import Wumpus.Drawing.Shapes.Derived-import Wumpus.Drawing.Text.SafeFonts-import Wumpus.Drawing.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..."-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica", "Helvetica-Bold"]-    mapM_ putStrLn msgs-    let pic1 = runDrawingU (makeCtx base_metrics) petri_net-    writeEPS "./out/petri_net01.eps" pic1-    writeSVG "./out/petri_net01.svg" pic1 --makeAfmPicture :: FilePath -> IO ()-makeAfmPicture font_dir = do -    putStrLn "Using AFM 4.1 metrics..."-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica", "Helvetica-Bold"]-    mapM_ putStrLn msgs-    let pic1 = runDrawingU (makeCtx base_metrics) petri_net-    writeEPS "./out/petri_net02.eps" pic1-    writeSVG "./out/petri_net02.svg" pic1 ---makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace helvetica . metricsContext 14---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 $ 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 $ P2 x y-----connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m-         , Real u, Floating u, FromPtSize u ) -      => Point2 u -> Point2 u -> m ()-connector' p0 p1 = -    drawi_ $ apply2R2 (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_ $ apply2R2 (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_ $ apply2R2 (strokeConnector (rightArrow (connIsosceles u) tri45)) p0 p1---lblParensParens :: Num u => LocGraphic u-lblParensParens = localize (fontFace helvetica) $ textline "(),()"--lblParensParensParens :: Num u => LocGraphic u-lblParensParensParens = localize (fontFace helvetica) $ textline "(),(),()"---lblBold' :: Num u => String -> LocGraphic u-lblBold' ss = localize (fontFace helvetica_bold) $ textline ss---lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u-lblBold ss = localize (fontFace helvetica_bold) $ post $ ctrCenterLine ss-  where-    post = fmap (replaceL uNil)

@@ -1,223 +0,0 @@-{-# OPTIONS -Wall #-}--module Symbols where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains-import Wumpus.Drawing.Text.SafeFonts---import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Monad-import Prelude hiding ( pi, product )--import System.Directory--main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runDrawingU std_ctx symbols-    writeEPS "./out/symbols.eps" pic1-    writeSVG "./out/symbols.svg" pic1---std_ctx :: DrawingContext-std_ctx = fontFace times_roman $ standardContext 12----- 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-    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--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")--    ---    , ("&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")--    -- -    , ("&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")--    ---    , ("&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")-    ]-

@@ -26,13 +26,11 @@   , module Wumpus.Basic.Kernel.Base.ScalingContext   , module Wumpus.Basic.Kernel.Base.UpdateDC   , module Wumpus.Basic.Kernel.Base.WrappedPrimitive-  , module Wumpus.Basic.Kernel.Geometry.Intersection-  , module Wumpus.Basic.Kernel.Geometry.Paths   , module Wumpus.Basic.Kernel.Objects.AdvanceGraphic   , module Wumpus.Basic.Kernel.Objects.BaseObjects   , module Wumpus.Basic.Kernel.Objects.Bounded   , module Wumpus.Basic.Kernel.Objects.Connector-  , module Wumpus.Basic.Kernel.Objects.Drawing+  , module Wumpus.Basic.Kernel.Objects.CtxPicture   , module Wumpus.Basic.Kernel.Objects.Graphic   , module Wumpus.Basic.Kernel.Objects.TraceDrawing   ) where@@ -46,12 +44,10 @@ import Wumpus.Basic.Kernel.Base.ScalingContext import Wumpus.Basic.Kernel.Base.UpdateDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Geometry.Intersection-import Wumpus.Basic.Kernel.Geometry.Paths import Wumpus.Basic.Kernel.Objects.AdvanceGraphic import Wumpus.Basic.Kernel.Objects.BaseObjects import Wumpus.Basic.Kernel.Objects.Bounded import Wumpus.Basic.Kernel.Objects.Connector-import Wumpus.Basic.Kernel.Objects.Drawing+import Wumpus.Basic.Kernel.Objects.CtxPicture import Wumpus.Basic.Kernel.Objects.Graphic import Wumpus.Basic.Kernel.Objects.TraceDrawing

@@ -96,7 +96,7 @@  extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u extendPtDist d p1 p2 = let v   = pvec p1 p2-                           ang = direction v+                           ang = vdirection v                            len = vlength v                        in p1 .+^ avec ang (len+d) @@ -210,7 +210,7 @@                       => t1 -> t2 -> (Point2 u, Point2 u)  radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b)   where-    theta = direction $ pvec (center a) (center b)+    theta = vdirection $ pvec (center a) (center b)       --------------------------------------------------------------------------------

@@ -52,7 +52,6 @@   , displacePerpendicular  -   -- * Monadic drawing   , MonUnit @@ -260,6 +259,9 @@ displacePerpendicular :: Floating u => u -> ThetaPointDisplace u displacePerpendicular d =      \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d+++   --------------------------------------------------------------------------------

@@ -65,6 +65,7 @@   -- * Combinators   , at   , rot+  , atRot   , connect   , chain1 @@ -328,8 +329,8 @@   --- | Promote a function @from one argument to a Context function@ --- to an arity one @Context function@.+-- | Promote a function @from one argument to a Context Function@ +-- to an arity one @Context Function@. -- -- The type signature is as explanatory as a description: --@@ -338,8 +339,8 @@ promoteR1           :: (r1 -> CF a) -> CF1 r1 a promoteR1 mf        = CF1 $ \ctx r1 -> unCF (mf r1) ctx --- | Promote a function @from two arguments to a Context function@ --- to an arity two @Context function@.+-- | Promote a function @from two arguments to a Context Function@ +-- to an arity two @Context Function@. -- -- The type signature is as explanatory as a description: --@@ -350,7 +351,7 @@   --- | Apply an arity-one Context function to a single argument, +-- | Apply an arity-one Context Function to a single argument,  -- downcasting it by one level, making an arity-zero Context  -- function.  -- @@ -362,7 +363,7 @@ apply1R1 mf r1      = CF $ \ctx -> unCF1 mf ctx r1  --- | Apply an arity-two Context function to two arguments, +-- | Apply an arity-two Context Function to two arguments,  -- downcasting it by two levels, making an arity-zero Context  -- function.  -- @@ -373,7 +374,7 @@ apply2R2            :: CF2 r1 r2 a -> r1 -> r2 -> CF a apply2R2 mf r1 r2   = CF $ \ctx -> unCF2 mf ctx r1 r2 --- | Apply an arity-two Context function to one argument, +-- | Apply an arity-two Context Function to one argument,  -- downcasting it by one level, making an arity-one Context  -- function.  -- @@ -474,7 +475,7 @@   -- | Downcast a 'LocCF' function by applying it to the supplied --- point, making an arity-zero Context function. +-- point, making an arity-zero Context Function.  --  -- Remember a 'LocCF' function is a 'CF1' context function where -- the /static argument/ is specialized to a start point.@@ -487,7 +488,7 @@   -- | Downcast a 'LocThetaCF' function by applying it to the --- supplied angle, making an arity-one Context function (a +-- supplied angle, making an arity-one Context Function (a  -- 'LocCF').  --  @@ -495,8 +496,16 @@ rot = apply1R2  +-- | Downcast a 'LocThetaCF' function by applying it to the +-- supplied point and angle, making an arity-zero Context +-- Function (a 'CF'). +--+atRot :: LocThetaCF u a -> Point2 u -> Radian -> CF a+atRot = apply2R2++ -- | Downcast a 'ConnectorCF' function by applying it to the --- start and end point, making an arity-zero Context function +-- start and end point, making an arity-zero Context Function  -- (a 'CF').  --  connect :: ConnectorCF u a -> Point2 u -> Point2 u -> CF a@@ -507,7 +516,7 @@ infixr 6 `chain1`  -- | /Chaining/ combinator - the /answer/ of the --- first Context function is feed to the second Context function. +-- first Context Function is feed to the second Context Function.  -- -- This contrasts with the usual idiom in @Wumpus-Basic@ where  -- composite graphics are built by applying both functions to the 

@@ -13,10 +13,10 @@ -- -- Drawing attributes ----- \*\* WARNING \*\* - this module needs systematic naming --- schemes both for update functions (primaryColour, ...) and --- for synthesized selectors (e.g. lowerxHeight). The current --- names will change.+-- \*\* WARNING \*\* - The drawing context modules need systematic +-- naming schemes both for update functions (primaryColour, ...) +-- and for synthesized selectors (e.g. lowerxHeight). The current +-- names in @QueryDC@ and @UpdateDC@ are expected to change. -- --  --------------------------------------------------------------------------------@@ -28,6 +28,8 @@     DrawingContext(..)   , DrawingContextF +  , TextMargin(..)+   , standardContext   , metricsContext @@ -53,7 +55,25 @@ import Control.Applicative import Data.Maybe -+-- | 'DrawingContext' - the \"graphics state\" of Wumpus-Basic. +-- DrawingContext is operated on within a Reader monad rather than +-- a State monad so \"updates\" are delineated within a @local@ +-- operation (called @localize@ in Wumpus), rather than permanent+-- until overridden as per @set@ of a State monad.+-- +-- Note - @round_corner_factor@ is only accounted for by some +-- graphic objects (certain Path objects and Shapes in +-- Wumpus-Drawing for instance). There many be many objects that +-- ignore it and are drawn only with angular corners.+-- +-- Also note - in contrast to most other drawing objects in +-- Wumpus, none of the measurement values are parameteric - +-- usually notated with the type variable @u@ in Wumpus. This is +-- so Wumpus can (potentially) support different units e.g. +-- centimeters rather than just Doubles (represening printers +-- points), though adding support for other units has a very low +-- priority.+--  data DrawingContext = DrawingContext       { glyph_tables          :: GlyphMetrics       , fallback_metrics      :: MetricsOps@@ -62,13 +82,30 @@       , stroke_colour         :: RGBi      -- also text colour...       , fill_colour           :: RGBi             , line_spacing_factor   :: Double+      , round_corner_factor   :: Double +      , text_margin           :: TextMargin       } --- TODO - hand craft a Show instance +-- TODO - what parts of the Drawing Context should be strict?  ++-- | Type synonym for DrawingContext update functions.+-- type DrawingContextF = DrawingContext -> DrawingContext +-- | The unit of Margin is always Double representing Points, e.g.+-- 1.0 is 1 Point. Margins are not scaled relative to the current+-- font size.+-- +-- The default value is 2 point.+--+data TextMargin = TextMargin+       { text_margin_x          :: !Double+       , text_margin_y          :: !Double+       } ++ standardContext :: FontSize -> DrawingContext standardContext sz =      DrawingContext { glyph_tables         = emptyGlyphMetrics@@ -78,23 +115,19 @@                    , stroke_colour        = wumpus_black                    , fill_colour          = wumpus_light_gray                    , line_spacing_factor  = 1.2  +                   , round_corner_factor  = 0+                   , text_margin          = standardTextMargin                    } +standardTextMargin :: TextMargin+standardTextMargin = TextMargin { text_margin_x = 2.0, text_margin_y = 2.0 }+ -- out-of-date - should be adding loaded fonts, not replacing the  -- GlyphMetrics Map wholesale. -- metricsContext :: FontSize -> GlyphMetrics -> DrawingContext metricsContext sz bgm = -    DrawingContext { glyph_tables         = bgm-                   , fallback_metrics     = monospace_metrics-                   , stroke_props         = default_stroke_attr-                   , font_props           = FontAttr sz wumpus_courier-                   , stroke_colour        = wumpus_black-                   , fill_colour          = wumpus_light_gray-                   , line_spacing_factor  = 1.2  -                   }--+    let env = standardContext sz in env { glyph_tables = bgm }   wumpus_black            :: RGBi

@@ -30,6 +30,9 @@   , borderedAttr   , withBorderedAttr +  , getRoundCornerSize+  , getTextMargin+   , getLineWidth   , getFontAttr   , getFontSize@@ -103,6 +106,25 @@     fn <$> asksDC fill_colour <*> asksDC stroke_props                                <*> asksDC stroke_colour +++-- | Vertical distance between baselines of consecutive text +-- lines.+--+getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u+getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1)+                    <$> asksDC round_corner_factor++++-- | Vertical distance between baselines of consecutive text +-- lines.+--+getTextMargin :: (DrawingCtxM m, Fractional u, FromPtSize u) => m (u,u)+getTextMargin = (\(TextMargin xsep ysep) -> (fn xsep, fn ysep))+                    <$> asksDC text_margin+  where+    fn d = (realToFrac d) * fromPtSize 1   

@@ -20,176 +20,85 @@ module Wumpus.Basic.Kernel.Base.ScalingContext   ( -    ScalingM(..)-  , ScalingContext(..)--  , Scaling-  , runScaling-  , ScalingT-  , runScalingT+    ScalingContext(..) -  , regularScalingContext-  , coordinateScalingContext+  , scaleX+  , scaleY+  , scalePt+  , scaleVec    , unitX   , unitY +  , uniformScaling+  , coordinateScaling    ) where -import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.WrappedPrimitive  import Wumpus.Core				-- package: wumpus-core -import Control.Applicative  ---- | Scaling...+-- | ScalingContext is a dictionary of two functions for scaling +-- in X and Y. ---class Monad m => ScalingM m where-  type XDim m :: *-  type YDim m :: *-  scaleX :: (u ~ MonUnit m, ux ~ XDim m) => ux -> m u-  scaleY :: (u ~ MonUnit m, uy ~ YDim m) => uy -> m u-  scalePt  :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) -           => ux -> uy -> m (Point2 u)-  scaleVec :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) -           => ux -> uy -> m (Vec2 u)--- data ScalingContext ux uy u = ScalingContext       { scale_in_x  :: ux -> u       , scale_in_y  :: uy -> u       }  ---- Chains (for example) want a plain monad rather than a transformer.----newtype Scaling ux uy u a = Scaling {-          getScaling :: ScalingContext ux uy u -> a }---type instance MonUnit (Scaling ux uy u) = u+scaleX              :: ScalingContext ux uy u -> ux -> u+scaleX ctx ux       = (scale_in_x ctx) ux +scaleY              :: ScalingContext ux uy u -> uy -> u+scaleY ctx uy       = (scale_in_y ctx) uy  -instance Functor (Scaling ux uy u) where-  fmap f ma = Scaling $ \ctx -> let a = getScaling ma ctx in f a--instance Applicative (Scaling ux uy u) where-  pure a    = Scaling $ \_   -> a-  mf <*> ma = Scaling $ \ctx -> let f = getScaling mf ctx-                                    a = getScaling ma ctx-             			in (f a)--instance Monad (Scaling ux uy u) where-  return a = Scaling $ \_   -> a-  m >>= k  = Scaling $ \ctx -> let a = getScaling m ctx-    	     	               in (getScaling . k) a ctx+scalePt             :: ScalingContext ux uy u -> ux -> uy -> Point2 u+scalePt ctx ux uy   = P2 (scale_in_x ctx ux) (scale_in_y ctx uy) +scaleVec            :: ScalingContext ux uy u -> ux -> uy -> Vec2 u+scaleVec ctx ux uy  = V2 (scale_in_x ctx ux) (scale_in_y ctx uy)  -instance ScalingM (Scaling ux uy u) where-  type XDim (Scaling ux uy u) = ux -  type YDim (Scaling ux uy u) = uy-  scaleX ux       = Scaling $ \ctx -> (scale_in_x ctx) ux-  scaleY uy       = Scaling $ \ctx -> (scale_in_y ctx) uy-  scalePt ux uy   = Scaling $ \ctx -> P2 (scale_in_x ctx ux) (scale_in_y ctx uy)-  scaleVec ux uy  = Scaling $ \ctx -> V2 (scale_in_x ctx ux) (scale_in_y ctx uy)--runScaling :: ScalingContext ux uy u -> Scaling ux uy u a -> a-runScaling ctx sf = (getScaling sf) ctx    +unitX               :: Num ux => ScalingContext ux uy u -> u+unitX ctx           = scaleX ctx 1+ +unitY               :: Num uy => ScalingContext ux uy u -> u+unitY ctx           = scaleY ctx 1     ----------------------------------------------------------------------------------- Transformer---- Turtle (for example) wants a transformer so it can use TraceM--- and DrawingCtxM----newtype ScalingT ux uy u m a = ScalingT { -          getScalingT :: ScalingContext ux uy u -> m a }--type instance MonUnit (ScalingT ux uy u m) = u---instance Monad m => Functor (ScalingT ux uy u m) where-  fmap f ma = ScalingT $ \ctx -> getScalingT ma ctx >>= \a -> return (f a)--instance Monad m => Applicative (ScalingT ux uy u m) where-  pure a    = ScalingT $ \_   -> return a-  mf <*> ma = ScalingT $ \ctx -> getScalingT mf ctx >>= \f -> -                                 getScalingT ma ctx >>= \a ->-             			 return (f a)--instance Monad m => Monad (ScalingT ux uy u m) where-  return a = ScalingT $ \_   -> return a-  m >>= k  = ScalingT $ \ctx -> getScalingT m ctx >>= \a -> -    	     	      	     	(getScalingT . k) a ctx---instance Monad m => ScalingM (ScalingT ux uy u m) where-  type XDim (ScalingT ux uy u m) = ux -  type YDim (ScalingT ux uy u m) = uy-  scaleX ux       = ScalingT $ \ctx -> return $ (scale_in_x ctx) ux-  scaleY uy       = ScalingT $ \ctx -> return $ (scale_in_y ctx) uy-  scalePt ux uy   = ScalingT $ \ctx -> -                      return $ P2 (scale_in_x ctx ux) (scale_in_y ctx uy)-  scaleVec ux uy  = ScalingT $ \ctx -> -                      return $ V2 (scale_in_x ctx ux) (scale_in_y ctx uy)------ Cross instances - needed to run SalingT /locally/ in Drawing.--instance DrawingCtxM m => DrawingCtxM (ScalingT ux uy u m) where-  askDC           = ScalingT $ \_    -> askDC >>= \dctx -> return dctx-  localize upd mf = ScalingT $ \sctx -> localize upd (getScalingT mf sctx)---instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ScalingT ux uy u m) where-  trace a  = ScalingT $ \_ -> trace a -----runScalingT :: ScalingContext ux uy u -> ScalingT ux uy u m a -> m a-runScalingT ctx sf = (getScalingT sf) ctx    ---------------------------------------------------------------------------------- -- constructors for scaling context -regularScalingContext :: Num u => u -> ScalingContext u u u-regularScalingContext u = ScalingContext++-- | Build a ScalingContext where both X and Y are scaled by the +-- same uniform step.+--+-- The dimensions (types) of the ScalingContext are unified - the +-- output type and the input types are all the same.+--+uniformScaling :: Num u => u -> ScalingContext u u u+uniformScaling u = ScalingContext       { scale_in_x  = (\x -> u*x)       , scale_in_y  = (\y -> u*y)       } -coordinateScalingContext :: Num u => u -> u -> ScalingContext Int Int u-coordinateScalingContext sx sy = ScalingContext+++-- | Build a ScalingContext for scaling Int coordinates.+--+-- The scaling factors in X and Y can be different sizes.+---+coordinateScaling :: Num u => u -> u -> ScalingContext Int Int u+coordinateScaling sx sy = ScalingContext       { scale_in_x  = (\x -> sx * fromIntegral x)       , scale_in_y  = (\y -> sy * fromIntegral y)       }   ------------------------------------------------------------------------------------ operations-----unitX :: (ScalingM m, Num ux, ux ~ XDim m, u ~ MonUnit m) => m u-unitX = scaleX 1- -unitY :: (ScalingM m, Num uy, uy ~ YDim m, u ~ MonUnit m) => m u-unitY = scaleY 1-- 

@@ -24,8 +24,12 @@   (     -- * Modifiers +  +    roundCornerFactor+  , textMargin+   -- ** Line widths-    lineWidth+  , lineWidth   , thick   , ultrathick   , thin@@ -83,6 +87,18 @@  updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props++++--------------------------------------------------------------------------------++roundCornerFactor   :: Double -> DrawingContextF+roundCornerFactor d = (\s -> s { round_corner_factor = d })++-- | 'textMargin' : @ xsep * ysep -> DrawingContextF @+--+textMargin   :: Double -> Double -> DrawingContextF+textMargin xsep ysep = (\s -> s { text_margin = TextMargin xsep ysep })   --------------------------------------------------------------------------------

@@ -1,172 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Geometry.Intersection--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Intersection of line to line and line to plane--- --- \*\* - WARNING \*\* - half baked. --------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Geometry.Intersection-  ( -    LineSegment(..)-  , PointSlope-  , pointSlope-  , LineEqn-  , lineEqn-  , toLineEqn-  , findIntersect-  , intersection--  , rectangleLines-  , polygonLines-  , langle-  ) -  where--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace----- WARNING - This module is not very good (neither particularly --- robust, nor efficient).--- --- I really need to find an algorithm that does this properly.-----data LineSegment u = LS (Point2 u) (Point2 u)-  deriving (Eq,Ord,Show)---data PointSlope u = PointSlope -      { _point_slope_point :: Point2 u-      , _point_slope_slope :: u-      }-  deriving (Eq,Show)--pointSlope :: Fractional u => Point2 u -> Radian -> PointSlope u -pointSlope pt theta = PointSlope pt (fromRadian $ tan theta)----- | Line in equational form, i.e. @Ax + By + C = 0@.-data LineEqn u = LineEqn -      { _line_eqn_A :: !u-      , _line_eqn_B :: !u-      , _line_eqn_C :: !u -      }-  deriving (Eq,Show)--lineEqn :: Num u => Point2 u -> Point2 u -> LineEqn u-lineEqn (P2 x1 y1) (P2 x2 y2) = LineEqn a b c -  where-    a = y1 - y2-    b = x2 - x1-    c = (x1*y2) - (x2*y1)---toLineEqn :: Num u => PointSlope u -> LineEqn u-toLineEqn (PointSlope (P2 x0 y0) m) = LineEqn m (-1) ((-m) * x0 + y0)-----data IntersectionResult u = Intersects u u | Contained | NoIntersect-  deriving (Eq,Show)----- Note the uses a /plane/ so is susceptible to picking the --- wrong quadrant...----findIntersect :: (Floating u, Real u, Ord u)-               => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u)-findIntersect ctr ang0 = step -  where-    theta       = circularModulo ang0-    eqn         = toLineEqn $ pointSlope ctr theta-    step []     = Nothing-    step (x:xs) = case intersection x eqn of -                     Just pt | quadrantCheck theta ctr pt -> Just pt-                     _       -> step xs---quadrantCheck :: (Real u, Floating u) -              => Radian -> Point2 u -> Point2 u -> Bool-quadrantCheck theta ctr pt = theta == langle ctr pt--intersection :: (Fractional u, Ord u) -             => LineSegment u -> LineEqn u -> Maybe (Point2 u)-intersection ls@(LS p q) eqn = case intersect1 ls eqn of-    Intersects fp fq -> let t = fp / (fp-fq) in Just $ affineComb p q t -    Contained        -> Just p-    NoIntersect      -> Nothing----intersect1 :: (Num u, Ord u) -           => LineSegment u -> LineEqn u -> IntersectionResult u-intersect1 (LS p q) eqn = -     if inters fp fq then Intersects fp fq-                     else if contained fp fq then Contained else NoIntersect-  where-    inters a b    = (a < 0 && b >= 0) || (a > 0 && b <= 0)-    contained a b = a == 0 && b == 0-    fp            = lineF p eqn-    fq            = lineF q eqn- -lineF :: Num u => Point2 u -> LineEqn u -> u-lineF (P2 x y) (LineEqn a b c) = a*x + b*y + c--affineComb :: Num u => Point2 u -> Point2 u -> u -> Point2 u-affineComb p q t = p .+^ t *^ (q .-. p)-----rectangleLines :: Num u => Point2 u -> u -> u -> [LineSegment u]-rectangleLines ctr hw hh = [LS br tr, LS tr tl, LS tl bl, LS bl br]-  where-    br = ctr .+^ (vec hw    (-hh))-    tr = ctr .+^ (vec hw    hh)-    tl = ctr .+^ (vec (-hw) hh)-    bl = ctr .+^ (vec (-hw) (-hh))---polygonLines :: [Point2 u] -> [LineSegment u]-polygonLines []     = error "polygonLines - emptyList"-polygonLines (x:xs) = step x xs -  where-    step a []        = [LS a x]-    step a (b:bs)    = LS a b : step b bs------ | Calculate the counter-clockwise angle between two points --- and the x-axis.----langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian-langle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1)-  where-    -- north-east quadrant -    step x y | pve x && pve y = toRadian $ atan (y/x)          -    -    -- north-west quadrant-    step x y | pve y          = pi     - (toRadian $ atan (y / abs x))--    -- south-east quadrant-    step x y | pve x          = (2*pi) - (toRadian $ atan (abs y / x)) --    -- otherwise... south-west quadrant-    step x y                  = pi     + (toRadian $ atan (y/x))--    pve a                     = signum a >= 0

@@ -1,114 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Geometry.Paths--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Paths for /elementary/ shapes - rectangles...--- --- \*\* - WARNING \*\* - half baked. --------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Geometry.Paths-  ( -    rectanglePath-  , diamondPath-  , polygonPoints-  , isoscelesTrianglePath-  , isoscelesTrianglePoints-  , equilateralTrianglePath-  , equilateralTrianglePoints-  ) -  where--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space---import Data.List ( unfoldr )---- TODO add regular polygon building from old Wumpus-Extra...---- | Supplied point is /bottom-left/.----rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u-rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ]-  where-    br = bl .+^ hvec w-    tr = br .+^ vvec h-    tl = bl .+^ vvec h ------ | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @----diamondPath :: Num u => u -> u -> Point2 u -> PrimPath u-diamondPath hw hh ctr = primPath s [ lineTo e, lineTo n, lineTo w]-  where-    s     = ctr .+^ vvec (-hh)-    e     = ctr .+^ hvec hw-    n     = ctr .+^ vvec hh-    w     = ctr .+^ hvec (-hw)-    ---- | 'polygonPoints' : @ num_points * radius * center -> [point] @ ----polygonPoints :: Floating u => Int -> u -> Point2 u -> [Point2 u]-polygonPoints n radius ctr = unfoldr phi (0,(pi*0.5))-  where-    theta = (pi*2) / fromIntegral n-    -    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))-                | otherwise = Nothing---- | @isocelesTriangle bw h pt@------ Supplied point is the centriod of the triangle. This has a --- nicer visual balance than using half-height.----isoscelesTrianglePoints :: Floating u -                        => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u)-isoscelesTrianglePoints bw h ctr = (bl, br, top) -  where-    hw         = 0.5*bw -    theta      = atan $ h / hw-    centroid_h = hw * tan (0.5*theta)-    top        = ctr .+^ vvec (h - centroid_h)-    br         = ctr .+^ V2   hw  (-centroid_h)-    bl         = ctr .+^ V2 (-hw) (-centroid_h)------ | @isocelesTriangle bw h pt@------ Supplied point is the centriod of the triangle. This has a --- nicer visual balance than using half-height.----isoscelesTrianglePath :: Floating u => u -> u -> Point2 u -> PrimPath u-isoscelesTrianglePath bw h ctr = primPath bl [ lineTo br, lineTo top ] -  where-    hw         = 0.5*bw -    theta      = atan $ h / hw-    centroid_h = hw * tan (0.5*theta)-    top        = ctr .+^ vvec (h - centroid_h)-    br         = ctr .+^ V2   hw  (-centroid_h)-    bl         = ctr .+^ V2 (-hw) (-centroid_h)--equilateralTrianglePoints :: Floating u -                          => u -> Point2 u -> (Point2 u, Point2 u, Point2 u)-equilateralTrianglePoints sl = isoscelesTrianglePoints sl h-  where-    h = sl * sin (pi/3)--equilateralTrianglePath :: Floating u => u -> Point2 u -> PrimPath u-equilateralTrianglePath sl ctr = primPath bl [ lineTo br, lineTo top ] -  where-    (bl,br,top) = equilateralTrianglePoints sl ctr

@@ -0,0 +1,563 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.CtxPicture+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- A Picture-with-implicit-context object. +-- +-- This is the corresponding type to Picture in the Wumpus-Core.+-- +-- CtxPicture 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.Kernel.Objects.CtxPicture+  (++    CtxPicture+  , DCtxPicture+  , runCtxPicture+  , runCtxPictureU+  , drawTracing++  , clipCtxPicture+  , mapCtxPicture++  -- * 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.Kernel.Base.Anchors+import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.ContextFun+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Objects.TraceDrawing++import Wumpus.Core                              -- package: wumpus-core++import Data.AdditiveGroup                       -- package: vector-space+import Data.AffineSpace++import Control.Applicative+import Data.List ( foldl' )++++newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) }++type DCtxPicture = CtxPicture Double+++type instance DUnit (CtxPicture u) = u+++++runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u)+runCtxPicture ctx drw = runCF ctx (getCtxPicture drw)  +++runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u+runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df+  where+    fk = error "runCtxPictureU - empty CtxPicture."   ++++drawTracing :: (Real u, Floating u, FromPtSize u) +            => TraceDrawing u a -> CtxPicture u+drawTracing mf = CtxPicture $ +    drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) )+++-- Note - cannot get an answer from a TraceDrawing with this +-- CtxPicture type. There is nowhere to put the answer in the type.+--+-- If the type was extended:+--+-- > newtype CtxPicture u a = CtxPicture { getCtxPicture :: CF (a, Maybe (Picture u))) }+--+-- 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)? +--+--------------------------------------------------------------------------------++clipCtxPicture :: (Num u, Ord u) => (PrimPath u) -> CtxPicture u -> CtxPicture u+clipCtxPicture cpath = mapCtxPicture (clip cpath)+++mapCtxPicture :: (Picture u -> Picture u) -> CtxPicture u -> CtxPicture u+mapCtxPicture pf = CtxPicture . fmap (fmap pf) . getCtxPicture++instance (Real u, Floating u) => Rotate (CtxPicture u) where +  rotate ang = mapCtxPicture (rotate ang)++instance (Real u, Floating u) => RotateAbout (CtxPicture u) where+  rotateAbout r pt = mapCtxPicture (rotateAbout r pt)++instance (Num u, Ord u) => Scale (CtxPicture u) where+  scale sx sy = mapCtxPicture (scale sx sy)++instance (Num u, Ord u) => Translate (CtxPicture u) where+  translate dx dy = mapCtxPicture (translate dx dy)++++--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+-- Extract anchors++boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a+boundaryExtr f = f . boundary++-- Operations on bounds++-- | The center of a picture.+--+boundaryCtr :: Fractional u => Picture u -> Point2 u+boundaryCtr = 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) => CtxPicture u+empty_drawing = drawTracing $ return ()+++++--------------------------------------------------------------------------------+-- Composition operators+++drawingConcat :: (Picture u -> Picture u -> Picture u) +              -> CtxPicture u -> CtxPicture u -> CtxPicture u+drawingConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)++++mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a)+mbpostcomb op = liftA2 fn +  where+    fn (Just a) (Just b) = Just $ a `op` b+    fn a        Nothing  = a+    fn Nothing  b        = b+++-- 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 CtxPictures.+--+-- 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) +          -> CtxPicture u -> CtxPicture u+          -> CtxPicture 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) => CtxPicture u -> CtxPicture u -> CtxPicture u+over    = drawingConcat picOver++++-- | > a `under` b+--+-- Similarly @under@ draws the first drawing behind +-- the second but move neither.+--+under :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u+under = flip over++++-- | Move in both the horizontal and vertical.+--+move :: (Num u, Ord u) => Vec2 u -> CtxPicture u -> CtxPicture u+move v = mapCtxPicture (\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) => CtxPicture u -> CtxPicture u -> CtxPicture u+centric = megaCombR boundaryCtr boundaryCtr 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) => CtxPicture u -> CtxPicture u -> CtxPicture 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) => CtxPicture u -> CtxPicture u -> CtxPicture 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) => CtxPicture u -> Point2 u  -> CtxPicture u+p `atPoint` (P2 x y) = move (V2 x y) p++++-- | Center the picture at the supplied point.+--+centeredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u+centeredAt d (P2 x y) = mapCtxPicture 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) => [CtxPicture u] -> CtxPicture u+zconcat []     = empty_drawing+zconcat (d:ds) = foldl' over d ds+++++-- | Concatenate the list pictures @xs@ horizontally.+-- +hcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture 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) => [CtxPicture u] -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture u+vsepA _  _ []     = empty_drawing+vsepA va n (d:ds) = foldl' op d ds+  where +    a `op` b = alignVSep va n a b +++

@@ -1,563 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.Drawing--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ 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.Kernel.Objects.Drawing-  (--    Drawing-  , DDrawing-  , runDrawing-  , runDrawingU-  , drawTracing--  , clipDrawing-  , modifyDrawing--  -- * 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.Kernel.Base.Anchors-import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Objects.TraceDrawing--import Wumpus.Core                              -- package: wumpus-core--import Data.AdditiveGroup                       -- package: vector-space-import Data.AffineSpace--import Control.Applicative-import Data.List ( foldl' )----newtype Drawing u = Drawing { getDrawing :: CF (Maybe (Picture u)) }--type DDrawing = Drawing Double---type instance DUnit (Drawing u) = u-----runDrawing :: DrawingContext -> Drawing u -> Maybe (Picture u)-runDrawing ctx drw = runCF ctx (getDrawing drw)  ---runDrawingU :: DrawingContext -> Drawing u -> Picture u-runDrawingU ctx df = maybe fk id $ runDrawing ctx df-  where-    fk = error "runDrawingU - empty Drawing."   ----drawTracing :: (Real u, Floating u, FromPtSize u) -            => TraceDrawing u a -> Drawing u-drawTracing mf = Drawing $ -    drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) )----- Note - cannot get an answer from a TraceDrawing with this --- Drawing type. There is nowhere to put the answer in the type.------ If the type was extended:------ > newtype Drawing u a = Drawing { getDrawing :: CF (a, Maybe (Picture u))) }------ 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)? --------------------------------------------------------------------------------------clipDrawing :: (Num u, Ord u) => (PrimPath u) -> Drawing u -> Drawing u-clipDrawing cpath = modifyDrawing (clip cpath)---modifyDrawing :: (Picture u -> Picture u) -> Drawing u -> Drawing u-modifyDrawing pf = Drawing . fmap (fmap pf) . getDrawing--instance (Real u, Floating u) => Rotate (Drawing u) where -  rotate ang = modifyDrawing (rotate ang)--instance (Real u, Floating u) => RotateAbout (Drawing u) where-  rotateAbout r pt = modifyDrawing (rotateAbout r pt)--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)-------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Extract anchors--boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a-boundaryExtr f = f . boundary---- Operations on bounds---- | The center of a picture.----boundaryCtr :: Fractional u => Picture u -> Point2 u-boundaryCtr = 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---drawingConcat :: (Picture u -> Picture u -> Picture u) -              -> Drawing u -> Drawing u -> Drawing u-drawingConcat op a b = Drawing $ mbpostcomb op (getDrawing a) (getDrawing b)----mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a)-mbpostcomb op = liftA2 fn -  where-    fn (Just a) (Just b) = Just $ a `op` b-    fn a        Nothing  = a-    fn Nothing  b        = b----- 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 boundaryCtr boundaryCtr 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 ---

@@ -92,7 +92,6 @@ import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Geometry.Paths import Wumpus.Basic.Kernel.Objects.BaseObjects  import Wumpus.Core                              -- package: wumpus-core@@ -404,6 +403,15 @@ drawWith :: (Point2 u -> PrimPath u) -> (PrimPath u -> Graphic u) -> LocGraphic u  drawWith g mf = promoteR1 $ \pt -> mf (g pt) ++-- | Supplied point is /bottom-left/.+--+rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u+rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ]+  where+    br = bl .+^ hvec w+    tr = br .+^ vvec h+    tl = bl .+^ vvec h  -- | Supplied point is /bottom left/. --

@@ -0,0 +1,349 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Utils.JoinList+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- A \"join list\" datatype and operations. +--+-- A join list is implemented a binary tree, so joining two +-- lists (catenation, aka (++)) is a cheap operation. +--+-- This constrasts with the regular list datatype which is a +-- cons list: while consing on a regular list is by nature cheap, +-- joining (++) is expensive. +--+--------------------------------------------------------------------------------+++module Wumpus.Basic.Utils.JoinList +  ( +  -- * Join list datatype, opaque.+    JoinList++  -- * Left view as per Data.Sequence  +  , ViewL(..)+  , ViewR(..)++  -- * Conversion between join lists and regular lists+  , fromList+  , fromListF+  , toList+  , toListF+  , toListM+  , zipWithIntoList++  -- * Construction+  , empty+  , one+  , cons+  , snoc+  , join++  -- * Basic functions  +  , head+  , takeL+  , length++  , takeWhileL+  , accumMapL+  , null+++  -- * Views+  , viewl+  , viewr+  , unViewL+  , unViewR+  +  ) where+++import Control.Applicative hiding ( empty )+import Control.Monad hiding ( join )++import Data.Foldable ( Foldable )+import qualified Data.Foldable as F+import Data.Monoid+import Data.Traversable ( Traversable(..) )++import Prelude hiding ( head, take, length, mapM, null )++data JoinList a = Empty +                | One a +                | Join (JoinList a) (JoinList a)+  deriving (Eq)++data ViewL a = EmptyL | a :< (JoinList a)+  deriving (Eq,Show)++data ViewR a = EmptyR | (JoinList a) :> a+  deriving (Eq,Show)++--------------------------------------------------------------------------------++instance Show a => Show (JoinList a) where+  showsPrec _ xs = showString "fromList " . shows (toList xs) +++instance Monoid (JoinList a) where+  mempty        = Empty+  mappend       = join++instance Functor JoinList where+  fmap _ Empty      = Empty+  fmap f (One a)    = One (f a)+  fmap f (Join t u) = Join (fmap f t) (fmap f u)++++instance Foldable JoinList where+  foldMap _ Empty      = mempty+  foldMap f (One a)    = f a+  foldMap f (Join t u) = F.foldMap f t `mappend` F.foldMap f u++  foldr                = joinfoldr+  foldl                = joinfoldl++instance Traversable JoinList where+  traverse _ Empty      = pure Empty+  traverse f (One a)    = One <$> f a+  traverse f (Join t u) = Join <$> traverse f t <*> traverse f u++  mapM mf               = step . viewl+    where+      step EmptyL    = return Empty+      step (x :< xs) = liftM2 cons (mf x) (step $ viewl xs)+++-- Views++instance Functor ViewL where+  fmap _ EmptyL         = EmptyL+  fmap f (a :< as)      = f a :< fmap f as++instance Functor ViewR where+  fmap _ EmptyR         = EmptyR+  fmap f (as :> a)      = fmap f as :> f a+++--------------------------------------------------------------------------------+-- Conversion++-- | Convert a join list to a regular list.+--+toList :: JoinList a -> [a]+toList = joinfoldl (flip (:)) []++++-- | Build a join list from a regular list.+--+-- This builds a tall skinny list.+--+-- WARNING - throws an error on empty list.+--++fromList :: [a] -> JoinList a+fromList []     = Empty+fromList [x]    = One x+fromList (x:xs) = Join (One x) (fromList xs)++fromListF :: (a -> b) -> [a] -> JoinList b+fromListF f = step +  where+    step []     = Empty+    step [x]    = One (f x)+    step (x:xs) = Join (One $ f x) (step xs)+++toListF :: (a -> b) -> JoinList a -> [b]+toListF f = ($ []) . step +  where+    step Empty       = id+    step (One x)     = (\ls -> f x : ls)+    step (Join t u)  = step t . step u+++toListM :: Monad m => (a -> m b) -> JoinList a -> m [b]+toListM mf = liftM ($ []) . step +  where+    step Empty       = return id+    step (One x)     = mf x >>= \a -> return (\ls -> a : ls)+    step (Join t u)  = step t >>= \f -> step u >>= \g  -> return (f . g)+++zipWithIntoList :: (a -> b -> c) -> JoinList a -> [b] -> [c]+zipWithIntoList f jl xs0 = step (viewl jl) xs0+  where+    step EmptyL    _      = []+    step _         []     = []+    step (a :< as) (x:xs) = f a x : step (viewl as) xs++--------------------------------------------------------------------------------+++null :: JoinList a -> Bool+null Empty       = True+null _           = False+++++-- | Create an empty join list.+--+empty :: JoinList a+empty = Empty++++-- | Create a singleton join list.+--+one :: a -> JoinList a+one = One++++infixr 5 `cons`++-- | Cons an element to the front of the join list.+--+cons :: a -> JoinList a -> JoinList a+cons a xs = Join (One a) xs  ++-- | Snoc an element to the tail of the join list.+--+snoc :: JoinList a -> a -> JoinList a+snoc xs a = Join xs (One a)+++++infixr 5 `join`++--+join :: JoinList a -> JoinList a -> JoinList a+join Empty b     = b+join a     Empty = a +join a     b     = Join a b+++--------------------------------------------------------------------------------+-- Basic functions++-- | Extract the first element of a join list - i.e. the leftmost+-- element of the left spine. An error is thrown if the list is +-- empty. +-- +-- This function performs a traversal down the left spine, so +-- unlike @head@ on regular lists this function is not performed +-- in constant time.+--+-- This function throws a runtime error on the empty list.+-- +head :: JoinList a -> a+head Empty      = error "JoinList - head called on empty list"+head (One a)    = a+head (Join t _) = head t+++takeL :: Int -> JoinList a -> JoinList a+takeL i xs | i < 1     = Empty+           | otherwise = case viewl xs of+                           a :< rest -> cons a $ takeL (i-1) rest+                           EmptyL    -> Empty     ++length :: JoinList a -> Int+length = joinfoldr (\_ n -> n+1) 0 ++++takeWhileL :: (a -> Bool) -> JoinList a -> JoinList a+takeWhileL test = step . viewl+  where+    step EmptyL                 = Empty+    step (x :< xs)  | test x    = x `cons` step (viewl xs)+                    | otherwise = Empty  +++accumMapL :: (x -> st -> (y,st)) -> JoinList x -> st -> (JoinList y,st)+accumMapL f xs st0 = go xs st0 +  where+    go Empty       st = (Empty,st)+    go (One x)     st = let (y,st') = f x st in (One y,st')+    go (Join t u)  st = (Join v w, st'')+                             where (v,st')  = go t st+                                   (w,st'') = go u st'+++++-- | Right-associative fold of a JoinList.+--+joinfoldr :: (a -> b -> b) -> b -> JoinList a -> b+joinfoldr f = go+  where+    go e Empty      = e+    go e (One a)    = f a e+    go e (Join t u) = go (go e u) t+++-- | Left-associative fold of a JoinList.+--+joinfoldl :: (b -> a -> b) -> b -> JoinList a -> b+joinfoldl f = go +  where+    go e Empty      = e+    go e (One a)    = f e a+    go e (Join t u) = go (go e t) u++--------------------------------------------------------------------------------+-- Views++-- | Access the left end of a sequence.+--+-- Unlike the corresponing operation on Data.Sequence this is +-- not a cheap operation, the joinlist must be traversed down +-- the left spine to find the leftmost node.+--+-- Also the traversal may involve changing the shape of the +-- underlying binary tree.+--+viewl :: JoinList a -> ViewL a+viewl Empty      = EmptyL+viewl (One a)    = a :< Empty+viewl (Join t u) = step t u+  where+    step Empty        r = viewl r+    step (One a)      r = a :< r+    step (Join t' u') r = step t' (Join u' r)++-- | Access the right end of a sequence.+--+-- Unlike the corresponing operation on Data.Sequence this is +-- not a cheap operation, the joinlist must be traversed down +-- the left spine to find the leftmost node.+--+-- Also the traversal may involve changing the shape of the +-- underlying binary tree.+--+viewr :: JoinList a -> ViewR a+viewr Empty      = EmptyR+viewr (One a)    = Empty :> a+viewr (Join t u) = step t u+  where+    step l Empty        = viewr l+    step l (One a)      = l :> a+    step l (Join t' u') = step (Join l t') u'+++unViewL :: ViewL a -> JoinList a+unViewL EmptyL    = Empty+unViewL (x :< xs) = cons x xs++unViewR :: ViewR a -> JoinList a+unViewR EmptyR    = Empty+unViewR (xs :> x) = snoc xs x+

@@ -23,7 +23,7 @@  -- | Version number ----- > (0,14,0)+-- > (0,15,0) -- wumpus_basic_version :: (Int,Int,Int)-wumpus_basic_version = (0,14,0)+wumpus_basic_version = (0,15,0)

@@ -1,28 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Arrows--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Shim module for arrow connectors and arrowheads.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Arrows-  ( --    module Wumpus.Drawing.Arrows.Tips-  , module Wumpus.Drawing.Arrows.Connectors--  ) where--import Wumpus.Drawing.Arrows.Tips-import Wumpus.Drawing.Arrows.Connectors--

@@ -1,149 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Arrows.Connectors--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Draw arrows.--------------------------------------------------------------------------------------module Wumpus.Drawing.Arrows.Connectors-  ( --    Connector-  , connector-  , leftArrow-  , rightArrow-  , dblArrow-  , leftrightArrow-  , strokeConnector---  ) where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Arrows.Tips-import Wumpus.Drawing.Paths--import Wumpus.Core                      -- package: wumpus-core--import Control.Applicative---- An arrowhead always know how to draw itself (filled triangle, --- stroked barb, etc.)------ A Path might will typically be drawn with openStroke,--- eventually there might be scope for drawing --- e.g. parallel lines  ====------- A ConnectorPath gets wrapped with how it is drawn into--- another type.---data Connector u = Connector -      { connector_path  :: ConnectorPath u-      , opt_left_arrow  :: Maybe (Arrowhead u)-      , opt_right_arrow :: Maybe (Arrowhead u)-      }----- | connector with no arrow heads.----connector :: ConnectorPath u -> Connector u-connector cp = -    Connector { connector_path  = cp-              , opt_left_arrow  = Nothing-              , opt_right_arrow = Nothing-              }--leftArrow :: ConnectorPath u -> Arrowhead u -> Connector u-leftArrow cp la =-    Connector { connector_path  = cp-              , opt_left_arrow  = Just la-              , opt_right_arrow = Nothing-              }---rightArrow :: ConnectorPath u -> Arrowhead u -> Connector u-rightArrow cp ra = -    Connector { connector_path  = cp-              , opt_left_arrow  = Nothing-              , opt_right_arrow = Just ra-              }---- | Same tip both ends.----dblArrow :: ConnectorPath u -> Arrowhead u -> Connector u-dblArrow cp arw = leftrightArrow cp arw arw--leftrightArrow :: ConnectorPath u -> Arrowhead u -> Arrowhead u -> Connector u-leftrightArrow cp la ra =-    Connector { connector_path  = cp-              , opt_left_arrow  = Just la-              , opt_right_arrow = Just ra-              }----strokeConnector :: (Real u, Floating u) -                => Connector u -> ConnectorImage u (Path u)-strokeConnector (Connector cpF opt_la opt_ra) =-    promoteR2 $ \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) -                 (fmap (bimapR (gfR . gfL)) $ drawP $ shortenPath dl dr pathc) -  where-    drawP       = openStroke . toPrimPath   ----- for Paths.Base ?----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 --- it has to wrap the tips back up as Graphics with @pure@ so they --- can be concatenated to the drawn path as GraphicTrafos.------ The Arrowhead type could be changed, so rather than returning --- an Image (retract_distance, PrimGraphic) it returns --- (retract_distance, GraphicTrafo) but that would burden all --- arrowheads with some extra complexity.--- --- In short - the code here works but it isn\'t exemplary, and it --- doesn\'t show whether or not GraphicTrafo is a valuable type or--- if it is implemented correctly (as GraphicTrafo could having--- different implementations according to how it regards the --- DrawingCtx).-----tipEval :: Num u -        => Maybe (Arrowhead u) -> Point2 u -> Radian-        -> CF (u, ArrowMark u)-tipEval Nothing    _  _     = return (0,unmarked)-tipEval (Just arw) pt theta = makeMark $ apply2R2 (getArrowhead arw) pt theta---unmarked :: ArrowMark u-unmarked = id---makeMark :: Image u a -> CF (a, ArrowMark u)-makeMark = fmap (\(a,prim) -> (a, (`oplus` prim)))---

@@ -1,505 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Arrows.Tips--- 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 in future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Arrows.Tips-  ( ---    Arrowhead(..)-- -  , tri90-  , tri60-  , tri45-  , otri90-  , otri60-  , otri45--  , revtri90-  , revtri60-  , revtri45-  , orevtri90-  , orevtri60-  , orevtri45--  , barb90-  , barb60-  , barb45-  , revbarb90-  , revbarb60-  , revbarb45--  , perp--  , bracket--  , diskTip-  , odiskTip-  , squareTip-  , osquareTip-  , diamondTip-  , odiamondTip--  , curveTip-  , revcurveTip--  ) where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Paths--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space--import Control.Applicative----- | Encode an arrowhead as an image where the /answer/ is the--- retract distance.------ The retract distance is context sensitive - usually just on--- the markHeight (or halfMarkHeight) so it has to be calculated--- w.r.t. the DrawingCtx.----newtype Arrowhead u = Arrowhead { getArrowhead :: LocThetaImage u u }------- | Tiplen is length of the tip \*along the line it follows\*. ------ > |\--- > | \--- > | /--- > |/--- > --- > |  |  -- tip len------- | Tip width is the distance between upper and lower --- arrow points.------ >       __--- > |\    --- > | \   tip--- > | /   width--- > |/    __--- >       ------ | This one is for triangular tips defined by their tip angle--- e.g. 90deg, 60deg, 45deg.------ The tip width will be variable (tip length should be the --- markHeight).--- -triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u)-triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower)-  where-    hypo_len     = tiplen / (fromRadian $ cos halfang)-    rtheta       = pi + theta        -- theta in the opposite direction-    vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len-    vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len ------ | This one is for triangles when the tip height and tip width--- are known.----triVecsByDist  :: (Real u, Floating u) -               => u -> u -> Radian -> (Vec2 u, Vec2 u)-triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower)-  where-    hypo_len     = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth)-    halfang      = toRadian $ atan (half_tipwidth / tiplen) -    rtheta       = pi + theta        -- theta in the opposite direction-    vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len-    vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len -----{--markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u-markHeightPlusLineWidth = -    (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth--}---markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u-markHeightLessLineWidth = -    (\h lw -> h - realToFrac lw) <$> markHeight <*> getLineWidth----- noRetract ignores both the angle and the point.------ Its common for the rectraction not to care about the angle or --- the point and only care about the DrawingCtx.----noRetract :: Num u => LocThetaCF u u-noRetract = promoteR2 $ \_ _ -> pure 0 --------------------------------------------------------------------------------------tipBody :: FromPtSize u => (Point2 u -> Radian -> u -> CF a) -> LocThetaCF u a-tipBody mf = promoteR2 $ \pt theta -> markHeight >>= \h -> mf pt theta h ---- | Tripoints takes the \*tip length\* is the mark height.------ This means that the 90deg tip has a tip width greater-than the--- mark height (but that is okay - seemingly this is how TikZ --- does it).----tripointsByAngle :: (Floating u, FromPtSize u)-                 => Radian -> LocThetaCF u (Point2 u, Point2 u)-tripointsByAngle triang = -    tipBody $ \pt theta h -> -      let (vup,vlo) = triVecsByAngle h (0.5*triang) theta-      in  pure (pt .+^ vup, pt .+^ vlo)-    --revtripointsByAngle :: (Floating u, FromPtSize u)-                    => Radian -                    -> LocThetaCF u (Point2 u, Point2 u, Point2 u)-revtripointsByAngle triang = -    tipBody $ \pt theta h -> -      let theta'    = circularModulo $ pi+theta -          (vup,vlo) = triVecsByAngle h (0.5*triang) theta'-          back_tip  = pt .-^ avec theta h -      in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo)----tripointsByDist :: (Real u, Floating u, FromPtSize u)-                => LocThetaCF u (Point2 u, Point2 u)-tripointsByDist = -    tipBody $ \pt theta h -> -      let (vup,vlo) = triVecsByDist h (0.5*h) theta-      in pure (pt .+^ vup, pt .+^ vlo)-  ---revtripointsByDist :: (Real u, Floating u, FromPtSize u)-                   => LocThetaCF u (Point2 u, Point2 u, Point2 u)-revtripointsByDist = -    tipBody $ \pt theta h -> -      let theta'    = circularModulo $ pi+theta -          (vup,vlo) = triVecsByDist h (0.5*h) theta'-          back_tip  = pt .-^ avec theta h -      in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo)-------- width = xchar_height--- filled with stroke colour!--triTLG :: (Floating u, Real u, FromPtSize u)-       => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u-triTLG triang drawF = -    promoteR2 $ \pt theta ->-      localize bothStrokeColour $ -         apply2R2 (tripointsByAngle triang) pt theta >>= \(u,v) -> -           drawF $ vertexPath [pt,u,v]----tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri90 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/2) filledPath)---tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri60 = Arrowhead $-    intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/3) filledPath)---tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri45 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/4) filledPath)--otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri90 = Arrowhead $-    intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/2) closedStroke)--otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri60 = Arrowhead $   -    intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/3) closedStroke)--otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri45 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/4) closedStroke)----- width = xchar_height--- filled with stroke colour!--revtriTLG :: (Floating u, Real u, FromPtSize u)-          => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u-revtriTLG triang drawF = -    promoteR2 $ \pt theta -> -      localize bothStrokeColour $ -        apply2R2 (revtripointsByAngle triang) pt theta >>= \(u,pt',v) -> -           drawF $ vertexPath [u,pt',v]----revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revtri90 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeightLessLineWidth) -                      (revtriTLG (pi/2) filledPath)--revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revtri60 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeightLessLineWidth) -                      (revtriTLG (pi/3) filledPath)--revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revtri45 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeightLessLineWidth) -                      (revtriTLG (pi/4) filledPath)---orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri90 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeightLessLineWidth) -                      (revtriTLG (pi/2) closedStroke)--orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri60 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeightLessLineWidth) -                      (revtriTLG (pi/3) closedStroke)--orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri45 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeightLessLineWidth) -                      (revtriTLG (pi/4) closedStroke)----barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u-barbTLG ang =  -    promoteR2 $ \pt theta -> -      apply2R2 (tripointsByAngle ang) pt theta >>= \(u,v) -> -        openStroke $ vertexPath [u,pt,v]----barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb90 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/2))--barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb60 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/3))---barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb45 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/4))----revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u-revbarbTLG ang = -    promoteR2 $ \pt theta -> -      apply2R2 (revtripointsByAngle ang) pt theta >>= \(u,pt',v) -> -        openStroke $ vertexPath [u,pt',v]--revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb90 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeight) (revbarbTLG (pi/2))---revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb60 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeight) (revbarbTLG (pi/3))--revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb45 = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeight) (revbarbTLG (pi/4))---perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u-perpTLG = -    tipBody $ \pt theta h -> -      let hh = 0.5*h in openStroke $ rperpPath hh pt theta---rperpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u-rperpPath 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 $ intoLocThetaImage noRetract perpTLG----bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u-bracketTLG = -    tipBody $ \pt theta h -> -      let hh = 0.5*h in openStroke $ rbracketPath hh pt theta---rbracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u-rbracketPath 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 $ intoLocThetaImage noRetract bracketTLG---diskTLG :: (Floating u, FromPtSize u) -        => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u-diskTLG drawF = -    tipBody $ \pt theta h -> let hh  = 0.5*h -                                 ctr = pt .-^ avec theta hh -                             in drawF hh ctr---diskTip :: (Floating u, FromPtSize u) => Arrowhead u-diskTip = Arrowhead $ intoLocThetaImage (lift0R2 markHeight) (diskTLG drawF)-  where-    drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt---odiskTip :: (Floating u, FromPtSize u) => Arrowhead u-odiskTip = Arrowhead $ intoLocThetaImage (lift0R2 markHeight) (diskTLG drawF)-  where-    drawF r pt = strokedDisk r `at` pt---squareTLG :: (Floating u, FromPtSize u) -        => (PrimPath u -> Graphic u) -> LocThetaGraphic u-squareTLG drawF = -    tipBody $ \pt theta h -> drawF $ rsquarePath pt theta (0.5*h)---rsquarePath :: Floating u => Point2 u -> Radian -> u -> PrimPath u-rsquarePath pt theta hh = vertexPath [p0,p1,p2,p3]-  where-    p0 = displacePerpendicular     hh  theta pt-    p3 = displacePerpendicular   (-hh) theta pt-    p1 = displaceParallel      (-2*hh) theta p0-    p2 = displaceParallel      (-2*hh) theta p3-    --squareTip :: (Floating u, FromPtSize u) => Arrowhead u-squareTip = Arrowhead $ intoLocThetaImage (lift0R2 markHeight) (squareTLG drawF)-  where-    drawF = localize bothStrokeColour . filledPath---osquareTip :: (Floating u, FromPtSize u) => Arrowhead u-osquareTip = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeight) (squareTLG closedStroke)---diamondTLG :: (Floating u, FromPtSize u) -           => (PrimPath u -> Graphic u) -> LocThetaGraphic u-diamondTLG drawF = -    tipBody $ \pt theta h -> drawF $ rdiamondPath pt theta (0.5*h)- --rdiamondPath :: Floating u => Point2 u -> Radian -> u -> PrimPath u-rdiamondPath pt theta hh = vertexPath [pt,p1,p2,p3]-  where-    ctr = displaceParallel       (-2*hh) theta pt-    p1  = displacePerpendicular     hh   theta ctr-    p3  = displacePerpendicular   (-hh)  theta ctr-    p2  = displaceParallel       (-4*hh) theta pt-         ---diamondTip :: (Floating u, FromPtSize u) => Arrowhead u-diamondTip = Arrowhead $ -    intoLocThetaImage (lift0R2 $ fmap (2*) markHeightLessLineWidth) -                      (diamondTLG drawF)-  where-    drawF = localize bothStrokeColour . filledPath---odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u-odiamondTip = Arrowhead $ -    intoLocThetaImage (lift0R2 $ fmap (2*) markHeight) (diamondTLG closedStroke)------- Note - points flipped to get the second trapezium to --- draw /underneath/.----curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u-curveTLG = -    tipBody $ \pt theta h -> -      cxCurvePath pt theta (0.5*h) >>= \path ->-        localize (joinRound . capRound) (openStroke path)---cxCurvePath :: (Real u, Floating u, FromPtSize u) -            => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u)-cxCurvePath pt theta hh =-     apply2R2 tripointsByDist pt theta >>= \(tup,tlo) -> -          let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup-              (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt -          in pure $ toPrimPath $ curve tup u2 u1 pt `append` curve pt l1 l2 tlo-----curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u-curveTip = Arrowhead $ -    intoLocThetaImage (lift0R2 $ fmap realToFrac getLineWidth) curveTLG----- Note - points flipped to get the second trapezium to --- draw /underneath/.----revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u-revcurveTLG = -    tipBody $ \pt theta h ->-      cxRevcurvePath pt theta (0.5*h) >>= \path ->-        localize (joinRound . capRound) (openStroke path)--cxRevcurvePath :: (Real u, Floating u, FromPtSize u) -               => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u)-cxRevcurvePath pt theta hh = -    apply2R2 revtripointsByDist pt theta >>= \(tup,p1,tlo) -> -      let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup-          (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1-      in pure$ toPrimPath $ curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo---revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u-revcurveTip = Arrowhead $ -    intoLocThetaImage (lift0R2 markHeight) revcurveTLG-

@@ -1,29 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Chains--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Shim module.------ WARNING - very unstable.--------------------------------------------------------------------------------------module Wumpus.Drawing.Chains-  (-    module Wumpus.Drawing.Chains.Base-  , module Wumpus.Drawing.Chains.Derived-  --  ) where---import Wumpus.Drawing.Chains.Base-import Wumpus.Drawing.Chains.Derived

@@ -1,161 +0,0 @@-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE RankNTypes                 #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Chains.Base--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Generate points in an iterated chain.------ WARNING - very unstable.--------------------------------------------------------------------------------------module Wumpus.Drawing.Chains.Base-  (---    Chain-  , LocChain-  , chain-  , chainFrom-  , unchain---  , AnaAlg(..)-  , IterAlg(..)--  , BivariateAlg-  , bivariate-  -  , SequenceAlg-  , iteration--  , bounded-  , pairOnXs-  , pairOnYs--  ) where--import Wumpus.Basic.Kernel--import Wumpus.Core                              -- package: wumpus-core----- Chain uses the Scaling monad, but it is not itself a monad.---newtype Chain ux uy u = Chain { getChain :: Scaling ux uy u [Point2 u] }---type LocChain ux uy u = Point2 u -> Chain ux uy u----chain :: BivariateAlg ux uy -> Chain ux uy u-chain alg = Chain (scaledBivariatePt alg)--chainFrom :: Num u => BivariateAlg ux uy -> LocChain ux uy u-chainFrom alg start = Chain (scaledBivariateVec alg start)---unchain :: ScalingContext ux uy u -> Chain ux uy u -> [Point2 u]-unchain ctx ch = runScaling ctx $ getChain ch- ---- | Chains are built as unfolds - AnaAlg avoids the pair --- constructor in the usual definition of unfoldr and makes the--- state strict.------ It is expected that all Chains built on unfolds will terminate. ----data AnaAlg st a = Done | Step a !st----- | IterAlg is a variant of AnaAlg that builds infinite --- sequences (iterations).--- --- When lifted to a Chain an iteration is bounded by a count so--- it will terminate.----data IterAlg st a = IterStep a !st ---data BivariateAlg ux uy = forall st. BivariateAlg-      { st_zero     :: st-      , gen_step    :: st -> AnaAlg st (ux,uy)-      }--bivariate :: st -> (st -> AnaAlg st (ux,uy)) -> BivariateAlg ux uy-bivariate st0 step_alg = BivariateAlg { st_zero = st0-                                      , gen_step = step_alg }---scaledBivariatePt :: BivariateAlg ux uy -> Scaling ux uy u [Point2 u]-scaledBivariatePt (BivariateAlg { st_zero = st0, gen_step = step}) = -    go (step st0)   -  where-    go Done              = return []-    go (Step (x,y) next) = scalePt x y    >>= \pt   ->-                           go (step next) >>= \rest ->  -                           return  (pt:rest)---- Note - cannot encode this with (.+^) from Data.AffineSpace.--- The u (u ~ MonUnit m) extracted from the Scaling Context is --- not compatible with the u that forms Points (u ~ Diff (Point2 u)).--scaledBivariateVec :: Num u -                   => BivariateAlg ux uy -                   -> Point2 u -                   -> Scaling ux uy u [Point2 u]-scaledBivariateVec (BivariateAlg { st_zero = st0, gen_step = step}) (P2 x0 y0) = -    go (step st0)   -  where-    go Done              = return []-    go (Step (x,y) next) = scaleVec x y   >>= \(V2 dx dy)   ->-                           go (step next) >>= \rest ->  -                           return (P2 (x0+dx) (y0+dy):rest)---data SequenceAlg a = forall st. SequenceAlg-      { initial_st  :: st-      , iter_step   :: st -> IterAlg st a-      }--iteration :: (a -> a) -> a -> SequenceAlg a-iteration fn s0 = SequenceAlg { initial_st = s0, iter_step = step }-  where-    step s = IterStep s (fn s)---bounded :: Int -> SequenceAlg (ux,uy) -> BivariateAlg ux uy-bounded n (SequenceAlg a0 fn) =-    BivariateAlg { st_zero     = (0,a0)-                 , gen_step    = gstep  }-  where-    gstep (i,s) | i < n = let (IterStep ans next) = fn s in Step ans (i+1,next)-    gstep _             = Done-----pairOnXs :: (ux -> uy) -> SequenceAlg ux -> SequenceAlg (ux,uy)-pairOnXs fn (SequenceAlg { initial_st = s0, iter_step = step }) = -    SequenceAlg s0 step2-  where-    step2 s = let (IterStep a s') = step s in IterStep (a, fn a) s'---pairOnYs :: (r -> l) -> SequenceAlg r -> SequenceAlg (l,r) -pairOnYs fn (SequenceAlg { initial_st = s0, iter_step = step }) = -    SequenceAlg  s0 step2-  where-    step2 s = let (IterStep a s') = step s in IterStep (fn a, a) s'-

@@ -1,129 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Chains.Derived--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Generate points in an iterated chain.------ WARNING - very unstable.--------------------------------------------------------------------------------------module Wumpus.Drawing.Chains.Derived-  (-    -    univariateX-  , univariateY--  , tableDown-  , tableRight--  , horizontal-  , vertical--  , horizontals-  , verticals--  , rescale--  ) where--import Wumpus.Drawing.Chains.Base-----univariateX :: (Fractional uy, Num ux, Num u) -            => [ux] -> LocChain ux uy u-univariateX zs = chainFrom $ bivariate (0,zs) gstep-  where-    gstep (_,[])     = Done -    gstep (n,x:xs)   = Step (x,n) (n+i,xs)-    len              = length zs-    i                = rescale 0 1 0 (fromIntegral $ len-1) 1---univariateY :: (Fractional ux, Num uy, Num u) -            => [uy] -> LocChain ux uy u-univariateY zs = chainFrom $ bivariate (0,zs) gstep-  where-    gstep (_,[])     = Done -    gstep (n,y:ys)   = Step (n,y) (n+i,ys)-    len              = length zs-    i                = rescale 0 1 0 (fromIntegral $ len-1) 1--------------------------------------------------------------------------------------- Tables---tableDown :: Int -> Int -> Chain Int Int u-tableDown rows cols = -    chain $ bounded (rows*cols) (iteration (downstep rows) (0,rows-1))----downstep :: Int -> (Int,Int) -> (Int,Int)-downstep row_count (x,y) | y == 0 = (x+1,row_count-1)-downstep _         (x,y)          = (x,y-1)----tableRight :: Num u => Int -> Int -> Chain Int Int u-tableRight rows cols = -    chain $ bounded (rows*cols) (iteration (rightstep cols) (0,rows-1))---rightstep :: Int -> (Int,Int) -> (Int,Int)-rightstep col_count (x,y) | x == (col_count-1) = (0,y-1)-rightstep _         (x,y)                      = (x+1,y)---horizontal :: Int -> Chain Int Int u-horizontal count = chain $ bivariate 0 alg-  where-    alg st | st == count = Done-    alg st               = Step (st,0) (st+1)---vertical :: Int -> Chain Int Int u-vertical count = chain $ bivariate 0 alg-  where-    alg st | st == count = Done-    alg st               = Step (0,st) (st+1)----horizontals :: (Num ua, Num u) => [ua] -> LocChain ua ua u-horizontals xs0 = chainFrom $ bivariate xs0 alg-  where-    alg []     = Done-    alg (x:xs) = Step (x,0) xs---verticals :: (Num ua, Num u)  => [ua] -> LocChain ua ua u-verticals ys0 = chainFrom $ bivariate ys0 alg-  where-    alg []     = Done-    alg (y:ys) = Step (0,y) ys-------------------------------------------------------------------------------------- general helpers--rescale :: Fractional a => a -> a -> a -> a -> a -> a-rescale outmin outmax innmin innmax a = -    outmin + innpos * (outrange / innrange)  -  where-    outrange = outmax - outmin-    innrange = innmax - innmin-    innpos   = a - innmin -

@@ -1,625 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Colour.SVGColours--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  unstable--- Portability :  GHC------ The SVG \'named colours\', as rgb [0,1] values --------------------------------------------------------------------------------------module Wumpus.Drawing.Colour.SVGColours -  (-    -  -- * Named colours-    alice_blue-  , antique_white-  , aqua-  , aquamarine-  , azure-  , beige-  , bisque-  , black-  , blanched_almond-  , blue-  , blue_violet-  , brown-  , burlywood-  , cadet_blue-  , chartreuse-  , chocolate-  , coral-  , cornflower_blue-  , cornsilk-  , crimson-  , cyan-  , dark_blue-  , dark_cyan-  , dark_goldenrod-  , dark_gray-  , dark_green-  , dark_grey-  , dark_khaki-  , dark_magenta-  , dark_olive_green-  , dark_orange-  , dark_orchid-  , dark_red-  , dark_salmon-  , dark_sea_green-  , dark_slate_blue-  , dark_slate_gray-  , dark_slate_grey-  , dark_turquoise-  , dark_violet-  , deep_pink-  , deep_sky_blue-  , dim_gray-  , dim_grey-  , dodger_blue-  , firebrick-  , floral_white-  , forest_green-  , fuchsia-  , gainsboro-  , ghost_white-  , gold-  , goldenrod-  , gray-  , grey-  , green-  , green_yellow-  , honeydew-  , hot_pink-  , indian_red-  , indigo-  , ivory-  , khaki-  , lavender-  , lavender_blush-  , lawn_green-  , lemon_chiffon-  , light_blue-  , light_coral-  , light_cyan-  , light_goldenrod_yellow-  , light_gray-  , light_green-  , light_grey-  , light_pink-  , light_salmon-  , light_sea_green-  , light_sky_blue-  , light_slate_gray-  , light_slate_grey-  , light_steel_blue-  , light_yellow-  , lime-  , lime_green-  , linen-  , magenta-  , maroon-  , medium_aquamarine-  , medium_blue-  , medium_orchid-  , medium_purple-  , medium_sea_green-  , medium_slate_blue-  , medium_spring_green-  , medium_turquoise-  , medium_violet_red-  , midnight_blue-  , mintcream-  , mistyrose-  , moccasin-  , navajo_white-  , navy-  , old_lace-  , olive-  , olive_drab-  , orange-  , orange_red-  , orchid-  , pale_goldenrod-  , pale_green-  , pale_turquoise-  , pale_violet_red-  , papaya_whip-  , peach_puff-  , peru-  , pink-  , plum-  , powder_blue-  , purple-  , red-  , rosy_brown-  , royal_blue-  , saddle_brown-  , salmon-  , sandy_brown-  , sea_green-  , seashell-  , sienna-  , silver-  , sky_blue-  , slate_blue-  , slate_gray-  , slate_grey-  , snow-  , spring_green-  , steel_blue-  , tan-  , teal-  , thistle-  , tomato-  , turquoise-  , violet-  , wheat-  , white-  , whitesmoke-  , yellow-  , yellow_green-  -  ) where---import Wumpus.Core.Colour ( RGBi(..) )---import Prelude ( )-  ------------------------------------------------------------------------------------  -alice_blue              :: RGBi-alice_blue              = RGBi 0xf0 0xf8 0xff--antique_white           :: RGBi -antique_white           = RGBi 0xfa 0xeb 0xd7--aqua                    :: RGBi-aqua                    = RGBi 0x00 0xff 0xff--aquamarine              :: RGBi-aquamarine              = RGBi 0x7f 0xff 0xd4--azure                   :: RGBi-azure                   = RGBi 0xf0 0xff 0xff--beige                   :: RGBi-beige                   = RGBi 0xf5 0xf5 0xdc--bisque                  :: RGBi-bisque                  = RGBi 0xff 0xe4 0xc4--black                   :: RGBi-black                   = RGBi 0x00 0x00 0x00--blanched_almond         :: RGBi-blanched_almond         = RGBi 0xff 0xeb 0xcd--blue                    :: RGBi-blue                    = RGBi 0x00 0x00 0xff--blue_violet             :: RGBi-blue_violet             = RGBi 0x8a 0x2b 0xe2--brown                   :: RGBi-brown                   = RGBi 0xa5 0x2a 0x2a--burlywood               :: RGBi-burlywood               = RGBi 0xde 0xb8 0x87--cadet_blue              :: RGBi-cadet_blue              = RGBi 0x5f 0x9e 0xa0--chartreuse              :: RGBi-chartreuse              = RGBi 0x7f 0xff 0x00--chocolate               :: RGBi-chocolate               = RGBi 0xd2 0x69 0x1e--coral                   :: RGBi-coral                   = RGBi 0xff 0x7f 0x50--cornflower_blue         :: RGBi-cornflower_blue         = RGBi 0x64 0x95 0xed--cornsilk                :: RGBi-cornsilk                = RGBi 0xff 0xf8 0xdc--crimson                 :: RGBi-crimson                 = RGBi 0xdc 0x14 0x3c--cyan                    :: RGBi-cyan                    = RGBi 0x00 0xff 0xff--dark_blue               :: RGBi-dark_blue               = RGBi 0x00 0x00 0x8b--dark_cyan               :: RGBi-dark_cyan               = RGBi 0x00 0x8b 0x8b--dark_goldenrod          :: RGBi-dark_goldenrod          = RGBi 0xb8 0x86 0x0b--dark_gray               :: RGBi-dark_gray               = RGBi 0xa9 0xa9 0xa9--dark_green              :: RGBi-dark_green              = RGBi 0x00 0x64 0x00--dark_grey               :: RGBi-dark_grey               = RGBi 0xa9 0xa9 0xa9--dark_khaki              :: RGBi-dark_khaki              = RGBi 0xbd 0xb7 0x6b--dark_magenta            :: RGBi-dark_magenta            = RGBi 0x8b 0x00 0x8b--dark_olive_green        :: RGBi-dark_olive_green        = RGBi 0x55 0x6b 0x2f--dark_orange             :: RGBi-dark_orange             = RGBi 0xff 0x8c 0x00--dark_orchid             :: RGBi-dark_orchid             = RGBi 0x99 0x32 0xcc--dark_red                :: RGBi-dark_red                = RGBi 0x8b 0x00 0x00--dark_salmon             :: RGBi-dark_salmon             = RGBi 0xe9 0x96 0x7a--dark_sea_green          :: RGBi-dark_sea_green          = RGBi 0x8f 0xbc 0x8f--dark_slate_blue         :: RGBi-dark_slate_blue         = RGBi 0x48 0x3d 0x8b--dark_slate_gray         :: RGBi-dark_slate_gray         = RGBi 0x2f 0x4f 0x4f--dark_slate_grey         :: RGBi-dark_slate_grey         = RGBi 0x2f 0x4f 0x4f--dark_turquoise          :: RGBi-dark_turquoise          = RGBi 0x00 0xce 0xd1--dark_violet             :: RGBi-dark_violet             = RGBi 0x94 0x00 0xd3--deep_pink               :: RGBi-deep_pink               = RGBi 0xff 0x14 0x93--deep_sky_blue           :: RGBi-deep_sky_blue           = RGBi 0x00 0xbf 0xff--dim_gray                :: RGBi-dim_gray                = RGBi 0x69 0x69 0x69--dim_grey                :: RGBi-dim_grey                = RGBi 0x69 0x69 0x69--dodger_blue             :: RGBi-dodger_blue             = RGBi 0x1e 0x90 0xff--firebrick               :: RGBi-firebrick               = RGBi 0xb2 0x22 0x22--floral_white            :: RGBi-floral_white            = RGBi 0xff 0xfa 0xf0--forest_green            :: RGBi-forest_green            = RGBi 0x22 0x8b 0x22--fuchsia                 :: RGBi-fuchsia                 = RGBi 0xff 0x00 0xff--gainsboro               :: RGBi-gainsboro               = RGBi 0xdc 0xdc 0xdc--ghost_white             :: RGBi-ghost_white             = RGBi 0xf8 0xf8 0xff--gold                    :: RGBi-gold                    = RGBi 0xff 0xd7 0x00--goldenrod               :: RGBi-goldenrod               = RGBi 0xda 0xa5 0x20--gray                    :: RGBi-gray                    = RGBi 0x80 0x80 0x80--green                   :: RGBi-green                   = RGBi 0x00 0x80 0x00--green_yellow            :: RGBi-green_yellow            = RGBi 0xad 0xff 0x2f--grey                    :: RGBi-grey                    = RGBi 0x80 0x80 0x80--honeydew                :: RGBi-honeydew                = RGBi 0xf0 0xff 0xf0--hot_pink                :: RGBi-hot_pink                = RGBi 0xff 0x69 0xb4--indian_red              :: RGBi-indian_red              = RGBi 0xcd 0x5c 0x5c--indigo                  :: RGBi-indigo                  = RGBi 0x4b 0x00 0x82--ivory                   :: RGBi-ivory                   = RGBi 0xff 0xff 0xf0--khaki                   :: RGBi-khaki                   = RGBi 0xf0 0xe6 0x8c--lavender                :: RGBi-lavender                = RGBi 0xe6 0xe6 0xfa--lavender_blush          :: RGBi-lavender_blush          = RGBi 0xff 0xf0 0xf5--lawn_green              :: RGBi-lawn_green              = RGBi 0x7c 0xfc 0x00--lemon_chiffon           :: RGBi-lemon_chiffon           = RGBi 0xff 0xfa 0xcd--light_blue              :: RGBi-light_blue              = RGBi 0xad 0xd8 0xe6--light_coral             :: RGBi-light_coral             = RGBi 0xf0 0x80 0x80--light_cyan              :: RGBi-light_cyan              = RGBi 0xe0 0xff 0xff--light_goldenrod_yellow  :: RGBi-light_goldenrod_yellow  = RGBi 0xfa 0xfa 0xd2--light_gray              :: RGBi-light_gray              = RGBi 0xd3 0xd3 0xd3--light_green             :: RGBi-light_green             = RGBi 0x90 0xee 0x90--light_grey              :: RGBi-light_grey              = RGBi 0xd3 0xd3 0xd3--light_pink              :: RGBi-light_pink              = RGBi 0xff 0xb6 0xc1--light_salmon            :: RGBi-light_salmon            = RGBi 0xff 0xa0 0x7a--light_sea_green         :: RGBi-light_sea_green         = RGBi 0x20 0xb2 0xaa--light_sky_blue          :: RGBi-light_sky_blue          = RGBi 0x87 0xce 0xfa--light_slate_gray        :: RGBi-light_slate_gray        = RGBi 0x77 0x88 0x99--light_slate_grey        :: RGBi-light_slate_grey        = RGBi 0x77 0x88 0x99--light_steel_blue        :: RGBi-light_steel_blue        = RGBi 0xb0 0xc4 0xde--light_yellow            :: RGBi-light_yellow            = RGBi 0xff 0xff 0xe0--lime                    :: RGBi-lime                    = RGBi 0x00 0xff 0x00--lime_green              :: RGBi-lime_green              = RGBi 0x32 0xcd 0x32--linen                   :: RGBi-linen                   = RGBi 0xfa 0xf0 0xe6--magenta                 :: RGBi-magenta                 = RGBi 0xff 0x00 0xff--maroon                  :: RGBi-maroon                  = RGBi 0x80 0x00 0x00--medium_aquamarine       :: RGBi-medium_aquamarine       = RGBi 0x66 0xcd 0xaa--medium_blue             :: RGBi-medium_blue             = RGBi 0x00 0x00 0xcd--medium_orchid           :: RGBi-medium_orchid           = RGBi 0xba 0x55 0xd3--medium_purple           :: RGBi-medium_purple           = RGBi 0x93 0x70 0xdb--medium_sea_green        :: RGBi-medium_sea_green        = RGBi 0x3c 0xb3 0x71--medium_slate_blue       :: RGBi-medium_slate_blue       = RGBi 0x7b 0x68 0xee--medium_spring_green     :: RGBi-medium_spring_green     = RGBi 0x00 0xfa 0x9a--medium_turquoise        :: RGBi-medium_turquoise        = RGBi 0x48 0xd1 0xcc--medium_violet_red       :: RGBi-medium_violet_red       = RGBi 0xc7 0x15 0x85--midnight_blue           :: RGBi-midnight_blue           = RGBi 0x19 0x19 0x70--mintcream               :: RGBi-mintcream               = RGBi 0xf5 0xff 0xfa--mistyrose               :: RGBi-mistyrose               = RGBi 0xff 0xe4 0xe1--moccasin                :: RGBi-moccasin                = RGBi 0xff 0xe4 0xb5--navajo_white            :: RGBi-navajo_white            = RGBi 0xff 0xde 0xad--navy                    :: RGBi-navy                    = RGBi 0x00 0x00 0x80--old_lace                :: RGBi-old_lace                = RGBi 0xfd 0xf5 0xe6--olive                   :: RGBi-olive                   = RGBi 0x80 0x80 0x00--olive_drab              :: RGBi-olive_drab              = RGBi 0x6b 0x8e 0x23--orange                  :: RGBi-orange                  = RGBi 0xff 0xa5 0x00--orange_red              :: RGBi-orange_red              = RGBi 0xff 0x45 0x00--orchid                  :: RGBi-orchid                  = RGBi 0xda 0x70 0xd6--pale_goldenrod          :: RGBi-pale_goldenrod          = RGBi 0xee 0xe8 0xaa--pale_green              :: RGBi-pale_green              = RGBi 0x98 0xfb 0x98--pale_turquoise          :: RGBi-pale_turquoise          = RGBi 0xaf 0xee 0xee--pale_violet_red         :: RGBi-pale_violet_red         = RGBi 0xdb 0x70 0x93--papaya_whip             :: RGBi-papaya_whip             = RGBi 0xff 0xef 0xd5--peach_puff              :: RGBi-peach_puff              = RGBi 0xff 0xda 0xb9--peru                    :: RGBi-peru                    = RGBi 0xcd 0x85 0x3f--pink                    :: RGBi-pink                    = RGBi 0xff 0xc0 0xcb--plum                    :: RGBi-plum                    = RGBi 0xdd 0xa0 0xdd--powder_blue             :: RGBi-powder_blue             = RGBi 0xb0 0xe0 0xe6--purple                  :: RGBi-purple                  = RGBi 0x80 0x00 0x80--red                     :: RGBi-red                     = RGBi 0xff 0x00 0x00--rosy_brown              :: RGBi-rosy_brown              = RGBi 0xbc 0x8f 0x8f--royal_blue              :: RGBi-royal_blue              = RGBi 0x41 0x69 0xe1--saddle_brown            :: RGBi-saddle_brown            = RGBi 0x8b 0x45 0x13--salmon                  :: RGBi-salmon                  = RGBi 0xfa 0x80 0x72--sandy_brown             :: RGBi-sandy_brown             = RGBi 0xf4 0xa4 0x60--sea_green               :: RGBi-sea_green               = RGBi 0x2e 0x8b 0x57--seashell                :: RGBi-seashell                = RGBi 0xff 0xf5 0xee--sienna                  :: RGBi-sienna                  = RGBi 0xa0 0x52 0x2d--silver                  :: RGBi-silver                  = RGBi 0xc0 0xc0 0xc0--sky_blue                :: RGBi-sky_blue                = RGBi 0x87 0xce 0xeb--slate_blue              :: RGBi-slate_blue              = RGBi 0x6a 0x5a 0xcd--slate_gray              :: RGBi-slate_gray              = RGBi 0x70 0x80 0x90--slate_grey              :: RGBi-slate_grey              = RGBi 0x70 0x80 0x90--snow                    :: RGBi-snow                    = RGBi 0xff 0xfa 0xfa--spring_green            :: RGBi-spring_green            = RGBi 0x00 0xff 0x7f--steel_blue              :: RGBi-steel_blue              = RGBi 0x46 0x82 0xb4--tan                     :: RGBi-tan                     = RGBi 0xd2 0xb4 0x8c--teal                    :: RGBi-teal                    = RGBi 0x00 0x80 0x80--thistle                 :: RGBi-thistle                 = RGBi 0xd8 0xbf 0xd8--tomato                  :: RGBi-tomato                  = RGBi 0xff 0x63 0x47--turquoise               :: RGBi-turquoise               = RGBi 0x40 0xe0 0xd0--violet                  :: RGBi-violet                  = RGBi 0xee 0x82 0xee--wheat                   :: RGBi-wheat                   = RGBi 0xf5 0xde 0xb3--white                   :: RGBi-white                   = RGBi 0xff 0xff 0xff--whitesmoke              :: RGBi-whitesmoke              = RGBi 0xf5 0xf5 0xf5--yellow                  :: RGBi-yellow                  = RGBi 0xff 0xff 0x00--yellow_green            :: RGBi-yellow_green            = RGBi 0x9a 0xcd 0x32-----

@@ -1,1282 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Colour.X11Colours--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  unstable--- Portability :  GHC------ The X11 \'named colours\', as rgb [0,1] values --------------------------------------------------------------------------------------module Wumpus.Drawing.Colour.X11Colours-  ( -  -  -- * Named X11 colours-    antique_white1-  , antique_white2-  , antique_white3-  , antique_white4-  , aquamarine1-  , aquamarine2-  , aquamarine3-  , aquamarine4-  , azure1-  , azure2-  , azure3-  , azure4-  , bisque1-  , bisque2-  , bisque3-  , bisque4-  , blue1-  , blue2-  , blue3-  , blue4-  , brown1-  , brown2-  , brown3-  , brown4-  , burlywood1-  , burlywood2-  , burlywood3-  , burlywood4-  , cadet_blue1-  , cadet_blue2-  , cadet_blue3-  , cadet_blue4-  , chartreuse1-  , chartreuse2-  , chartreuse3-  , chartreuse4-  , chocolate1-  , chocolate2-  , chocolate3-  , chocolate4-  , coral1-  , coral2-  , coral3-  , coral4-  , cornsilk1-  , cornsilk2-  , cornsilk3-  , cornsilk4-  , cyan1-  , cyan2-  , cyan3-  , cyan4-  , dark_goldenrod1-  , dark_goldenrod2-  , dark_goldenrod3-  , dark_goldenrod4-  , dark_olive_green1-  , dark_olive_green2-  , dark_olive_green3-  , dark_olive_green4-  , dark_orange1-  , dark_orange2-  , dark_orange3-  , dark_orange4-  , dark_orchid1-  , dark_orchid2-  , dark_orchid3-  , dark_orchid4-  , dark_sea_green1-  , dark_sea_green2-  , dark_sea_green3-  , dark_sea_green4-  , dark_slate_gray1-  , dark_slate_gray2-  , dark_slate_gray3-  , dark_slate_gray4-  , deep_pink1-  , deep_pink2-  , deep_pink3-  , deep_pink4-  , deep_sky_blue1-  , deep_sky_blue2-  , deep_sky_blue3-  , deep_sky_blue4-  , dodger_blue1-  , dodger_blue2-  , dodger_blue3-  , dodger_blue4-  , firebrick1-  , firebrick2-  , firebrick3-  , firebrick4-  , gold1-  , gold2-  , gold3-  , gold4-  , goldenrod1-  , goldenrod2-  , goldenrod3-  , goldenrod4-  , green1-  , green2-  , green3-  , green4-  , honeydew1-  , honeydew2-  , honeydew3-  , honeydew4-  , hot_pink1-  , hot_pink2-  , hot_pink3-  , hot_pink4-  , indian_red1-  , indian_red2-  , indian_red3-  , indian_red4-  , ivory1-  , ivory2-  , ivory3-  , ivory4-  , khaki1-  , khaki2-  , khaki3-  , khaki4-  , lavender_blush1-  , lavender_blush2-  , lavender_blush3-  , lavender_blush4-  , lemon_chiffon1-  , lemon_chiffon2-  , lemon_chiffon3-  , lemon_chiffon4-  , light_blue1-  , light_blue2-  , light_blue3-  , light_blue4-  , light_cyan1-  , light_cyan2-  , light_cyan3-  , light_cyan4-  , light_goldenrod1-  , light_goldenrod2-  , light_goldenrod3-  , light_goldenrod4-  , light_pink1-  , light_pink2-  , light_pink3-  , light_pink4-  , light_salmon1-  , light_salmon2-  , light_salmon3-  , light_salmon4-  , light_sky_blue1-  , light_sky_blue2-  , light_sky_blue3-  , light_sky_blue4-  , light_steel_blue1-  , light_steel_blue2-  , light_steel_blue3-  , light_steel_blue4-  , light_yellow1-  , light_yellow2-  , light_yellow3-  , light_yellow4-  , magenta1-  , magenta2-  , magenta3-  , magenta4-  , maroon1-  , maroon2-  , maroon3-  , maroon4-  , medium_orchid1-  , medium_orchid2-  , medium_orchid3-  , medium_orchid4-  , medium_purple1-  , medium_purple2-  , medium_purple3-  , medium_purple4-  , misty_rose1-  , misty_rose2-  , misty_rose3-  , misty_rose4-  , navajo_white1-  , navajo_white2-  , navajo_white3-  , navajo_white4-  , olive_drab1-  , olive_drab2-  , olive_drab3-  , olive_drab4-  , orange1-  , orange2-  , orange3-  , orange4-  , orange_red1-  , orange_red2-  , orange_red3-  , orange_red4-  , orchid1-  , orchid2-  , orchid3-  , orchid4-  , pale_green1-  , pale_green2-  , pale_green3-  , pale_green4-  , pale_turquoise1-  , pale_turquoise2-  , pale_turquoise3-  , pale_turquoise4-  , pale_violet_red1-  , pale_violet_red2-  , pale_violet_red3-  , pale_violet_red4-  , peach_puff1-  , peach_puff2-  , peach_puff3-  , peach_puff4-  , pink1-  , pink2-  , pink3-  , pink4-  , plum1-  , plum2-  , plum3-  , plum4-  , purple1-  , purple2-  , purple3-  , purple4-  , red1-  , red2-  , red3-  , red4-  , rosy_brown1-  , rosy_brown2-  , rosy_brown3-  , rosy_brown4-  , royal_blue1-  , royal_blue2-  , royal_blue3-  , royal_blue4-  , salmon1-  , salmon2-  , salmon3-  , salmon4-  , sea_green1-  , sea_green2-  , sea_green3-  , sea_green4-  , seashell1-  , seashell2-  , seashell3-  , seashell4-  , sienna1-  , sienna2-  , sienna3-  , sienna4-  , sky_blue1-  , sky_blue2-  , sky_blue3-  , sky_blue4-  , slate_blue1-  , slate_blue2-  , slate_blue3-  , slate_blue4-  , slate_gray1-  , slate_gray2-  , slate_gray3-  , slate_gray4-  , snow1-  , snow2-  , snow3-  , snow4-  , spring_green1-  , spring_green2-  , spring_green3-  , spring_green4-  , steel_blue1-  , steel_blue2-  , steel_blue3-  , steel_blue4-  , tan1-  , tan2-  , tan3-  , tan4-  , thistle1-  , thistle2-  , thistle3-  , thistle4-  , tomato1-  , tomato2-  , tomato3-  , tomato4-  , turquoise1-  , turquoise2-  , turquoise3-  , turquoise4-  , violet_red1-  , violet_red2-  , violet_red3-  , violet_red4-  , wheat1-  , wheat2-  , wheat3-  , wheat4-  , yellow1-  , yellow2-  , yellow3-  , yellow4--  ) where--import Wumpus.Core.Colour ( RGBi(..) )-------------------------------------------------------------------------------------antique_white1          :: RGBi-antique_white1          = RGBi 0xff 0xef 0xdb--antique_white2          :: RGBi-antique_white2          = RGBi 0xee 0xdf 0xcc--antique_white3          :: RGBi-antique_white3          = RGBi 0xcd 0xc0 0xb0--antique_white4          :: RGBi-antique_white4          = RGBi 0x8b 0x83 0x78--aquamarine1             :: RGBi-aquamarine1             = RGBi 0x7f 0xff 0xd4--aquamarine2             :: RGBi-aquamarine2             = RGBi 0x76 0xee 0xc6--aquamarine3             :: RGBi-aquamarine3             = RGBi 0x66 0xcd 0xaa--aquamarine4             :: RGBi-aquamarine4             = RGBi 0x45 0x8b 0x74--azure1                  :: RGBi-azure1                  = RGBi 0xf0 0xff 0xff--azure2                  :: RGBi-azure2                  = RGBi 0xe0 0xee 0xee--azure3                  :: RGBi-azure3                  = RGBi 0xc1 0xcd 0xcd--azure4                  :: RGBi-azure4                  = RGBi 0x83 0x8b 0x8b--bisque1                 :: RGBi-bisque1                 = RGBi 0xff 0xe4 0xc4--bisque2                 :: RGBi-bisque2                 = RGBi 0xee 0xd5 0xb7--bisque3                 :: RGBi-bisque3                 = RGBi 0xcd 0xb7 0x9e--bisque4                 :: RGBi-bisque4                 = RGBi 0x8b 0x7d 0x6b--blue1                   :: RGBi-blue1                   = RGBi 0x00 0x00 0xff--blue2                   :: RGBi-blue2                   = RGBi 0x00 0x00 0xee--blue3                   :: RGBi-blue3                   = RGBi 0x00 0x00 0xcd--blue4                   :: RGBi-blue4                   = RGBi 0x00 0x00 0x8b--brown1                  :: RGBi-brown1                  = RGBi 0xff 0x40 0x40--brown2                  :: RGBi-brown2                  = RGBi 0xee 0x3b 0x3b--brown3                  :: RGBi-brown3                  = RGBi 0xcd 0x33 0x33--brown4                  :: RGBi-brown4                  = RGBi 0x8b 0x23 0x23--burlywood1              :: RGBi-burlywood1              = RGBi 0xff 0xd3 0x9b--burlywood2              :: RGBi-burlywood2              = RGBi 0xee 0xc5 0x91--burlywood3              :: RGBi-burlywood3              = RGBi 0xcd 0xaa 0x7d--burlywood4              :: RGBi-burlywood4              = RGBi 0x8b 0x73 0x55--cadet_blue1             :: RGBi-cadet_blue1             = RGBi 0x98 0xf5 0xff--cadet_blue2             :: RGBi-cadet_blue2             = RGBi 0x8e 0xe5 0xee--cadet_blue3             :: RGBi-cadet_blue3             = RGBi 0x7a 0xc5 0xcd--cadet_blue4             :: RGBi-cadet_blue4             = RGBi 0x53 0x86 0x8b--chartreuse1             :: RGBi-chartreuse1             = RGBi 0x7f 0xff 0x00--chartreuse2             :: RGBi-chartreuse2             = RGBi 0x76 0xee 0x00--chartreuse3             :: RGBi-chartreuse3             = RGBi 0x66 0xcd 0x00--chartreuse4             :: RGBi-chartreuse4             = RGBi 0x45 0x8b 0x00--chocolate1              :: RGBi-chocolate1              = RGBi 0xff 0x7f 0x24--chocolate2              :: RGBi-chocolate2              = RGBi 0xee 0x76 0x21--chocolate3              :: RGBi-chocolate3              = RGBi 0xcd 0x66 0x1d--chocolate4              :: RGBi-chocolate4              = RGBi 0x8b 0x45 0x13--coral1                  :: RGBi-coral1                  = RGBi 0xff 0x72 0x56--coral2                  :: RGBi-coral2                  = RGBi 0xee 0x6a 0x50--coral3                  :: RGBi-coral3                  = RGBi 0xcd 0x5b 0x45--coral4                  :: RGBi-coral4                  = RGBi 0x8b 0x3e 0x2f--cornsilk1               :: RGBi-cornsilk1               = RGBi 0xff 0xf8 0xdc--cornsilk2               :: RGBi-cornsilk2               = RGBi 0xee 0xe8 0xcd--cornsilk3               :: RGBi-cornsilk3               = RGBi 0xcd 0xc8 0xb1--cornsilk4               :: RGBi-cornsilk4               = RGBi 0x8b 0x88 0x78--cyan1                   :: RGBi-cyan1                   = RGBi 0x00 0xff 0xff--cyan2                   :: RGBi-cyan2                   = RGBi 0x00 0xee 0xee--cyan3                   :: RGBi-cyan3                   = RGBi 0x00 0xcd 0xcd--cyan4                   :: RGBi-cyan4                   = RGBi 0x00 0x8b 0x8b--dark_goldenrod1         :: RGBi-dark_goldenrod1         = RGBi 0xff 0xb9 0x0f--dark_goldenrod2         :: RGBi-dark_goldenrod2         = RGBi 0xee 0xad 0x0e--dark_goldenrod3         :: RGBi-dark_goldenrod3         = RGBi 0xcd 0x95 0x0c--dark_goldenrod4         :: RGBi-dark_goldenrod4         = RGBi 0x8b 0x65 0x08--dark_olive_green1       :: RGBi-dark_olive_green1       = RGBi 0xca 0xff 0x70--dark_olive_green2       :: RGBi-dark_olive_green2       = RGBi 0xbc 0xee 0x68--dark_olive_green3       :: RGBi-dark_olive_green3       = RGBi 0xa2 0xcd 0x5a--dark_olive_green4       :: RGBi-dark_olive_green4       = RGBi 0x6e 0x8b 0x3d--dark_orange1            :: RGBi-dark_orange1            = RGBi 0xff 0x7f 0x00--dark_orange2            :: RGBi-dark_orange2            = RGBi 0xee 0x76 0x00--dark_orange3            :: RGBi-dark_orange3            = RGBi 0xcd 0x66 0x00--dark_orange4            :: RGBi-dark_orange4            = RGBi 0x8b 0x45 0x00--dark_orchid1            :: RGBi-dark_orchid1            = RGBi 0xbf 0x3e 0xff--dark_orchid2            :: RGBi-dark_orchid2            = RGBi 0xb2 0x3a 0xee--dark_orchid3            :: RGBi-dark_orchid3            = RGBi 0x9a 0x32 0xcd--dark_orchid4            :: RGBi-dark_orchid4            = RGBi 0x68 0x22 0x8b--dark_sea_green1         :: RGBi-dark_sea_green1         = RGBi 0xc1 0xff 0xc1--dark_sea_green2         :: RGBi-dark_sea_green2         = RGBi 0xb4 0xee 0xb4--dark_sea_green3         :: RGBi-dark_sea_green3         = RGBi 0x9b 0xcd 0x9b--dark_sea_green4         :: RGBi-dark_sea_green4         = RGBi 0x69 0x8b 0x69--dark_slate_gray1        :: RGBi-dark_slate_gray1        = RGBi 0x97 0xff 0xff--dark_slate_gray2        :: RGBi-dark_slate_gray2        = RGBi 0x8d 0xee 0xee--dark_slate_gray3        :: RGBi-dark_slate_gray3        = RGBi 0x79 0xcd 0xcd--dark_slate_gray4        :: RGBi-dark_slate_gray4        = RGBi 0x52 0x8b 0x8b--deep_pink1              :: RGBi-deep_pink1              = RGBi 0xff 0x14 0x93--deep_pink2              :: RGBi-deep_pink2              = RGBi 0xee 0x12 0x89--deep_pink3              :: RGBi-deep_pink3              = RGBi 0xcd 0x10 0x76--deep_pink4              :: RGBi-deep_pink4              = RGBi 0x8b 0x0a 0x50--deep_sky_blue1          :: RGBi-deep_sky_blue1          = RGBi 0x00 0xbf 0xff--deep_sky_blue2          :: RGBi-deep_sky_blue2          = RGBi 0x00 0xb2 0xee--deep_sky_blue3          :: RGBi-deep_sky_blue3          = RGBi 0x00 0x9a 0xcd--deep_sky_blue4          :: RGBi-deep_sky_blue4          = RGBi 0x00 0x68 0x8b--dodger_blue1            :: RGBi-dodger_blue1            = RGBi 0x1e 0x90 0xff--dodger_blue2            :: RGBi-dodger_blue2            = RGBi 0x1c 0x86 0xee--dodger_blue3            :: RGBi-dodger_blue3            = RGBi 0x18 0x74 0xcd--dodger_blue4            :: RGBi-dodger_blue4            = RGBi 0x10 0x4e 0x8b--firebrick1              :: RGBi-firebrick1              = RGBi 0xff 0x30 0x30--firebrick2              :: RGBi-firebrick2              = RGBi 0xee 0x2c 0x2c--firebrick3              :: RGBi-firebrick3              = RGBi 0xcd 0x26 0x26--firebrick4              :: RGBi-firebrick4              = RGBi 0x8b 0x1a 0x1a--gold1                   :: RGBi-gold1                   = RGBi 0xff 0xd7 0x00--gold2                   :: RGBi-gold2                   = RGBi 0xee 0xc9 0x00--gold3                   :: RGBi-gold3                   = RGBi 0xcd 0xad 0x00--gold4                   :: RGBi-gold4                   = RGBi 0x8b 0x75 0x00--goldenrod1              :: RGBi-goldenrod1              = RGBi 0xff 0xc1 0x25--goldenrod2              :: RGBi-goldenrod2              = RGBi 0xee 0xb4 0x22--goldenrod3              :: RGBi-goldenrod3              = RGBi 0xcd 0x9b 0x1d--goldenrod4              :: RGBi-goldenrod4              = RGBi 0x8b 0x69 0x14--green1                  :: RGBi-green1                  = RGBi 0x00 0xff 0x00--green2                  :: RGBi-green2                  = RGBi 0x00 0xee 0x00--green3                  :: RGBi-green3                  = RGBi 0x00 0xcd 0x00--green4                  :: RGBi-green4                  = RGBi 0x00 0x8b 0x00--honeydew1               :: RGBi-honeydew1               = RGBi 0xf0 0xff 0xf0--honeydew2               :: RGBi-honeydew2               = RGBi 0xe0 0xee 0xe0--honeydew3               :: RGBi-honeydew3               = RGBi 0xc1 0xcd 0xc1--honeydew4               :: RGBi-honeydew4               = RGBi 0x83 0x8b 0x83--hot_pink1               :: RGBi-hot_pink1               = RGBi 0xff 0x6e 0xb4--hot_pink2               :: RGBi-hot_pink2               = RGBi 0xee 0x6a 0xa7--hot_pink3               :: RGBi-hot_pink3               = RGBi 0xcd 0x60 0x90--hot_pink4               :: RGBi-hot_pink4               = RGBi 0x8b 0x3a 0x62--indian_red1             :: RGBi-indian_red1             = RGBi 0xff 0x6a 0x6a--indian_red2             :: RGBi-indian_red2             = RGBi 0xee 0x63 0x63--indian_red3             :: RGBi-indian_red3             = RGBi 0xcd 0x55 0x55--indian_red4             :: RGBi-indian_red4             = RGBi 0x8b 0x3a 0x3a--ivory1                  :: RGBi-ivory1                  = RGBi 0xff 0xff 0xf0--ivory2                  :: RGBi-ivory2                  = RGBi 0xee 0xee 0xe0--ivory3                  :: RGBi-ivory3                  = RGBi 0xcd 0xcd 0xc1--ivory4                  :: RGBi-ivory4                  = RGBi 0x8b 0x8b 0x83--khaki1                  :: RGBi-khaki1                  = RGBi 0xff 0xf6 0x8f--khaki2                  :: RGBi-khaki2                  = RGBi 0xee 0xe6 0x85--khaki3                  :: RGBi-khaki3                  = RGBi 0xcd 0xc6 0x73--khaki4                  :: RGBi-khaki4                  = RGBi 0x8b 0x86 0x4e--lavender_blush1         :: RGBi-lavender_blush1         = RGBi 0xff 0xf0 0xf5--lavender_blush2         :: RGBi-lavender_blush2         = RGBi 0xee 0xe0 0xe5--lavender_blush3         :: RGBi-lavender_blush3         = RGBi 0xcd 0xc1 0xc5--lavender_blush4         :: RGBi-lavender_blush4         = RGBi 0x8b 0x83 0x86--lemon_chiffon1          :: RGBi-lemon_chiffon1          = RGBi 0xff 0xfa 0xcd--lemon_chiffon2          :: RGBi-lemon_chiffon2          = RGBi 0xee 0xe9 0xbf--lemon_chiffon3          :: RGBi-lemon_chiffon3          = RGBi 0xcd 0xc9 0xa5--lemon_chiffon4          :: RGBi-lemon_chiffon4          = RGBi 0x8b 0x89 0x70--light_blue1             :: RGBi-light_blue1             = RGBi 0xbf 0xef 0xff--light_blue2             :: RGBi-light_blue2             = RGBi 0xb2 0xdf 0xee--light_blue3             :: RGBi-light_blue3             = RGBi 0x9a 0xc0 0xcd--light_blue4             :: RGBi-light_blue4             = RGBi 0x68 0x83 0x8b--light_cyan1             :: RGBi-light_cyan1             = RGBi 0xe0 0xff 0xff--light_cyan2             :: RGBi-light_cyan2             = RGBi 0xd1 0xee 0xee--light_cyan3             :: RGBi-light_cyan3             = RGBi 0xb4 0xcd 0xcd--light_cyan4             :: RGBi-light_cyan4             = RGBi 0x7a 0x8b 0x8b--light_goldenrod1        :: RGBi-light_goldenrod1        = RGBi 0xff 0xec 0x8b--light_goldenrod2        :: RGBi-light_goldenrod2        = RGBi 0xee 0xdc 0x82--light_goldenrod3        :: RGBi-light_goldenrod3        = RGBi 0xcd 0xbe 0x70--light_goldenrod4        :: RGBi-light_goldenrod4        = RGBi 0x8b 0x81 0x4c--light_pink1             :: RGBi-light_pink1             = RGBi 0xff 0xae 0xb9--light_pink2             :: RGBi-light_pink2             = RGBi 0xee 0xa2 0xad--light_pink3             :: RGBi-light_pink3             = RGBi 0xcd 0x8c 0x95--light_pink4             :: RGBi-light_pink4             = RGBi 0x8b 0x5f 0x65--light_salmon1           :: RGBi-light_salmon1           = RGBi 0xff 0xa0 0x7a--light_salmon2           :: RGBi-light_salmon2           = RGBi 0xee 0x95 0x72--light_salmon3           :: RGBi-light_salmon3           = RGBi 0xcd 0x81 0x62--light_salmon4           :: RGBi-light_salmon4           = RGBi 0x8b 0x57 0x42--light_sky_blue1         :: RGBi-light_sky_blue1         = RGBi 0xb0 0xe2 0xff--light_sky_blue2         :: RGBi-light_sky_blue2         = RGBi 0xa4 0xd3 0xee--light_sky_blue3         :: RGBi-light_sky_blue3         = RGBi 0x8d 0xb6 0xcd--light_sky_blue4         :: RGBi-light_sky_blue4         = RGBi 0x60 0x7b 0x8b--light_steel_blue1       :: RGBi-light_steel_blue1       = RGBi 0xca 0xe1 0xff--light_steel_blue2       :: RGBi-light_steel_blue2       = RGBi 0xbc 0xd2 0xee--light_steel_blue3       :: RGBi-light_steel_blue3       = RGBi 0xa2 0xb5 0xcd--light_steel_blue4       :: RGBi-light_steel_blue4       = RGBi 0x6e 0x7b 0x8b--light_yellow1           :: RGBi-light_yellow1           = RGBi 0xff 0xff 0xe0--light_yellow2           :: RGBi-light_yellow2           = RGBi 0xee 0xee 0xd1--light_yellow3           :: RGBi-light_yellow3           = RGBi 0xcd 0xcd 0xb4--light_yellow4           :: RGBi-light_yellow4           = RGBi 0x8b 0x8b 0x7a--magenta1                :: RGBi-magenta1                = RGBi 0xff 0x00 0xff--magenta2                :: RGBi-magenta2                = RGBi 0xee 0x00 0xee--magenta3                :: RGBi-magenta3                = RGBi 0xcd 0x00 0xcd--magenta4                :: RGBi-magenta4                = RGBi 0x8b 0x00 0x8b--maroon1                 :: RGBi-maroon1                 = RGBi 0xff 0x34 0xb3--maroon2                 :: RGBi-maroon2                 = RGBi 0xee 0x30 0xa7--maroon3                 :: RGBi-maroon3                 = RGBi 0xcd 0x29 0x90--maroon4                 :: RGBi-maroon4                 = RGBi 0x8b 0x1c 0x62--medium_orchid1          :: RGBi-medium_orchid1          = RGBi 0xe0 0x66 0xff--medium_orchid2          :: RGBi-medium_orchid2          = RGBi 0xd1 0x5f 0xee--medium_orchid3          :: RGBi-medium_orchid3          = RGBi 0xb4 0x52 0xcd--medium_orchid4          :: RGBi-medium_orchid4          = RGBi 0x7a 0x37 0x8b--medium_purple1          :: RGBi-medium_purple1          = RGBi 0xab 0x82 0xff--medium_purple2          :: RGBi-medium_purple2          = RGBi 0x9f 0x79 0xee--medium_purple3          :: RGBi-medium_purple3          = RGBi 0x89 0x68 0xcd--medium_purple4          :: RGBi-medium_purple4          = RGBi 0x5d 0x47 0x8b--misty_rose1             :: RGBi-misty_rose1             = RGBi 0xff 0xe4 0xe1--misty_rose2             :: RGBi-misty_rose2             = RGBi 0xee 0xd5 0xd2--misty_rose3             :: RGBi-misty_rose3             = RGBi 0xcd 0xb7 0xb5--misty_rose4             :: RGBi-misty_rose4             = RGBi 0x8b 0x7d 0x7b--navajo_white1           :: RGBi-navajo_white1           = RGBi 0xff 0xde 0xad--navajo_white2           :: RGBi-navajo_white2           = RGBi 0xee 0xcf 0xa1--navajo_white3           :: RGBi-navajo_white3           = RGBi 0xcd 0xb3 0x8b--navajo_white4           :: RGBi-navajo_white4           = RGBi 0x8b 0x79 0x5e--olive_drab1             :: RGBi-olive_drab1             = RGBi 0xc0 0xff 0x3e--olive_drab2             :: RGBi-olive_drab2             = RGBi 0xb3 0xee 0x3a--olive_drab3             :: RGBi-olive_drab3             = RGBi 0x9a 0xcd 0x32--olive_drab4             :: RGBi-olive_drab4             = RGBi 0x69 0x8b 0x22--orange1                 :: RGBi-orange1                 = RGBi 0xff 0xa5 0x00--orange2                 :: RGBi-orange2                 = RGBi 0xee 0x9a 0x00--orange3                 :: RGBi-orange3                 = RGBi 0xcd 0x85 0x00--orange4                 :: RGBi-orange4                 = RGBi 0x8b 0x5a 0x00--orange_red1             :: RGBi-orange_red1             = RGBi 0xff 0x45 0x00--orange_red2             :: RGBi-orange_red2             = RGBi 0xee 0x40 0x00--orange_red3             :: RGBi-orange_red3             = RGBi 0xcd 0x37 0x00--orange_red4             :: RGBi-orange_red4             = RGBi 0x8b 0x25 0x00--orchid1                 :: RGBi-orchid1                 = RGBi 0xff 0x83 0xfa--orchid2                 :: RGBi-orchid2                 = RGBi 0xee 0x7a 0xe9--orchid3                 :: RGBi-orchid3                 = RGBi 0xcd 0x69 0xc9--orchid4                 :: RGBi-orchid4                 = RGBi 0x8b 0x47 0x89--pale_green1             :: RGBi-pale_green1             = RGBi 0x9a 0xff 0x9a--pale_green2             :: RGBi-pale_green2             = RGBi 0x90 0xee 0x90--pale_green3             :: RGBi-pale_green3             = RGBi 0x7c 0xcd 0x7c--pale_green4             :: RGBi-pale_green4             = RGBi 0x54 0x8b 0x54--pale_turquoise1         :: RGBi-pale_turquoise1         = RGBi 0xbb 0xff 0xff--pale_turquoise2         :: RGBi-pale_turquoise2         = RGBi 0xae 0xee 0xee--pale_turquoise3         :: RGBi-pale_turquoise3         = RGBi 0x96 0xcd 0xcd--pale_turquoise4         :: RGBi-pale_turquoise4         = RGBi 0x66 0x8b 0x8b--pale_violet_red1        :: RGBi-pale_violet_red1        = RGBi 0xff 0x82 0xab--pale_violet_red2        :: RGBi-pale_violet_red2        = RGBi 0xee 0x79 0x9f--pale_violet_red3        :: RGBi-pale_violet_red3        = RGBi 0xcd 0x68 0x89--pale_violet_red4        :: RGBi-pale_violet_red4        = RGBi 0x8b 0x47 0x5d--peach_puff1             :: RGBi-peach_puff1             = RGBi 0xff 0xda 0xb9--peach_puff2             :: RGBi-peach_puff2             = RGBi 0xee 0xcb 0xad--peach_puff3             :: RGBi-peach_puff3             = RGBi 0xcd 0xaf 0x95--peach_puff4             :: RGBi-peach_puff4             = RGBi 0x8b 0x77 0x65--pink1                   :: RGBi-pink1                   = RGBi 0xff 0xb5 0xc5--pink2                   :: RGBi-pink2                   = RGBi 0xee 0xa9 0xb8--pink3                   :: RGBi-pink3                   = RGBi 0xcd 0x91 0x9e--pink4                   :: RGBi-pink4                   = RGBi 0x8b 0x63 0x6c--plum1                   :: RGBi-plum1                   = RGBi 0xff 0xbb 0xff--plum2                   :: RGBi-plum2                   = RGBi 0xee 0xae 0xee--plum3                   :: RGBi-plum3                   = RGBi 0xcd 0x96 0xcd--plum4                   :: RGBi-plum4                   = RGBi 0x8b 0x66 0x8b--purple1                 :: RGBi-purple1                 = RGBi 0x9b 0x30 0xff--purple2                 :: RGBi-purple2                 = RGBi 0x91 0x2c 0xee--purple3                 :: RGBi-purple3                 = RGBi 0x7d 0x26 0xcd--purple4                 :: RGBi-purple4                 = RGBi 0x55 0x1a 0x8b--red1                    :: RGBi-red1                    = RGBi 0xff 0x00 0x00--red2                    :: RGBi-red2                    = RGBi 0xee 0x00 0x00--red3                    :: RGBi-red3                    = RGBi 0xcd 0x00 0x00--red4                    :: RGBi-red4                    = RGBi 0x8b 0x00 0x00--rosy_brown1             :: RGBi-rosy_brown1             = RGBi 0xff 0xc1 0xc1--rosy_brown2             :: RGBi-rosy_brown2             = RGBi 0xee 0xb4 0xb4--rosy_brown3             :: RGBi-rosy_brown3             = RGBi 0xcd 0x9b 0x9b--rosy_brown4             :: RGBi-rosy_brown4             = RGBi 0x8b 0x69 0x69--royal_blue1             :: RGBi-royal_blue1             = RGBi 0x48 0x76 0xff--royal_blue2             :: RGBi-royal_blue2             = RGBi 0x43 0x6e 0xee--royal_blue3             :: RGBi-royal_blue3             = RGBi 0x3a 0x5f 0xcd--royal_blue4             :: RGBi-royal_blue4             = RGBi 0x27 0x40 0x8b---salmon1                 :: RGBi-salmon1                 = RGBi 0xff 0x8c 0x69--salmon2                 :: RGBi-salmon2                 = RGBi 0xee 0x82 0x62--salmon3                 :: RGBi-salmon3                 = RGBi 0xcd 0x70 0x54--salmon4                 :: RGBi-salmon4                 = RGBi 0x8b 0x4c 0x39--sea_green1              :: RGBi-sea_green1              = RGBi 0x54 0xff 0x9f--sea_green2              :: RGBi-sea_green2              = RGBi 0x4e 0xee 0x94--sea_green3              :: RGBi-sea_green3              = RGBi 0x43 0xcd 0x80--sea_green4              :: RGBi-sea_green4              = RGBi 0x2e 0x8b 0x57--seashell1               :: RGBi-seashell1               = RGBi 0xff 0xf5 0xee--seashell2               :: RGBi-seashell2               = RGBi 0xee 0xe5 0xde--seashell3               :: RGBi-seashell3               = RGBi 0xcd 0xc5 0xbf--seashell4               :: RGBi-seashell4               = RGBi 0x8b 0x86 0x82--sienna1                 :: RGBi-sienna1                 = RGBi 0xff 0x82 0x47--sienna2                 :: RGBi-sienna2                 = RGBi 0xee 0x79 0x42--sienna3                 :: RGBi-sienna3                 = RGBi 0xcd 0x68 0x39--sienna4                 :: RGBi-sienna4                 = RGBi 0x8b 0x47 0x26--sky_blue1               :: RGBi-sky_blue1               = RGBi 0x87 0xce 0xff--sky_blue2               :: RGBi-sky_blue2               = RGBi 0x7e 0xc0 0xee--sky_blue3               :: RGBi-sky_blue3               = RGBi 0x6c 0xa6 0xcd--sky_blue4               :: RGBi-sky_blue4               = RGBi 0x4a 0x70 0x8b--slate_blue1             :: RGBi-slate_blue1             = RGBi 0x83 0x6f 0xff--slate_blue2             :: RGBi-slate_blue2             = RGBi 0x7a 0x67 0xee--slate_blue3             :: RGBi-slate_blue3             = RGBi 0x69 0x59 0xcd--slate_blue4             :: RGBi-slate_blue4             = RGBi 0x47 0x3c 0x8b--slate_gray1             :: RGBi-slate_gray1             = RGBi 0xc6 0xe2 0xff--slate_gray2             :: RGBi-slate_gray2             = RGBi 0xb9 0xd3 0xee--slate_gray3             :: RGBi-slate_gray3             = RGBi 0x9f 0xb6 0xcd--slate_gray4             :: RGBi-slate_gray4             = RGBi 0x6c 0x7b 0x8b--snow1                   :: RGBi-snow1                   = RGBi 0xff 0xfa 0xfa--snow2                   :: RGBi-snow2                   = RGBi 0xee 0xe9 0xe9--snow3                   :: RGBi-snow3                   = RGBi 0xcd 0xc9 0xc9--snow4                   :: RGBi-snow4                   = RGBi 0x8b 0x89 0x89--spring_green1           :: RGBi-spring_green1           = RGBi 0x00 0xff 0x7f--spring_green2           :: RGBi-spring_green2           = RGBi 0x00 0xee 0x76--spring_green3           :: RGBi-spring_green3           = RGBi 0x00 0xcd 0x66--spring_green4           :: RGBi-spring_green4           = RGBi 0x00 0x8b 0x45--steel_blue1             :: RGBi-steel_blue1             = RGBi 0x63 0xb8 0xff--steel_blue2             :: RGBi-steel_blue2             = RGBi 0x5c 0xac 0xee--steel_blue3             :: RGBi-steel_blue3             = RGBi 0x4f 0x94 0xcd--steel_blue4             :: RGBi-steel_blue4             = RGBi 0x36 0x64 0x8b--tan1                    :: RGBi-tan1                    = RGBi 0xff 0xa5 0x4f--tan2                    :: RGBi-tan2                    = RGBi 0xee 0x9a 0x49--tan3                    :: RGBi-tan3                    = RGBi 0xcd 0x85 0x3f--tan4                    :: RGBi-tan4                    = RGBi 0x8b 0x5a 0x2b--thistle1                :: RGBi-thistle1                = RGBi 0xff 0xe1 0xff--thistle2                :: RGBi-thistle2                = RGBi 0xee 0xd2 0xee--thistle3                :: RGBi-thistle3                = RGBi 0xcd 0xb5 0xcd--thistle4                :: RGBi-thistle4                = RGBi 0x8b 0x7b 0x8b--tomato1                 :: RGBi-tomato1                 = RGBi 0xff 0x63 0x47--tomato2                 :: RGBi-tomato2                 = RGBi 0xee 0x5c 0x42--tomato3                 :: RGBi-tomato3                 = RGBi 0xcd 0x4f 0x39--tomato4                 :: RGBi-tomato4                 = RGBi 0x8b 0x36 0x26--turquoise1              :: RGBi-turquoise1              = RGBi 0x00 0xf5 0xff--turquoise2              :: RGBi-turquoise2              = RGBi 0x00 0xe5 0xee--turquoise3              :: RGBi-turquoise3              = RGBi 0x00 0xc5 0xcd--turquoise4              :: RGBi-turquoise4              = RGBi 0x00 0x86 0x8b--violet_red1             :: RGBi-violet_red1             = RGBi 0xff 0x3e 0x96--violet_red2             :: RGBi-violet_red2             = RGBi 0xee 0x3a 0x8c--violet_red3             :: RGBi-violet_red3             = RGBi 0xcd 0x32 0x78--violet_red4             :: RGBi-violet_red4             = RGBi 0x8b 0x22 0x52--wheat1                  :: RGBi-wheat1                  = RGBi 0xff 0xe7 0xba--wheat2                  :: RGBi-wheat2                  = RGBi 0xee 0xd8 0xae--wheat3                  :: RGBi-wheat3                  = RGBi 0xcd 0xba 0x96--wheat4                  :: RGBi-wheat4                  = RGBi 0x8b 0x7e 0x66--yellow1                 :: RGBi-yellow1                 = RGBi 0xff 0xff 0x00--yellow2                 :: RGBi-yellow2                 = RGBi 0xee 0xee 0x00--yellow3                 :: RGBi-yellow3                 = RGBi 0xcd 0xcd 0x00--yellow4                 :: RGBi-yellow4                 = RGBi 0x8b 0x8b 0x00------