wumpus-drawing 0.2.0 → 0.3.0

raw patch · 77 files changed

+7170/−4812 lines, 77 filesdep ~wumpus-basicdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic, wumpus-core

API changes (from Hackage documentation)

Files

• demo/ArrowCircuit.hs +50/−63
• demo/Arrowheads.hs +69/−56
• demo/Automata.hs +107/−0
• demo/ClipPic.hs +59/−54
• demo/ColourCharts.hs +8/−10
• demo/Connectors.hs +58/−44
• demo/DotPic.hs +20/−49
• demo/FeatureModel.hs +28/−50
• demo/FontLoaderUtils.hs +0/−95
• demo/FontPic.hs +27/−23
• demo/LeftRightText.hs +49/−85
• demo/PetriNet.hs +89/−111
• demo/SampleShapes.hs +56/−73
• demo/SingleChar.hs +70/−0
• demo/SingleLine.hs +20/−40
• demo/Symbols.hs +10/−11
• demo/TableChains.hs +5/−29
• src/Wumpus/Drawing/Arrows.hs +0/−28
• src/Wumpus/Drawing/Arrows/Connectors.hs +0/−104
• src/Wumpus/Drawing/Arrows/Tips.hs +0/−515
• src/Wumpus/Drawing/Chains.hs +0/−29
• src/Wumpus/Drawing/Chains/Base.hs +0/−259
• src/Wumpus/Drawing/Chains/Derived.hs +0/−155
• src/Wumpus/Drawing/Connectors.hs +31/−0
• src/Wumpus/Drawing/Connectors/Arrowheads.hs +464/−0
• src/Wumpus/Drawing/Connectors/Base.hs +172/−0
• src/Wumpus/Drawing/Connectors/BoxConnectors.hs +65/−0
• src/Wumpus/Drawing/Connectors/ConnectorPaths.hs +499/−0
• src/Wumpus/Drawing/Connectors/Loop.hs +86/−0
• src/Wumpus/Drawing/Dots/AnchorDots.hs +33/−31
• src/Wumpus/Drawing/Dots/Marks.hs +56/−57
• src/Wumpus/Drawing/Extras/Axes.hs +49/−0
• src/Wumpus/Drawing/Extras/Grids.hs +229/−0
• src/Wumpus/Drawing/Extras/Turtle/TurtleClass.hs +91/−0
• src/Wumpus/Drawing/Extras/Turtle/TurtleMonad.hs +132/−0
• src/Wumpus/Drawing/Grids.hs +0/−67
• src/Wumpus/Drawing/Paths.hs +0/−32
• src/Wumpus/Drawing/Paths/Absolute.hs +28/−0
• src/Wumpus/Drawing/Paths/Base.hs +0/−585
• src/Wumpus/Drawing/Paths/Base/AbsBuilder.hs +561/−0
• src/Wumpus/Drawing/Paths/Base/AbsPath.hs +801/−0
• src/Wumpus/Drawing/Paths/Base/BuildCommon.hs +129/−0
• src/Wumpus/Drawing/Paths/Base/RelBuilder.hs +520/−0
• src/Wumpus/Drawing/Paths/Base/RelPath.hs +269/−0
• src/Wumpus/Drawing/Paths/Connectors.hs +0/−253
• src/Wumpus/Drawing/Paths/ControlPoints.hs +0/−189
• src/Wumpus/Drawing/Paths/MonadicConstruction.hs +0/−160
• src/Wumpus/Drawing/Paths/Relative.hs +27/−0
• src/Wumpus/Drawing/Paths/Vamps.hs +56/−0
• src/Wumpus/Drawing/Shapes/Base.hs +108/−83
• src/Wumpus/Drawing/Shapes/Circle.hs +22/−21
• src/Wumpus/Drawing/Shapes/Diamond.hs +36/−30
• src/Wumpus/Drawing/Shapes/Ellipse.hs +41/−30
• src/Wumpus/Drawing/Shapes/InvSemicircle.hs +32/−27
• src/Wumpus/Drawing/Shapes/InvSemiellipse.hs +32/−28
• src/Wumpus/Drawing/Shapes/InvTriangle.hs +39/−35
• src/Wumpus/Drawing/Shapes/Parallelogram.hs +50/−39
• src/Wumpus/Drawing/Shapes/Rectangle.hs +38/−32
• src/Wumpus/Drawing/Shapes/Semicircle.hs +41/−29
• src/Wumpus/Drawing/Shapes/Semiellipse.hs +36/−31
• src/Wumpus/Drawing/Shapes/Trapezium.hs +43/−41
• src/Wumpus/Drawing/Shapes/Triangle.hs +51/−39
• src/Wumpus/Drawing/Text/Base.hs +0/−166
• src/Wumpus/Drawing/Text/Base/Common.hs +143/−0
• src/Wumpus/Drawing/Text/Base/DocTextZero.hs +453/−0
• src/Wumpus/Drawing/Text/Base/Label.hs +133/−0
• src/Wumpus/Drawing/Text/Base/PosChar.hs +73/−0
• src/Wumpus/Drawing/Text/Base/RotTextZero.hs +375/−0
• src/Wumpus/Drawing/Text/CatText.hs +0/−207
• src/Wumpus/Drawing/Text/DirectionZero.hs +27/−0
• src/Wumpus/Drawing/Text/LRText.hs +0/−292
• src/Wumpus/Drawing/Text/SafeFonts.hs +0/−167
• src/Wumpus/Drawing/Text/StandardFontDefs.hs +323/−0
• src/Wumpus/Drawing/Turtle/TurtleClass.hs +0/−91
• src/Wumpus/Drawing/Turtle/TurtleMonad.hs +0/−139
• src/Wumpus/Drawing/VersionNumber.hs +3/−3
• wumpus-drawing.cabal +48/−25

@@ -5,60 +5,42 @@ -- Acknowledgment - the Arrow diagram is taken from Ross  -- Paterson\'s slides /Arrows and Computation/. +-- NOTE - this example now rather out-of-date. Wumpus-Drawing has +-- some new features to make node/connector drawing a bit easier.  module ArrowCircuit where -import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Paths +import Wumpus.Drawing.Connectors import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core -import FontLoaderUtils --import Data.AffineSpace+import Data.AffineSpace                         -- package: vector-space  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 = runCtxPictureU (makeCtx base_metrics) circuit_pic-    writeEPS "./out/arrow_circuit01.eps" pic1-    writeSVG "./out/arrow_circuit01.svg" pic1 +main = simpleFontLoader main1 >> return () -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+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Right times_roman_family ]+    printLoadErrors base_metrics     let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic-    writeEPS "./out/arrow_circuit02.eps" pic1-    writeSVG "./out/arrow_circuit02.svg" pic1 +    writeEPS "./out/arrow_circuit.eps" pic1+    writeSVG "./out/arrow_circuit.svg" pic1    -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace times_roman . metricsContext 11+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font times_roman . metricsContext 11   @@ -69,8 +51,11 @@  -- Note `at` currently does not work for Shapes.          -circuit_pic :: CtxPicture Double -circuit_pic = drawTracing $ do+circuit_pic :: CtxPicture+circuit_pic = drawTracing body ++body :: TraceDrawing Double ()+body = do     a1 <- drawi $ rrectangle 12 66 30 `at` P2 0 72     atext a1 "CONST 0"     a2 <- drawi $ (strokedShape $ circle 16) `at` P2 120 60@@ -79,44 +64,46 @@     atext a3 "+1"     a4 <- drawi $ (strokedShape $ rectangle 66 30) `at` 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)+    connWith connline (east a1) ((.+^ hvec 76) $ east a1)+    connWith connline (east a2) ((.+^ hvec 180) $ east a2)+    connWith connline ((.+^ vvec 40) $ north a2) (north a2)+    connWith connline ((.+^ vvec 16) $ north a3) (north a3)  +    connWith connaright  (south a3) (east a4)+    connWith connabar (west a4)  (southwest a2)     ptext (P2  40  10) "next"     ptext (P2 152 100) "reset"     ptext (P2 252  72) "output"     return () -+    -- Note - need a variant of /bar/ that draws UDLR only. -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 (rightArrow tri45 con) p0 p1+connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit (m ())+            , Real u, Floating u, InterpretUnit u ) +         => Connector u -> Anchor u -> Anchor u -> m ()+connWith con a0 a1 = localize double_point_size $ +    drawc a0 a1 (rightArrow tri45 con)  -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_ $ textAlignCenter ss `at` pt+atext :: ( CenterAnchor (t u)+         , Real u, Floating u, InterpretUnit u+         , TraceM m, DrawingCtxM m, u ~ MonUnit (m ()), u ~ DUnit (t u) )+      => t u -> String -> m ()+atext ancr ss = +    draw $ ccTextline ss `at` (center ancr)  -ptext :: ( Real u, Floating u, FromPtSize u-         , TraceM m, DrawingCtxM m, u ~ MonUnit m )+ptext :: ( Real u, Floating u, InterpretUnit u+         , TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) )       => Point2 u -> String -> m ()-ptext pt ss = localize (fontAttr times_italic 14) $ -    drawi_ $ textAlignCenter ss `at` pt+ptext pt ss = localize (font_attr times_italic 14) $ +    draw $ ccTextline ss `at` pt   -- Note - return type is a LocImage not a shape... ---rrectangle :: (Real u, Floating u, FromPtSize u) -           => u -> u -> u -> LocImage u (Rectangle u)-rrectangle r w h = -    localize (roundCornerFactor $ realToFrac r) $ strokedShape (rectangle w h)+rrectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +           => Double -> u -> u -> LocImage u (Rectangle u)+rrectangle _r w h = strokedShape (rectangle w h)+    -- This should have round corners but they are currently+    -- disabled pending a re-think. +    {- localize (round_corner_factor r) $ -} 

@@ -2,84 +2,97 @@  module Arrowheads where --import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths hiding ( length )+import Wumpus.Drawing.Connectors+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs + import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space  import System.Directory  main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx arrow_drawing-    writeEPS "./out/arrowheads01.eps" pic1-    writeSVG "./out/arrowheads01.svg" pic1+main = simpleFontLoader main1 >> return () -arrow_drawing :: CtxPicture Double-arrow_drawing = drawTracing $ localize (dashPattern unit_dash_pattern) -                            $ tableGraphic arrtable+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) arrow_drawing+    writeEPS "./out/arrowheads.eps" pic1+    writeSVG "./out/arrowheads.svg" pic1 -arrtable :: [(Arrowhead Double, Arrowhead Double)]++makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 14++++arrow_drawing :: CtxPicture+arrow_drawing = +    drawTracing $ localize dotted_line $ tableGraphic arrtable++arrtable :: [(String, ArrowTip 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)+    [ ("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)+    , ("diamondWideTip",        diamondWideTip)+    , ("odiamondWideTip",       odiamondWideTip)+    , ("curveTip",              curveTip)+    , ("revcurveTip",           revcurveTip)         ] -tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u ()+++tableGraphic :: [(String, ArrowTip Double)] -> TraceDrawing Double () tableGraphic tips = -    draw $ unchainZipWith emptyLocGraphic makeArrowDrawing tips chn `at` start+    drawl start $ chain_ chn_alg (map makeArrowDrawing tips)   where-    chn   = tableDown 20 (120,24)-    start = P2 0 480+    chn_alg = tableDown 18 (180,24)+    start   = P2 0 480    std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18+std_ctx = fill_colour peru $ standardContext 18   -makeArrowDrawing :: (Real u, Floating u, FromPtSize u) -                 => (Arrowhead u, Arrowhead u) -> LocGraphic u-makeArrowDrawing (arrl,arrr) = -    promoteR1 $ \p0 -> forget $-      connect (leftRightArrow arrl arrr connLine) p0 (mkP1 p0)+makeArrowDrawing :: (String, ArrowTip Double) -> LocGraphic Double+makeArrowDrawing (name, utip) = aconn `oplus` lbl   where-    mkP1    = (.+^ hvec 100)-    -- forget needs a better name, then adding to Wumpus-Basic.-    forget  = fmap (replaceL uNil)  +    aconn = promoteR1 $ \pt -> fmap ignoreAns $ +              connect (uniformArrow utip connline) pt (displaceH 60 pt)++    lbl   = promoteR1 $ \pt -> fmap ignoreAns $ +              atStartAddr (textline name) (displaceH 66 pt) WW 

@@ -0,0 +1,107 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++module Automata where++import Wumpus.Drawing.Connectors+import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Shapes+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs+import Wumpus.Drawing.Text.Base.Label+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader++import Wumpus.Core                              -- package: wumpus-core++import System.Directory++++main :: IO ()+main = simpleFontLoader main1 >> return ()++main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Right times_roman_family  ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) automata+    writeEPS "./out/automata.eps" pic1+    writeSVG "./out/automata.svg" pic1 +++makeCtx :: FontLoadResult -> DrawingContext+makeCtx = +    snap_grid_factors 60.0 60.0 . set_font times_roman . metricsContext 14+++automata :: CtxPicture+automata = udrawTracing (0::Double) $ do+    q0     <- nodei (8,0)   $ state "q0"+    q1     <- drawi $ state "q1"      `mat` above_right_of q0+    q2     <- drawi $ state "q2"      `mat` below_right_of q0+    q3     <- drawi $ stopstate "q3"  `mat` below_right_of q1++    s0     <- evalQuery $ left_of q0++    draw $ label_midway_of SE (textline "0") $ straightconn q0 q1+    draw $ label_midway_of SS (textline "0") $ arrloop (center q1) (north q1) +    draw $ label_midway_of SW (textline "1") $ straightconn q1 q3+    draw $ label_midway_of NE (textline "1") $ straightconn q0 q2+    draw $ label_midway_of NW (textline "0") $ straightconn q2 q3+    draw $ label_midway_of NN (textline "1") $ arrloop (center q2) (south q2) +    draw $ label_atstart_of EE (textline "start") $ astraightconn s0 (west q0) ++    return ()+++infixr 1 `mat`++mat :: LocImage u a -> Query (Point2 u) -> Image u a+mat img mq = mq >>= \pt -> img `at` pt++state :: String -> DLocImage DCircle+state ss = +    localize (set_font times_italic) $ +        label_center_of (textline ss) $ strokedShape $ circle 20+++stopstate :: String -> DLocImage DCircle +stopstate ss = +    localize (set_font times_italic) $ +        label_center_of (textline ss) $ dblStrokedShape $ circle 20++++straightconn :: ( Real u, Floating u, InterpretUnit u+                , u ~ DUnit a, u ~ DUnit b+                , CenterAnchor a, RadialAnchor a+                , CenterAnchor b, RadialAnchor b+                )+             => a -> b -> Image u (AbsPath u)+straightconn a b =+    let (p0,p1) = radialConnectorPoints a b+    in connect (rightArrow tri45 connline) p0 p1+++astraightconn :: ( Real u, Floating u, InterpretUnit u)+              => Anchor u -> Anchor u -> Image u (AbsPath u)+astraightconn p0 p1 = connect (rightArrow tri45 connline) p0 p1+++-- Note - there is a problem with @rightArrow@ as @loop@+-- manufactures the start and end points...+--+arrloop :: ( Real u, Floating u, InterpretUnit u, Tolerance u)+        => Anchor u -> Anchor u -> Image u (AbsPath u)+arrloop p0 p1 = connect (rightArrow barb45 loop) p0 p1+++++++

@@ -12,11 +12,9 @@  module ClipPic where -import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths-import Wumpus.Drawing.Paths.MonadicConstruction-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic @@ -30,76 +28,83 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    let pic = runCtxPictureU pic_drawing_ctx big_pic-    writeEPS "./out/clip_pic.eps" pic-    writeSVG "./out/clip_pic.svg" pic+    let pic1 = runCtxPictureU std_ctx $ top_pic `vconcat` clip_pic+    writeEPS "./out/clip_pic.eps" pic1+    writeSVG "./out/clip_pic.svg" pic1  -pic_drawing_ctx :: DrawingContext-pic_drawing_ctx = standardContext 14+std_ctx :: DrawingContext+std_ctx = standardContext 14  -big_pic :: DCtxPicture-big_pic = pic1 `cxpDown` oconcat cpic1 [cpic2, cpic3, cpic4]--fillPath :: Num u => Path u -> Graphic u-fillPath = filledPath . toPrimPath+top_pic :: CtxPicture+top_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do+    draw $ toPrimPath path01 >>= filledPath+    draw $ localize (fill_colour powder_blue) $ toPrimPath path02 >>= filledPath+    draw $ toPrimPath path03 >>= filledPath+    draw $ toPrimPath path04 >>= filledPath -pic1 :: DCtxPicture-pic1 = drawTracing $ localize (fillColour medium_slate_blue) $ do-    draw $ fillPath path01-    draw $ localize (fillColour powder_blue) $ fillPath path02-    draw $ fillPath path03-    draw $ fillPath path04+clip_pic :: CtxPicture+clip_pic = drawTracing $ do+    mapM_ draw $ [ clip1, clip2, clip3, clip4 ]  -background :: RGBi -> DCtxPicture-background rgb = drawTracing $ -    draw $ localize (strokeColour rgb) $ ihh `at` P2 0 288+background :: RGBi -> Graphic Double+background rgb = +    fmap ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288   where-    ihh = unchain 112 emptyLocGraphic iheartHaskell $ tableDown 18 (86,16)+    ihh = chain (tableDown 18 (86,16)) (replicate 112 iheartHaskell) -cpic1 :: DCtxPicture -cpic1 = clipCtxPicture (toPrimPath path01) (background black)+-- Wumpus-Basic needs a clip function, but is this the most +-- satisfactory definition?+--+clipGraphic :: PrimPath -> Graphic u -> Graphic u +clipGraphic cp = fmap (clipObject cp)+++clip1 :: Graphic Double+clip1 = toPrimPath path01 >>= \pp -> clipGraphic pp (background black)   -cpic2 :: DCtxPicture-cpic2 = clipCtxPicture (toPrimPath path02) (background medium_violet_red)+clip2 :: Graphic Double+clip2 = toPrimPath path02 >>= \pp -> clipGraphic pp (background medium_violet_red) -cpic3 :: DCtxPicture -cpic3 = clipCtxPicture (toPrimPath path03) (background black)+clip3 :: Graphic Double+clip3 = toPrimPath path03 >>= \pp -> clipGraphic pp (background black) -cpic4 :: DCtxPicture -cpic4 = clipCtxPicture (toPrimPath path04) (background black)+clip4 :: Graphic Double+clip4 = toPrimPath path04 >>= \pp -> clipGraphic pp (background black)  -iheartHaskell :: Num u => FromPtSize u => LocGraphic u+iheartHaskell :: LocGraphic Double iheartHaskell = promoteR1 $ \pt -> -    let body  = textline "I Haskell" `at` pt-        heart = localize (fontFace symbol) $ -                  textline "&heart;" `at` (pt .+^ hvec 7)+    let body  = plainTextLine "I Haskell" `at` pt+        heart = localize (set_font symbol) $ +                  plainTextLine "&heart;" `at` (pt .+^ hvec 7)     in body `oplus` heart  -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))+path01 :: AbsPath Double+path01 = evalAbsBuild zeroPt $  hline 80 +                             >> relline (vec 112 160) +                             >> relline (vec (-112) 160)+                             >> hline (-80)+                             >> relline (vec 112 (-160))+                             >> relline (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))+path02 :: AbsPath Double+path02 = evalAbsBuild (P2 112 0) $  hline 80 +                                 >> relline (vec 72 112)+                                 >> relline (vec 72 (-112))+                                 >> hline 80+                                 >> relline (vec (-224) 320)+                                 >> hline (-80)+                                 >> relline (vec 112 (-160))+                                 >> relline (vec (-112) (-160)) -path03 :: Floating u => Path u-path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) +path03 :: AbsPath Double+path03 = evalAbsBuild (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) +path04 :: AbsPath Double+path04 = evalAbsBuild (P2 328 192) $ hline 152 >> vline 56 >> hline (-192)  

@@ -4,7 +4,6 @@  import ColourChartUtils -import Wumpus.Drawing.Chains  import Wumpus.Basic.Kernel                      -- package: wumpus-basic @@ -22,28 +21,27 @@     writeSVG "./out/SVGcolours.svg" svg_pic     --     let x11_p = runCtxPictureU draw_ctx x11_portrait-    writeEPS "./out/X11colours.eps" $ uniformScale 0.75 x11_p+    writeEPS "./out/X11colours.eps" $ scale 0.75 0.75 x11_p     let x11_l = runCtxPictureU draw_ctx x11_landscape     writeSVG "./out/X11colours.svg" x11_l  draw_ctx :: DrawingContext draw_ctx = (standardContext 9) -svg :: CtxPicture Double+svg :: CtxPicture svg = makeDrawing 52 all_svg_colours -x11_landscape :: CtxPicture Double+x11_landscape :: CtxPicture x11_landscape = makeDrawing 52 all_x11_colours -x11_portrait :: CtxPicture Double+x11_portrait :: CtxPicture x11_portrait = makeDrawing 72 all_x11_colours      -makeDrawing :: Int -> [(String,RGBi)] -> DCtxPicture+makeDrawing :: Int -> [(String,RGBi)] -> CtxPicture makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs  tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double ()-tableGraphic row_count xs = -    draw $ unchainZip emptyLocGraphic gs chn `at` pt+tableGraphic row_count xs = draw $ (chain_ chn gs) `at` pt   where     chn  = tableDown row_count (152,11)     pt   = displaceV (fromIntegral $ 11 * row_count) zeroPt @@ -51,9 +49,9 @@      colourSample :: String -> RGBi -> LocGraphic Double-colourSample name rgb = localize (fillColour rgb) $ +colourSample name rgb = localize (fill_colour rgb) $      promoteR1 $ \pt ->         oplus (borderedRectangle 15 10 `at` pt)-            (textline name `at` displace 20 2 pt)+            (plainTextLine name `at` displace 20 2 pt)          

@@ -2,73 +2,87 @@  module Connectors where --import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths hiding ( length )+import Wumpus.Drawing.Connectors+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core ++ import System.Directory + main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx conn_pic-    writeEPS "./out/connectors01.eps" pic1-    writeSVG "./out/connectors01.svg" pic1+main = simpleFontLoader main1 >> return () +main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) conn_pic+    writeEPS "./out/connectors.eps" pic1+    writeSVG "./out/connectors.svg" pic1 +           +makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 11 -conn_pic :: CtxPicture Double-conn_pic = drawTracing $ tableGraphic $ conntable+conn_pic :: CtxPicture +conn_pic = drawTracing $ localize (dest_arm_len (0.75::Em))+                       $ tableGraphic conntable -conntable :: [ConnectorPath Double]+conntable :: [(String, Connector 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   +    [ ("connline",      connline)+    , ("connarc",       connarc)+    , ("connhdiagh",    connhdiagh)+    , ("connvdiagv",    connvdiagv)+    , ("conndiagh",     conndiagh)+    , ("conndiagv",     conndiagv)+    , ("connhdiag",     connhdiag)+    , ("connvdiag",     connvdiag)+    , ("connabar",      connabar)+    , ("connbbar",      connbbar)+    , ("connaright",    connaright)+    , ("connbright",    connbright)+    , ("connhrr",       connhrr)+    , ("connrrh",       connrrh)+    , ("connvrr",       connvrr)+    , ("connrrv",       connrrv)+    , ("connaloop",     connaloop)+    , ("connbloop",     connbloop)+    , ("connhbezier",   connhbezier)+    , ("connvbezier",   connvbezier)     ] -tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [ConnectorPath u] -> TraceDrawing u ()+tableGraphic :: [(String, Connector Double)] -> TraceDrawing Double () tableGraphic conns = -    draw $ unchainZipWith emptyLocGraphic makeConnDrawing conns chn `at` start+    draw $ chain_ chn_alg (map makeConnDrawing conns) `at` start   where-    chn   = tableDown 10 (120,52) -    start = P2 0 520 +    chn_alg   = tableDown 8 (180,64) +    start     = P2 0 520     std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18+std_ctx = fill_colour peru $ standardContext 18   -makeConnDrawing :: (Real u, Floating u, FromPtSize u) -                 => ConnectorPath u -> LocGraphic u-makeConnDrawing conn = -    promoteR1 $ \p0 -> fmap (replaceL uNil) $ -        connect (uniformArrow curveTip conn) p0 (mkP1 p0)+makeConnDrawing :: (String, Connector Double) -> DLocGraphic +makeConnDrawing (ss,conn) = +    promoteR1 $ \p0 -> fn p0 (displace 60 40 p0)    where-    mkP1 = displace 100 40-  +    fn p0 p1   = disk p0 `oplus` disk p1 `oplus` dcon p0 p1 `oplus` lbl p1++    disk pt    = localize (fill_colour red) $ filledDisk 2 `at` pt+    dcon p0 p1 = fmap ignoreAns $ connect (uniformArrow curveTip conn) p0 p1++    lbl  pt    = fmap ignoreAns $ atStartAddr (textline ss) (displaceH 10 pt) WW+ 

@@ -2,18 +2,12 @@  module DotPic where ---import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.AnchorDots-import Wumpus.Drawing.Text.SafeFonts--import FontLoaderUtils+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core @@ -21,45 +15,25 @@  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..."-+main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO ()-makeGSPicture font_dir = do -    putStrLn "Using GhostScript metrics..."-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics     let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic-    writeEPS "./out/dot_pic01_gs.eps" pic1-    writeSVG "./out/dot_pic01_gs.svg" pic1+    writeEPS "./out/dot_pic.eps" pic1+    writeSVG "./out/dot_pic.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 = runCtxPictureU (makeCtx base_metrics) dot_pic-    writeEPS "./out/dot_pic01_afm.eps" pic1-    writeSVG "./out/dot_pic01_afm.svg" pic1-  -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fillColour peru . fontFace helvetica . metricsContext 24+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = fill_colour peru . set_font helvetica . metricsContext 24  -dot_pic :: CtxPicture Double+dot_pic :: CtxPicture dot_pic = drawTracing $ tableGraphic $      [ dotHLine     , dotVLine@@ -82,13 +56,12 @@     ]  -tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [DotLocImage u] -> TraceDrawing u ()+tableGraphic :: [DotLocImage Double] -> TraceDrawing Double () tableGraphic imgs = -    draw $ unchainZipWith emptyLocGraphic makeDotDrawing imgs chn `at` pt+    draw $ chain_ chn_alg (map makeDotDrawing imgs) `at` pt   where     row_count   = length imgs-    chn         = tableDown row_count (1,36)+    chn_alg     = tableDown row_count (1,36)     pt          = displaceV (fromIntegral $ 36 * row_count) zeroPt   @@ -96,20 +69,18 @@ -- This is a bit convoluted - maybe there should be chain-run  -- functions for TraceDrawings as well as LocGraphics? -makeDotDrawing :: (Real u, Floating u, FromPtSize u) +makeDotDrawing :: (Real u, Floating u, InterpretUnit u)                 => DotLocImage u -> LocGraphic u makeDotDrawing dotF =      promoteR1 $ \pt ->          let all_points = map (pt .+^) displacements         in oconcat (dashline all_points)-                   (map (\p1 -> ignoreL $ dotF `at` p1) all_points)+                   (map (\p1 -> fmap ignoreAns $ dotF `at` p1) all_points)   where-    dashline = \ps -> localize attrUpd (openStroke $ vertexPath ps)+    dashline = \ps -> localize attrUpd $ vertexPP ps >>= openStroke      attrUpd  :: DrawingContext -> DrawingContext-    attrUpd  =  dashPattern (evenDashes 1) . strokeColour cadet_blue--    ignoreL  = fmap (replaceL uNil) +    attrUpd  = packed_dotted . stroke_colour cadet_blue  displacements :: Num u => [Vec2 u] displacements = [V2 0 0, V2 64 20, V2 128 0, V2 192 20]

@@ -1,66 +1,45 @@-{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}    module FeatureModel where -import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Paths +import Wumpus.Drawing.Connectors+import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript+import Wumpus.Basic.System.FontLoader  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..."+main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO ()-makeGSPicture font_dir = do -    putStrLn "Using GhostScript metrics..."-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Courier-Bold"]-    mapM_ putStrLn msgs+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left courier_bold ]+    printLoadErrors base_metrics     let pic1 = runCtxPictureU (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 = runCtxPictureU (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+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font courier_bold . metricsContext 18   -- Note - I haven't worked out how to do @alternative@, @or@ and -- @repetitions@ yet. --          -feature_model :: CtxPicture Double -feature_model = drawTracing $ do+feature_model :: CtxPicture+feature_model = udrawTracing (0::Double) $ do     lea <- widebox "e" $ P2 150 160         lra <- widebox "r" $ P2  60  80     lsa <- widebox "s" $ P2 240  80@@ -91,46 +70,45 @@  -- Note - ctrCenterLine does not seem to be working well... -makeBox :: (Real u, Floating u, FromPtSize u) +makeBox :: (Real u, Floating u, InterpretUnit u, Tolerance u)          => u -> String -> Point2 u -> TraceDrawing u (Box u) makeBox w ss pt = do      a <- drawi $ (strokedShape $ rectangle w 20) `at` pt-    drawi_ $ textAlignCenter ss `at` center a-    -- draw  $ filledDisk 2 `at` center a+    drawl (center a) $ ccTextline ss     return a -box :: (Real u, Floating u, FromPtSize u) +box :: (Real u, Floating u, InterpretUnit u, Tolerance u)      => String -> Point2 u -> TraceDrawing u (Box u) box = makeBox 40 -widebox :: (Real u, Floating u, FromPtSize u) +widebox :: (Real u, Floating u, InterpretUnit u, Tolerance 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 :: ( Real u, Floating u, InterpretUnit u ) +         => ArrowTip u -> Box u -> Box u -> TraceDrawing u (AbsPath u) connWith arrh b0 b1 = do    lw <- getLineWidth    let p0 = south b0    let p1 = projectAnchor north (realToFrac lw) b1-   drawi $ apply2R2 (rightArrow arrh connLine) p0 p1+   drawi $ connect (rightArrow arrh connline) p0 p1  infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` -cmandatory :: ( Real u, Floating u, FromPtSize u ) -           => Box u -> Box u -> TraceDrawing u (Path u)+cmandatory :: ( Real u, Floating u, InterpretUnit u ) +           => Box u -> Box u -> TraceDrawing u (AbsPath u) cmandatory = connWith diskTip -coptional :: ( Real u, Floating u, FromPtSize u ) -          => Box u -> Box u -> TraceDrawing u (Path u)+coptional :: ( Real u, Floating u, InterpretUnit u ) +          => Box u -> Box u -> TraceDrawing u (AbsPath u) coptional = connWith odiskTip  -cmandatory_ :: ( Real u, Floating u, FromPtSize u ) +cmandatory_ :: ( Real u, Floating u, InterpretUnit u )              => Box u -> Box u -> TraceDrawing u () cmandatory_ p0 p1 = connWith diskTip p0 p1 >> return () -coptional_ :: ( Real u, Floating u, FromPtSize u ) +coptional_ :: ( Real u, Floating u, InterpretUnit u )             => Box u -> Box u -> TraceDrawing u () coptional_ p0 p1 = connWith odiskTip p0 p1 >> return ()

@@ -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-

@@ -2,10 +2,9 @@  module FontPic where -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.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic @@ -35,16 +34,17 @@     writeSVG "./out/font_symbol.svg"    symbol_pic  -fontMsg :: FontFace -> Int -> String-fontMsg ff sz = msgF []+fontMsg :: FontDef -> Int -> String+fontMsg ft sz = msgF []   where-    msgF = showString (ps_font_name ff) . showChar ' ' . shows sz . showString "pt"+    msgF = showString name . showChar ' ' . shows sz . showString "pt"+    name = ps_font_name $ font_def_face ft   -makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic-makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz)+makeLabel :: RGBi -> FontDef -> Int -> DLocGraphic+makeLabel rgb ft sz = localize upd (plainTextLine $ fontMsg ft sz)   where-    upd = fillColour rgb . fontAttr ff sz +    upd = text_colour rgb . font_attr ft sz   -- indian_red1 -- steel_blue@@ -55,35 +55,39 @@ positions :: [Int] positions = [0, 12, 27, 49, 78, 122]  --pointChain :: LocChain Double-pointChain = verticalSteps $ map (fromIntegral . (+2)) point_sizes+-- Note - this chain might be worth putting in a library...+pointChain :: (Int -> DLocGraphic) -> DLocImage DPoint2+pointChain fn = chain chn_alg $ map fn point_sizes+  where+    chn_alg = linear $ iterationScheme start step+    start   = \pt -> (pt,point_sizes) +    step (pt,[])     = ((displaceV 50 pt, []), pt)+    step (pt,(y:ys)) = ((displaceV (fromIntegral $ 2 + y)  pt, ys), pt) -fontGraphic :: RGBi -> FontFace -> DLocGraphic -fontGraphic rgb ff = -    unchainZipWith emptyLocGraphic mkGF point_sizes pointChain +fontGraphic :: RGBi -> FontDef -> DLocGraphic +fontGraphic rgb ft = locGraphic_ $ pointChain mkGF   where-    mkGF sz = makeLabel rgb ff sz+    mkGF sz = makeLabel rgb ft sz   std_ctx :: DrawingContext std_ctx = standardContext 10  -fontDrawing :: [(RGBi,FontFace)] -> DCtxPicture+fontDrawing :: [(RGBi,FontDef)] -> CtxPicture fontDrawing xs = drawTracing $  -    draw $ unchainZipWith emptyLocGraphic (uncurry fontGraphic) xs chn `at` start+    draw $ chain_ chn_alg (map (uncurry fontGraphic) xs) `at` start   where-    chn   = tableDown 4 (1,180)-    start = P2 0 (4*180)+    chn_alg   = tableDown 4 (1,180)+    start     = P2 0 (4*180)    -------------------------------------------------------------------------------- -- Times -times_cxpic :: CtxPicture Double+times_cxpic :: CtxPicture times_cxpic =      fontDrawing [ (steel_blue,  times_roman)                 , (indian_red1, times_italic)@@ -91,7 +95,7 @@                 , (indian_red1, times_bold_italic)                 ]  -helvetica_cxpic :: CtxPicture Double+helvetica_cxpic :: CtxPicture helvetica_cxpic =      fontDrawing [ (steel_blue,  helvetica)                 , (indian_red1, helvetica_oblique)@@ -103,7 +107,7 @@  -------------------------------------------------------------------------------- -courier_cxpic :: CtxPicture Double+courier_cxpic :: CtxPicture courier_cxpic =      fontDrawing [ (steel_blue,  courier)                 , (indian_red1, courier_oblique)@@ -115,6 +119,6 @@ --------------------------------------------------------------------------------      -symbol_cxpic :: CtxPicture Double+symbol_cxpic :: CtxPicture symbol_cxpic =      fontDrawing [ (steel_blue, symbol) ]

@@ -15,79 +15,54 @@  module LeftRightText where -import FontLoaderUtils  import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.Marks-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts-+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript+import Wumpus.Basic.System.FontLoader  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 = runCtxPictureU (makeCtx gs_metrics) text_pic-    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 = runCtxPictureU (makeCtx afm_metrics) text_pic-    writeEPS "./out/lr_text02.eps" pic2-    writeSVG "./out/lr_text02.svg" pic2+main = simpleFontLoader main1 >> return () +main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) text_pic+    writeEPS "./out/left_right_text.eps" pic1+    writeSVG "./out/left_right_text.svg" pic1   -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace helvetica . metricsContext 14+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 15  -text_pic :: CtxPicture Double-text_pic = drawTracing $ do -    drawi_ $ (fn left_text)       `at` P2   0 400-    drawi_ $ (fn center_text)     `at` P2 150 400-    drawi_ $ (fn right_text)      `at` P2 300 400-    drawi_ $ (fn blank_text)      `at` P2   0 300-    drawi_ $ (fn ne_oneline)      `at` P2 150 300 -    drawi_ $ (fn cc_oneline)      `at` P2 300 300+text_pic :: CtxPicture+text_pic = udrawTracing (0::Double) $ localize text_margin_loose $ do +    draw $ (fn left_text)       `at` P2   0 400+    draw $ (fn center_text)     `at` P2 150 400+    draw $ (fn right_text)      `at` P2 300 400+    draw $ (fn blank_text)      `at` P2   0 300+    draw $ (fn ne_oneline)      `at` P2 150 300 +    draw $ (fn cc_oneline)      `at` P2 300 300  -    drawi_ $ (fn sw_oneline)      `at` P2   0 200-    drawi_ $ (fn ss_oneline)      `at` P2 150 200-    drawi_ $ (fn se_oneline)      `at` P2 300 200-    drawi_ $ (fn swr_multi)       `at` P2   0 100-    drawi_ $ (fn ssr_multi)       `at` P2 150 100-    drawi_ $ (fn ner_multi)       `at` P2 300 100-    drawi_ $ (fn rleft_text)      `at` P2   0 (-75)-    drawi_ $ (fn rcenter_text)    `at` P2 150 (-75)-    drawi_ $ (fn rright_text)     `at` P2 300 (-75)+    draw $ (fn sw_oneline)      `at` P2   0 200+    draw $ (fn ss_oneline)      `at` P2 150 200+    draw $ (fn se_oneline)      `at` P2 300 200+    draw $ (fn swr_single)      `at` P2   0 100+    draw $ (fn ssr_single)      `at` P2 150 100+    draw $ (fn ner_single)      `at` P2 300 100      draw $ redPlus            `at` P2   0 400     draw $ redPlus            `at` P2 150 400@@ -108,78 +83,67 @@   where     fn = illustrateBoundedLocGraphic    -redPlus :: (Fractional u, FromPtSize u) => LocGraphic u-redPlus = localize (strokeColour red) markPlus+redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u+redPlus = localize (stroke_colour red) markPlus    -- single line -- ne_oneline :: BoundedLocGraphic Double-ne_oneline = singleLine "north east" `startPos` NE+ne_oneline = textline "north east" `startAddr` NE   -- single line -- se_oneline :: BoundedLocGraphic Double-se_oneline = singleLine "south east" `startPos` SE+se_oneline = textline "south east" `startAddr` SE  -- single line -- ss_oneline :: BoundedLocGraphic Double-ss_oneline = singleLine "south" `startPos` SS+ss_oneline = textline "south" `startAddr` SS  -- single line -- sw_oneline :: BoundedLocGraphic Double-sw_oneline = singleLine "south west" `startPos` SW+sw_oneline = textline "south west" `startAddr` SW  --- multi line++-- single line rot ---ssr_multi :: BoundedLocGraphic Double-ssr_multi = multiAlignCenter (0.25*pi) "south rot45" `startPos` SS+ssr_single :: BoundedLocGraphic Double+ssr_single = rtextline (0.25*pi) "south rot45" `startAddr` SS --- multi line+-- single line rot ---swr_multi :: BoundedLocGraphic Double-swr_multi = multiAlignCenter (0.25*pi) "south west rot45" `startPos` SW+swr_single :: BoundedLocGraphic Double+swr_single = rtextline (0.25*pi)  "south west rot45" `startAddr` SW --- multi line+-- single line rot ---ner_multi :: BoundedLocGraphic Double-ner_multi = multiAlignCenter (0.25*pi) "north east rot45" `startPos` NE+ner_single :: BoundedLocGraphic Double+ner_single = rtextline (0.25*pi)  "north east rot45" `startAddr`  NE   cc_oneline :: BoundedLocGraphic Double-cc_oneline = rsingleLine 0 "Center-center..."  `startPos` CENTER+cc_oneline = ccTextline "Center-center..."   blank_text :: BoundedLocGraphic Double-blank_text = multiAlignCenter 0 "" `startPos` CENTER+blank_text = blcTextline ""   left_text :: BoundedLocGraphic Double-left_text = multiAlignLeft 0 dummy_text `startPos` CENTER+left_text = multiAlignLeft dummy_text `startAddr` CENTER   right_text :: BoundedLocGraphic Double-right_text = multiAlignRight 0 dummy_text `startPos` CENTER+right_text = multiAlignRight dummy_text `startAddr` CENTER  center_text :: BoundedLocGraphic Double-center_text = multiAlignCenter 0 dummy_text `startPos` CENTER---rleft_text :: BoundedLocGraphic Double-rleft_text = multiAlignLeft (0.25*pi)  dummy_text `startPos` CENTER---rright_text :: BoundedLocGraphic Double-rright_text = multiAlignRight (0.25*pi) dummy_text `startPos` CENTER--rcenter_text :: BoundedLocGraphic Double-rcenter_text = multiAlignCenter (0.25*pi) dummy_text `startPos` CENTER-+center_text = multiAlignCenter dummy_text `startAddr` CENTER  dummy_text :: String  dummy_text = unlines $ [ "The quick brown"

@@ -7,18 +7,14 @@  module PetriNet where -import Wumpus.Drawing.Arrows import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths+import Wumpus.Drawing.Connectors import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.SafeFonts-import Wumpus.Drawing.Text.LRText--import FontLoaderUtils+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core @@ -26,135 +22,117 @@ 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..."+main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO ()-makeGSPicture font_dir = do -    putStrLn "Using GhostScript metrics..."-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica", "Helvetica-Bold"]-    mapM_ putStrLn msgs+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Right helvetica_family ]+    printLoadErrors base_metrics     let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net-    writeEPS "./out/petri_net01.eps" pic1-    writeSVG "./out/petri_net01.svg" pic1 +    writeEPS "./out/petri_net.eps" pic1+    writeSVG "./out/petri_net.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 = runCtxPictureU (makeCtx base_metrics) petri_net-    writeEPS "./out/petri_net02.eps" pic1-    writeSVG "./out/petri_net02.svg" pic1 +makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 14  -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace helvetica . metricsContext 14-+petri_net :: CtxPicture+petri_net = udrawTracing (0::Double) $ do+    pw     <- drawi $ place         `at` (P2 0 140)+    tu1    <- drawi $ transition    `at` (P2 70 140)  +    rtw    <- drawi $ place         `at` (P2 140 140)+    tu2    <- drawi $ transition    `at` (P2 210 140)+    w      <- drawi $ place         `at` (P2 280 140)+    tu3    <- drawi $ transition    `at` (P2 350 140)+    res    <- drawi $ place         `at` (P2 280 70)+    pr     <- drawi $ place         `at` (P2 0 0)+    tl1    <- drawi $ transition    `at` (P2 70 0)+    rtr    <- drawi $ place         `at` (P2 140 0)+    tl2    <- drawi $ transition    `at` (P2 210 0)+    r      <- drawi $ place         `at` (P2 280 0)+    tl3    <- drawi $ transition    `at` (P2 350 0) -petri_net :: DCtxPicture-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) +    drawc (east pw)  (west tu1)   $ straightconn+    drawc (east tu1) (west rtw)   $ straightconn+    drawc (east rtw) (west tu2)   $ straightconn+    drawc (east tu2) (west w)     $ straightconn+    drawc (east w)   (west tu3)   $ straightconn+    drawc (north tu3) (north pw)  $ connectorC +    drawc (east pr)  (west tl1)   $ straightconn+    drawc (east tl1) (west rtr)   $ straightconn+    drawc (east rtr) (west tl2)   $ straightconn+    drawc (east tl2) (west r)     $ straightconn+    drawc (east r)   (west tl3)   $ straightconn+    drawc (south tl3) (south pr)  $ connectorC'+    drawc (southwest res) (northeast tl2) $ straightconn+    drawc (northwest tl3) (southeast res) $ straightconn+    drawc (southwest tu3) (northeast res) $ connectorD+    drawc (southwest tu3) (northeast res) $ connectorD'+    drawc (northwest res) (southeast tu2) $ connectorD+    drawc (northwest res) (southeast tu2) $ connectorD'     draw $ lblParensParens `at` (P2 (-36) 150)     draw $ lblParensParens `at` (P2 300 60)     draw $ lblParensParensParens `at` (P2 (-52) (-14))-    draw $ lblBold "processing_w"   `at` (projectAnchor south 12 pw)-    draw $ lblBold "ready_to_write" `at` (projectAnchor south 12 rtw)-    draw $ lblBold "writing"        `at` (projectAnchor south 12 w)-    draw $ lblBold' "resource"      `at` (P2 300 72)-    draw $ lblBold "processing_r"   `at` (projectAnchor north 12 pr)-    draw $ lblBold "ready_to_read"  `at` (projectAnchor north 12 rtr)-    draw $ lblBold "reading"        `at` (projectAnchor north 12 r)+    drawl (projectAnchor south 12 pw)     $ lblBold "processing_w"+    drawl (projectAnchor south 12 rtw)    $ lblBold "ready_to_write"+    drawl (projectAnchor south 12 w)      $ lblBold "writing"+    draw $ lblBold "resource"      `at` (P2 300 72)+    drawl (projectAnchor north 12 pr)     $ lblBold "processing_r"+    drawl (projectAnchor north 12 rtr)    $ lblBold "ready_to_read"+    drawl (projectAnchor north 12 r)      $ lblBold "reading"+     return () -greenFill :: DrawingCtxM m => m a -> m a-greenFill = localize (fillColour lime_green)+greenFill :: LocImage u a -> LocImage u a+greenFill = localize (fill_colour lime_green) -place :: ( Real u, Floating u, FromPtSize u-         , DrawingCtxM m, TraceM m, u ~ MonUnit m ) -      => u -> u -> m (Circle u)-place x y = greenFill $ drawi $ (borderedShape $ circle 14) `at` P2 x y -transition :: ( Real u, Floating u, FromPtSize u-              , DrawingCtxM m, TraceM m, u ~ MonUnit m ) -           => u -> u -> m (Rectangle u)-transition x y = -    greenFill $ drawi $ (borderedShape $ rectangle 32 22) `at` P2 x y+place :: DLocImage (Circle Double)+place = greenFill $ borderedShape $ circle 14  +transition :: DLocImage (Rectangle Double)+transition = greenFill $ borderedShape $ rectangle 32 22  -connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m-         , Real u, Floating u, FromPtSize u ) -      => Point2 u -> Point2 u -> m ()-connector' p0 p1 = -    drawi_ $ apply2R2 (rightArrow tri45 connLine) 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 (rightArrow tri45 (connRightVHV v)) p0 p1+straightconn :: ConnectorGraphic Double+straightconn = connectorGraphic_ $ rightArrow tri45 connline -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 (rightArrow tri45 (connIsosceles u)) p0 p1 +connectorC :: ConnectorGraphic Double+connectorC = +    connectorGraphic_ $ localize (uniform_arm_len  (30::Double)) +                      $ rightArrow tri45 connbbar -lblParensParens :: Num u => LocGraphic u-lblParensParens = localize (fontFace helvetica) $ textline "(),()"+connectorC' :: ConnectorGraphic Double+connectorC' = +    connectorGraphic_ $ localize (uniform_arm_len  (30::Double)) +                      $ rightArrow tri45 connabar -lblParensParensParens :: Num u => LocGraphic u-lblParensParensParens = localize (fontFace helvetica) $ textline "(),(),()"+connectorD :: ConnectorGraphic Double+connectorD = connectorGraphic_ $ rightArrow tri45 connarc +connectorD' :: ConnectorGraphic Double+connectorD' = +    connectorGraphic_ $ localize (conn_arc_angle $ negate $ pi / 12) +                      $ rightArrow tri45 connarc -lblBold' :: Num u => String -> LocGraphic u-lblBold' ss = localize (fontFace helvetica_bold) $ textline ss +lblParensParens :: DLocGraphic+lblParensParens = +    locGraphic_ $ localize (set_font helvetica) $ ccTextline "(),()" -lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u-lblBold ss = localize (fontFace helvetica_bold) $ -                ignoreAns $ textAlignCenter ss+lblParensParensParens :: DLocGraphic+lblParensParensParens = +    locGraphic_ $ localize (set_font helvetica) $ ccTextline "(),(),()"++++lblBold :: String -> DLocGraphic+lblBold ss = +    locGraphic_ $ localize (set_font helvetica_bold) $ ccTextline ss 

@@ -1,66 +1,43 @@ {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}   module SampleShapes where  -import FontLoaderUtils- import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.Marks import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core  import Control.Monad import System.Directory - main :: IO ()-main = do -    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help-    createDirectoryIfMissing True "./out/shapes/"-    maybe gs_failk  (makeGSPicture shape_list)  $ mb_gs-    maybe afm_failk (makeAfmPicture shape_list) $ mb_afm-  where-    gs_failk  = putStrLn "No GhostScript font path supplied..."-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."-+main = simpleFontLoader main1 >> return () -makeGSPicture :: ShapeList -> FilePath -> IO ()-makeGSPicture shapes font_dir = do-    putStrLn "Using GhostScript metrics..."-    (gs_metrics, msgs) <- loadGSMetrics font_dir ["Courier"]-    mapM_ putStrLn msgs-    mapM_ (out1 gs_metrics) shapes +main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/shapes/" +    base_metrics <- loader [ Left courier ]+    printLoadErrors base_metrics+    let ctx = makeCtx base_metrics+    mapM_ (out1 ctx) shape_list   where-    out1 gs_metrics (name, shape_pic) = do -       let pic1 = runCtxPictureU (makeCtx gs_metrics) $ shape_pic name+    out1 ctx (name, shape_pic) = do +       let pic1 = runCtxPictureU ctx $ shape_pic name        writeEPS ("./out/shapes/" ++ name ++ "01.eps") pic1        writeSVG ("./out/shapes/" ++ name ++ "01.svg") pic1  -makeAfmPicture :: ShapeList -> FilePath -> IO ()-makeAfmPicture shapes font_dir = do-    putStrLn "Using AFM 4.1 metrics..."-    (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Courier"]-    mapM_ putStrLn msgs-    mapM_ (out1 afm_metrics) shapes -  where-    out1 afm_metrics (name, shape_pic) = do -        let pic1 = runCtxPictureU (makeCtx afm_metrics) $ shape_pic name-        writeEPS ("./out/shapes/" ++ name ++ "02.eps") pic1-        writeSVG ("./out/shapes/" ++ name ++ "02.svg") pic1--type ShapeList = [(String, (String -> DCtxPicture))]+type ShapeList = [(String, (String -> CtxPicture))]   shape_list :: ShapeList@@ -96,10 +73,10 @@           triangle 300 150 )     ] -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace courier . metricsContext 16+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font courier . metricsContext 16 -rotate05 :: Rotate a => a -> a+rotate05 :: Rotate a => Image u a -> Image u a rotate05 = rotate (d2r (5::Double))  -- Extra elaboration...@@ -107,26 +84,27 @@ voidExtra :: a -> TraceDrawing u () voidExtra _ = return () -apexAnchor :: ( Real u, Floating u, FromPtSize u-            , ApexAnchor a-            , u ~ DUnit a )+++apexAnchor :: ( Real u, Floating u, InterpretUnit u+              , ApexAnchor a, u ~ DUnit a)             => a -> TraceDrawing u a apexAnchor a = do     draw $ label EAST   "(apex)"    `at` apex  a     return a -bottomCorners :: ( Real u, Floating u, FromPtSize u-               , BottomCornerAnchor a-               , u ~ DUnit a )+bottomCorners :: ( Real u, Floating u, InterpretUnit u+                 , BottomCornerAnchor a, u ~ DUnit a+                 )             => a -> TraceDrawing u a bottomCorners a = do     draw $ label SOUTH_WEST   "(bottom left)"    `at` bottomLeftCorner  a     draw $ label SOUTH_EAST   "(bottom right)"   `at` bottomRightCorner a     return a -topCorners :: ( Real u, Floating u, FromPtSize u-              , TopCornerAnchor a-              , u ~ DUnit a )+topCorners :: ( Real u, Floating u, InterpretUnit u+              , TopCornerAnchor a, u ~ DUnit a+              )            => a -> TraceDrawing u a topCorners a = do     draw $ label NORTH_WEST   "(top left)"    `at` topLeftCorner  a@@ -134,9 +112,9 @@     return a  -midPoints :: ( Real u, Floating u, FromPtSize u-             , SideMidpointAnchor a-             , u ~ DUnit a )+midPoints :: ( Real u, Floating u, InterpretUnit u+             , SideMidpointAnchor a, u ~ DUnit a+             )           => Int -> a -> TraceDrawing u a midPoints n a = mapM_ mf [1..n] >> return a   where@@ -146,12 +124,17 @@   -shapePic :: ( CenterAnchor a, CardinalAnchor a, CardinalAnchor2 a-            , RadialAnchor a-            , Scale a, Rotate a-            , DUnit a ~ Double) -         => (a -> DTraceDrawing b) -> DShape a -> String -> DCtxPicture-shapePic mf sh name = drawTracing $ do+shapePic :: ( Functor t+            , CenterAnchor (t Double)+            , CardinalAnchor (t Double)+            , CardinalAnchor2 (t Double)+            , RadialAnchor (t Double)+            , Scale (t Double)+            , Rotate (t Double)+            , Double ~ DUnit (t Double)+            ) +         => (t Double -> DTraceDrawing a) -> DShape t -> String -> CtxPicture+shapePic mf sh name = udrawTracing (0::Double) $ do     a1  <- localize shapeSty $ drawi $                uniformScale 2 $ rotate05 $ shape `at` (P2 100 0)     draw $ label NORTH        "(center)"      `at` center a1@@ -171,7 +154,7 @@     return ()       where     shape   = strokedShape $ setDecoration textF sh-    textF   = lift1R2 $ ignoreAns (multiAlignCenter 0 name `startPos` CENTER)+    textF   = lift1R2 $ locGraphic_ (startAddr (multiAlignCenter name) CENTER)      deg10   = d2r (10::Double)     deg110  = d2r (110::Double)@@ -184,23 +167,23 @@   shapeSty :: DrawingContextF-shapeSty = strokeColour light_steel_blue . ultrathick+shapeSty = stroke_colour light_steel_blue . line_ultra_thick -label :: (Real u, Floating u, FromPtSize u) -           => Cardinal -> String -> LocGraphic u+label :: (Real u, Floating u, InterpretUnit u) +      => Cardinal -> String -> LocGraphic u label cpos ss = markX `oplus` msg   where     (rpos,fn)     = go cpos-    msg           = ignoreAns $ moveStart (fn 10) $ -                       multiAlignCenter 0 ss `startPos` rpos+    msg           = locGraphic_ $ moveStart (fn 10) $ +                       startAddr (multiAlignCenter ss) rpos -    go NORTH      = (SS, northwards)-    go NORTH_EAST = (SW, northeastwards)-    go EAST       = (WW, eastwards) -    go SOUTH_EAST = (NW, southeastwards)-    go SOUTH      = (NN, southwards)-    go SOUTH_WEST = (NE, southwestwards)-    go WEST       = (EE, westwards)-    go NORTH_WEST = (SE, northwestwards)+    go NORTH      = (SS, disp_north)+    go NORTH_EAST = (SW, disp_northeast)+    go EAST       = (WW, disp_east) +    go SOUTH_EAST = (NW, disp_southeast)+    go SOUTH      = (NN, disp_south)+    go SOUTH_WEST = (NE, disp_southwest)+    go WEST       = (EE, disp_west)+    go NORTH_WEST = (SE, disp_northwest)    

@@ -0,0 +1,70 @@+{-# OPTIONS -Wall #-}+++module SingleChar where+++import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Dots.Marks+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader++import Wumpus.Core                              -- package: wumpus-core++import System.Directory+++main :: IO ()+main = simpleFontLoader main1 >> return ()++main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) drawing01+    writeEPS "./out/single_char.eps" pic1+    writeSVG "./out/single_char.svg" pic1+++makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 18++++drawing01 :: CtxPicture+drawing01 = drawTracing $ localize (fill_colour red) $ mf +++-- Note - Baseline positions not meaningful for multiline text++mf :: TraceDrawing Double ()+mf = localize (text_margin 6.0 6.0)  $ do+    draw $ (fn SS $ posChar 'S') `at` zeroPt+    draw $ redPlus `at` zeroPt++    draw $ (fn NN $ posChar 'N') `at` P2 40 0+    draw $ redPlus `at` P2 40 0++    draw $ (fn EE $ posChar 'E') `at` P2 80 0+    draw $ redPlus `at` P2 80 0++    draw $ (fn WW $ posChar 'W') `at` P2 120 0+    draw $ redPlus `at` P2 120 0++    draw $ (fn CENTER $ posChar 'C') `at` P2 160 0+    draw $ redPlus `at` P2 160 0++    draw $ (fn NE $ posChar 'X') `at` P2 200 0+    draw $ redPlus `at` P2 200 0++  where+    fn addr obj = illustrateBoundedLocGraphic (runPosObjectR2 obj `startAddr` addr)+++redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u+redPlus = localize (stroke_colour red) markPlus+

@@ -3,15 +3,12 @@  module SingleLine where -import FontLoaderUtils- import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core @@ -19,46 +16,29 @@   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 = runCtxPictureU (makeCtx gs_metrics) drawing01-    writeEPS "./out/single_line01.eps" pic1-    writeSVG "./out/single_line01.svg" pic1+main = simpleFontLoader main1 >> return () -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 = runCtxPictureU (makeCtx afm_metrics) drawing01-    writeEPS "./out/single_line02.eps" pic2-    writeSVG "./out/single_line02.svg" pic2+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) drawing01+    writeEPS "./out/single_line.eps" pic1+    writeSVG "./out/single_line.svg" pic1   -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace helvetica . metricsContext 12+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 12   -drawing01 :: DCtxPicture-drawing01 = drawTracing $ localize (fillColour red) $ mf +drawing01 :: CtxPicture+drawing01 = drawTracing $ localize (fill_colour red) $ mf   -mf :: (Real u, Floating u, FromPtSize u) => TraceDrawing u ()+mf :: TraceDrawing Double () mf = do     draw $ testDraw NN `at` (P2   0 200)     draw $ testDraw SS `at` (P2  75 200)@@ -71,10 +51,10 @@     draw $ testDraw CENTER    `at` (P2   0 0)      -testDraw :: (Real u, Floating u, FromPtSize u) => RectPosition -> LocGraphic u-testDraw rpos = filledDisk 2 `oplus` (ignoreAns ans)+testDraw :: RectAddress -> LocGraphic Double+testDraw rpos = filledDisk 2 `oplus` (locGraphic_ ans)   where-    ans = singleLine "Qwerty" `startPos` rpos+    ans = textline "Qwerty" `startAddr` rpos   

@@ -2,8 +2,7 @@  module Symbols where -import Wumpus.Drawing.Chains-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Core                              -- package: wumpus-core@@ -21,7 +20,7 @@   std_ctx :: DrawingContext-std_ctx = fontFace times_roman $ standardContext 12+std_ctx = set_font times_roman $ standardContext 12   -- Because the font changes, we draw the all the symbols in one@@ -29,16 +28,16 @@ -- generate better PostScript as there are less changes to the  -- /graphics state/. ---symbols :: DCtxPicture-symbols = drawTracing $ do-    draw $ localize (fontFace symbol) $ -            unchainZipWith emptyLocGraphic sdraw all_letters chn `at` start-    draw $ unchainZipWith emptyLocGraphic ldraw all_letters chn `at` start+symbols :: CtxPicture+symbols = udrawTracing (0::Double) $ do+    localize (set_font symbol) $ fontDelta $ draw $+               chain_ chn_alg (map sdraw all_letters) `at` start+    fontDelta $ draw $ chain chn_alg (map ldraw all_letters) `at` start   where-    chn             = tableDown 30 (100,20) +    chn_alg         = tableDown 30 (100,20)      start           = P2 0 (30*20)-    sdraw (s,_)     = textline s-    ldraw (_,name)  = moveStart (displaceH 16) (textline name)+    sdraw (s,_)     = plainTextLine s+    ldraw (_,name)  = moveStart (displaceH 16) (plainTextLine name)   all_letters :: [(String, String)]

@@ -4,7 +4,7 @@   import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Grids+import Wumpus.Drawing.Extras.Grids  import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Core                              -- package: wumpus-core@@ -19,32 +19,8 @@     writeSVG "./out/table_chains01.svg" pic1  std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18--table_drawing :: CtxPicture Double-table_drawing = drawTracing $ do ---    tableGraphic-    draw $ connect (interiorGrid 10) (P2 (-20) (-20)) (P2 150 80)-    draw $ grid (3,2) 20 `at` (P2 300 60)--{--tableGraphic :: (Real u, Floating u, FromPtSize u) -             => TraceDrawing u ()-tableGraphic = do -    draw $ filledDisk 3  `at` dstart-    draw $ filledDisk 3  `at` rstart-    zipchainWith (textline . show) [1..20::Int] downs-    zipchainWith (textline . show) [1..20::Int] rights-  where-    downs   = tableDown  4 (36,24) dstart-    rights  = tableRight 5 (36,24) rstart--    dstart  = P2 0   200   -- note grows down...-    rstart  = P2 240 200   -- ditto--}- ----+std_ctx = fill_colour peru $ standardContext 18 +table_drawing :: CtxPicture+table_drawing = udrawTracing (0::Double) $ do +    draw $ grid (grid_minor_colour cornflower_blue) (0,0) (4,2)

@@ -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,104 +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-  ( --    ArrowConnector-  , leftArrow-  , rightArrow-  , leftRightArrow-  , uniformArrow--  ) where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Arrows.Tips-import Wumpus.Drawing.Paths------ An arrowhead always know how to draw itself (filled triangle, --- stroked barb, etc.)------ A Path is currently always drawn with openStroke,--- eventually there might be scope for drawing --- e.g. parallel lines  ====-------- | A connector with arrow tips. The connector is an /Image/,--- drawing it returns the path - positions can be taken on the --- path (e.g. @midpoint@) for further decoration.----type ArrowConnector u = ConnectorImage u (Path u)----- | Connector with an arrow tip at the start point \/ left.----leftArrow :: (Real u, Floating u) -           => Arrowhead u -> ConnectorPath u -> ArrowConnector u-leftArrow arrh conn = promoteR2 $ \p0 p1 -> -    connect conn p0 p1           >>= \cpath -> -    arrowhead_retract_dist arrh  >>= \dl -> -    let path1   = shortenL dl cpath-        ang     = directionL path1-        g1      = openStroke $ toPrimPath path1-        g2      = atRot (arrowhead_draw arrh) p0 ang-    in  fmap (replaceL cpath) $ g1 `oplus` g2       ---- Note - returns original path-                 ---- | Connector with an arrow tip at the end point \/ right.----rightArrow :: (Real u, Floating u) -           => Arrowhead u -> ConnectorPath u -> ArrowConnector u-rightArrow arrh conn = promoteR2 $ \p0 p1 -> -    connect conn p0 p1           >>= \cpath -> -    arrowhead_retract_dist arrh  >>= \dr -> -    let path1   = shortenR dr cpath-        ang     = directionR path1-        g1      = openStroke $ toPrimPath path1-        g2      = atRot (arrowhead_draw arrh) p1 ang-    in  fmap (replaceL cpath) $ g1 `oplus` g2------ | Connector with two arrow tips, possibly different.----leftRightArrow :: (Real u, Floating u) -               => Arrowhead u -> Arrowhead u -> ConnectorPath u -               -> ArrowConnector u-leftRightArrow arrL arrR conn = promoteR2 $ \p0 p1 -> -    connect conn p0 p1           >>= \cpath -> -    arrowhead_retract_dist arrL  >>= \dL -> -    arrowhead_retract_dist arrR  >>= \dR -> -    let path1   = shortenPath dL dR cpath-        angL    = directionL path1-        angR    = directionR path1-        g1      = openStroke $ toPrimPath path1-        gL      = atRot (arrowhead_draw arrL) p0 angL-        gR      = atRot (arrowhead_draw arrR) p1 angR-    in  fmap (replaceL cpath) $ g1 `oplus` gL `oplus` gR----- | Connector with the same arrow tip at both ends.----uniformArrow :: (Real u, Floating u) -             => Arrowhead u -> ConnectorPath u -> ArrowConnector u-uniformArrow arrh cp = leftRightArrow arrh arrh cp-

@@ -1,515 +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 a Graphic and a retract distance - --- lines should be shortened for certain drawings (e.g. open--- triangles).------ The retract distance is context sensitive - usually just on--- the markHeight (or halfMarkHeight) so it has to be calculated--- w.r.t. the DrawingCtx.----data Arrowhead u = Arrowhead -      { arrowhead_retract_dist  :: DrawingInfo u-      , arrowhead_draw          :: LocThetaGraphic u -      }----- Design note - this used to be a newtype wrapper over a --- LocThetaImage that returned retract distance. But, considering --- the dataflow / evaluation, in some respects Arrowhead is not an --- ideal LocThetaImage as we want the retract distance to work out --- how to draw the image.------ Images do not inherently encode objects that should be drawn --- and evaluated at the same time (and lazy eval permits this) but --- it seems to helpful to think that Images should be evaluated as --- they are drawn.-------- | 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 => DrawingInfo u-noRetract = pure 0 ----- | Arrow tips are drawn with a sloid line even if the connector--- line is dashed (tips also override round corners)--solidArrTip :: DrawingCtxM m => m a -> m a-solidArrTip mf = localize (dashPattern Solid . roundCornerFactor 0) mf---solidOpenStroke :: Num  u => PrimPath u -> Graphic  u-solidOpenStroke = solidArrTip . openStroke--solidClosedStroke :: Num  u => PrimPath u -> Graphic  u-solidClosedStroke = solidArrTip . closedStroke--solidStrokedDisk :: Num  u => u -> LocGraphic  u-solidStrokedDisk = solidArrTip . strokedDisk------------------------------------------------------------------------------------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 markHeight (triTLG (pi/2) filledPath)---tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri60 = Arrowhead markHeight (triTLG (pi/3) filledPath)---tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri45 = Arrowhead markHeight (triTLG (pi/4) filledPath)--otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri90 = Arrowhead markHeight (triTLG (pi/2) solidClosedStroke)--otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri60 = Arrowhead markHeight (triTLG (pi/3) solidClosedStroke)--otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri45 = Arrowhead markHeight (triTLG (pi/4) solidClosedStroke)----- 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 markHeightLessLineWidth-                     (revtriTLG (pi/2) filledPath)--revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revtri60 = Arrowhead markHeightLessLineWidth-                     (revtriTLG (pi/3) filledPath)--revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revtri45 = Arrowhead markHeightLessLineWidth-                     (revtriTLG (pi/4) filledPath)---orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri90 = Arrowhead markHeightLessLineWidth-                      (revtriTLG (pi/2) solidClosedStroke)--orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri60 = Arrowhead markHeightLessLineWidth-                      (revtriTLG (pi/3) solidClosedStroke)--orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri45 = Arrowhead markHeightLessLineWidth-                      (revtriTLG (pi/4) solidClosedStroke)----barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u-barbTLG ang =  -    promoteR2 $ \pt theta -> -      apply2R2 (tripointsByAngle ang) pt theta >>= \(u,v) -> -        solidOpenStroke $ vertexPath [u,pt,v]----barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb90 = Arrowhead noRetract (barbTLG (pi/2))--barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb60 = Arrowhead noRetract (barbTLG (pi/3))---barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb45 = Arrowhead 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) -> -        solidOpenStroke $ vertexPath [u,pt',v]--revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb90 = Arrowhead markHeight (revbarbTLG (pi/2))---revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb60 = Arrowhead markHeight (revbarbTLG (pi/3))--revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb45 = Arrowhead markHeight (revbarbTLG (pi/4))---perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u-perpTLG = -    tipBody $ \pt theta h -> -      let hh = 0.5*h in solidOpenStroke $ 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 noRetract perpTLG----bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u-bracketTLG = -    tipBody $ \pt theta h -> -      let hh = 0.5*h in solidOpenStroke $ 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 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 markHeight (diskTLG drawF)-  where-    drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt---odiskTip :: (Floating u, FromPtSize u) => Arrowhead u-odiskTip = Arrowhead markHeight (diskTLG drawF)-  where-    drawF r pt = solidStrokedDisk 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 markHeight (squareTLG drawF)-  where-    drawF = localize bothStrokeColour . filledPath---osquareTip :: (Floating u, FromPtSize u) => Arrowhead u-osquareTip = Arrowhead markHeight (squareTLG solidClosedStroke)---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 (fmap (2*) markHeightLessLineWidth) -                       (diamondTLG drawF)-  where-    drawF = localize bothStrokeColour . filledPath---odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u-odiamondTip = Arrowhead (fmap (2*) markHeight) (diamondTLG solidClosedStroke)------- 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) (solidOpenStroke 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 (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) (solidOpenStroke 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 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,259 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Chains.Base--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Generate points in an iterated chain.--------------------------------------------------------------------------------------module Wumpus.Drawing.Chains.Base-  (--    PointChain-  , LocChain-  , ConnectorChain--  -- * Unrolling chains-  , unchain-  , unchainU-  , unchainZip-  , unchainZipWith-  , unconnectorChain--  -- * Building chains-  , liftChainF--  ) where--import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core------ | A 'PointChain' is a list of points. --- --- The list is typically inifinte so some attention must be given --- to choosing a chain drawing function and using it appropriately.--- -type PointChain u = [Point2 u]----- | A LocChain is a function from a starting point to a --- 'PointChain'.------ The list is often expected to be inifinte, but if it was a --- Stream it would loose the ability to use list comprehensions.--- -type LocChain u = LocDrawingInfo u (PointChain u)----- | A ConnectorChain is a function from a start- and end-point --- to a 'Chain'.--- -type ConnectorChain u = ConnectorCF u (PointChain u)------- | 'unchain' : @ unroll_count * alt_fun * draw_fun * chain -> LocCF @--- --- Unroll the chain, applying the @draw_fun@ to each point --- producing a LocCF (usually a 'LocGraphic'). If the chain does --- not produce any points the @alt_fun@ is applied to the start --- point.------ Note - commonly a 'Chain' may be infinite, so it is only --- unrolled a finite number of times - the @unrool_count@.------ This function has a very general type signature commonly it --- will be used at these types:------ > unchain :: (Num u, OPlus a) => --- >     Int -> LocImage u a -> LocImage u a -> LocChain u -> LocImage u a--- >--- > unchain :: Num u => --- >     Int -> LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u----unchain :: (Num u, OPlus a) -        => Int -        -> LocCF u (ImageAns u a) -        -> LocCF u (ImageAns u a) -        -> LocChain u -        -> LocCF u (ImageAns u a)-unchain i alt _  _   | i <= 0 = alt-unchain i alt gf chn          = promoteR1 $ \p0 -> -    (chn `at` p0) >>= \pts -> case pts of -      []     -> alt `at` p0-      [x]    -> gf  `at` x-      (x:xs) -> go x (take (i-1) xs)-  where-    go x []     = gf `at` x-    go x (y:ys) = (gf `at` x) `oplus` go y ys------- | 'unchain' : @ alt_fun * draw_fun * chain -> LocCF @--- --- /Unsafe/ version of 'unchain' - this function assumes the chain--- is finite which is not usually the case.------ This function has a very general type signature commonly it --- will be used at these type:------ > unchainU :: (Num u, OPlus a) => --- >     LocImage u a -> LocImage u a -> LocChain u -> LocImage u a--- >--- > unchainU :: Num u => --- >     LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u------ \*\* WARNING \*\* - if the chain is infinite this function will --- not terminate.----unchainU :: (Num u, OPlus a)-         => LocCF u (ImageAns u a) -         -> LocCF u (ImageAns u a) -         -> LocChain u -         -> LocCF u (ImageAns u a)-unchainU alt gf chn = promoteR1 $ \p0 -> -    (chn `at` p0) >>= \pts -> case pts of -      []     -> alt `at` p0-      [x]    -> gf  `at` x-      (x:xs) -> go x xs-  where-    go x []     = gf `at` x-    go x (y:ys) = (gf `at` x) `oplus` go y ys----- | 'unchainZip' : @ alt_fun * [draw_fun] * chain -> LocCF @--- --- Unroll the chain, zipping the list of @draw_funs@ to the list--- of points producing a LocCF (usually a 'LocGraphic'). If the --- chain does not produce any points the @alt_fun@ is applied to --- the start point.------ This function has a very general type signature commonly it --- will be used at these types:------ > unchainZip :: (Num u, OPlus a) => --- >     LocImage u a -> [LocImage u a] -> LocChain u -> LocImage u a--- >--- > unchainZip :: Num u => --- >     LocGraphic u -> [LocGraphic u] -> LocChain u -> LocGraphic u------ \*\* WARNING \*\* - the list of drawing functions should be --- finite. If both the list of drawing functions and the chain are --- infinite this function will not terminate.--- -unchainZip :: (Num u, OPlus a) -           => LocCF u (ImageAns u a) -           -> [LocCF u (ImageAns u a)] -           -> LocChain u -           -> LocCF u (ImageAns u a)-unchainZip alt []     _   = promoteR1 $ \p0 -> alt `at` p0-unchainZip alt  (g:gs) chn = promoteR1 $ \p0 -> -    (chn `at` p0) >>= \pts -> case pts of -      []     -> alt `at` p0-      [x]    -> g `at` x-      (x:xs) -> go (g `at` x) gs xs-  where-    go acc _      []     = acc-    go acc []     _      = acc-    go acc (f:fs) (p:ps) = go (acc `oplus` (f `at` p)) fs ps------ | 'unchainZipWith' : @ alt_fun * (a -> draw_fun) * [a] * chain -> LocCF @--- --- Version of 'unchainZip' where the list is some data rather --- than a drawing function and the @(a -> draw_fun)@ builder is --- applied to each element as part of the unrolling.--- --- Approximately this function is a @zipWith@ to the @zip@ of --- @unchainZip@.------ This function has a very general type signature commonly it --- will be used at these type:------ > unchainZipWith :: (Num u, OPlus a) => --- >     LocImage u a -> (s -> LocImage u a) -> [s] -> LocChain u -> LocImage u a--- >--- > unchainZipWith :: Num u => --- >     LocGraphic u -> (s -> LocGraphic u) -> [s] -> LocChain u -> LocGraphic u------ \*\* WARNING \*\* - if the chain and list are infinite this --- function will not terminate.----unchainZipWith :: (Num u, OPlus a)-                => LocCF u (ImageAns u a) -                -> (s -> LocCF u (ImageAns u a))-                -> [s]-                -> LocChain u -                -> LocCF u (ImageAns u a)-unchainZipWith alt _    []     _   = promoteR1 $ \p0 -> alt `at` p0-unchainZipWith alt mkGF (s:ss) chn = promoteR1 $ \p0 -> -    (chn `at` p0) >>= \pts -> case pts of -      []     -> alt `at` p0-      [x]    -> mkGF s `at` x-      (x:xs) -> go (mkGF s `at` x) ss xs-  where-    go acc _      []     = acc-    go acc []     _      = acc-    go acc (t:ts) (p:ps) = go (acc `oplus` (mkGF t `at` p)) ts ps------- | 'unconnectorChain' : @ alt_fun * draw_fun * conn_chain -> ConnectorCF @------ Unroll the chain produced between the implicit start and end --- points. Apply the @draw_fun@ to each point producing a --- ConnectorCF (usually a 'ConnectorGraphic'). If the chain does --- not produce any points, the @alt_fun@ is applied to the start --- and end points.------ This function has a very general type signature commonly it --- will be used at these types:------ > unconnectorChain :: (Num u, OPlus a) => --- >     ConnectorImage u a -> LocImage u a -> ConnectorChain u -> ConnectorImage u a--- >--- > unconnectorChain :: Num u => --- >     ConnectorGraphic u -> LocGraphic u -> ConnectorChain u -> ConnectorGraphic u-------unconnectorChain :: (Num u, OPlus a) -                 => ConnectorCF u (ImageAns u a) -                 -> LocCF u (ImageAns u a) -                 -> ConnectorChain u -                 -> ConnectorCF u (ImageAns u a)-unconnectorChain alt gf cchn = promoteR2 $ \p0 p1 -> -    (connect cchn p0 p1) >>= \pts -> case pts of-      []     -> connect alt p0 p1-      [x]    -> gf `at` x-      (x:xs) -> go (gf `at` x) xs-  where-    go acc []     = acc-    go acc (p:ps) = go (acc `oplus` (gf `at` p)) ps----------------------------------------------------------------------------------------- | 'liftChainF' : @ (point -> [point]) -> LocChain @------ Lift a pure chain generating function inot a 'LocChain'.----liftChainF :: (Point2 u -> PointChain u) -> LocChain u-liftChainF fn = promoteR1 $ \pt -> return $ fn pt-

@@ -1,155 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Chains.Derived--- Copyright   :  (c) Stephen Tetley 2010-2011--- 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-  (-    -    tableDown-  , tableRight--  , horizontalPoints-  , verticalPoints--  , horizontalSteps-  , verticalSteps--  , innerHorizontals-  , innerVerticals--  ) where--import Wumpus.Drawing.Chains.Base--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Core                              -- package: wumpus-core---import Data.List ------------------------------------------------------------------------------------- Tables---- Note - for the minor runtime cost, pairing the row_width and --- row_height should make the API more /memorable/...----- | 'tableDown' : @ num_rows * (row_width, row_height) -> LocChain @------ The table grows down and right, the implicit initial point is --- @top-left@.----tableDown :: Num u => Int -> (u,u) -> LocChain u-tableDown n (rw,rh) = liftChainF $ \pt -> map (fn pt) ints-  where-    ints    = iterate (+1) 0-    fn pt i = let (x,y) = i `divMod` n -              in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt----- | 'tableRight' : @ num_cols * row_width * row_height -> LocChain @------ The table grows right and down, the implicit initial point is --- @top-left@.------ This chain is infinite.----tableRight :: Num u => Int -> (u,u) -> LocChain u-tableRight n (rw,rh) = liftChainF $ \pt -> map (fn pt) ints-  where-    ints    = iterate (+1) 0-    fn pt i = let (y,x) = i `divMod` n -              in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt------ | 'horizontalPoints' : @ horizontal_dist -> LocChain @------ The chain grows right by the supplied increment.------ This chain is infinite.----horizontalPoints :: Num u => u -> LocChain u-horizontalPoints dx = liftChainF $ iterate (displaceH dx)----- | 'verticalPoints' : @ vertical_dist -> LocChain @------ The chain grows up by the supplied increment.------ This chain is infinite.----verticalPoints :: Num u => u -> LocChain u-verticalPoints dy = liftChainF $ iterate (displaceV dy)----- | 'horizontalSteps' : @ [horizontal_dist] -> LocChain @------ This is a @scanl@ successive displacing the start point.------ This chain is finite (for finite input list).----horizontalSteps :: Num u => [u] -> LocChain u-horizontalSteps xs = liftChainF $ \pt -> scanl (flip displaceH) pt xs ----- | 'verticalSteps' : @ [vertical_dist] -> LocChain @------ This is a @scanl@ successive displacing the start point.------ This chain is finite (for finite input list).------ \*\* WARNING \*\* - name due to be changed. Current name is --- too general for this function. ----verticalSteps :: Num u => [u] -> LocChain u-verticalSteps ys = liftChainF $ \pt -> scanl (flip displaceV) pt ys---{-# INLINE [0] ceilingi #-}-ceilingi :: RealFrac a => a -> Int-ceilingi = ceiling----- | Note - horizontals are projected from the start point. The --- horizontal component of the second point is ignored.--- --- This chain is finite for well formed input.----innerHorizontals :: RealFrac u => u -> ConnectorChain u-innerHorizontals n = promoteR2 $ \a b -> return $ body a b-  where-    body (P2 x0 y0) (P2 x1 _) = unfoldr phi (n * fromIntegral z) -      where z                 = ceilingi $ x0 / n-            phi x | x < x1    = Just (P2 x y0, x+n)-                  | otherwise = Nothing--      ---- | Note - verticals are projected from the start point. The --- vertical component of the second point is ignored.--- --- This chain is finite for well formed input.----innerVerticals :: RealFrac u => u -> ConnectorChain u-innerVerticals n = promoteR2 $ \a b -> return $ body a b-  where-    body (P2 x0 y0) (P2 _ y1) = unfoldr phi (n * fromIntegral z)-      where z                 = ceilingi $ y0 / n-            phi y | y < y1    = Just (P2 x0 y, y+n)-                  | otherwise = Nothing-

@@ -0,0 +1,31 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Shim module for Connectors.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors+  ( +    module Wumpus.Drawing.Connectors.Arrowheads+  , module Wumpus.Drawing.Connectors.Base+  , module Wumpus.Drawing.Connectors.BoxConnectors+  , module Wumpus.Drawing.Connectors.ConnectorPaths+  , module Wumpus.Drawing.Connectors.Loop++  ) where++import Wumpus.Drawing.Connectors.Arrowheads+import Wumpus.Drawing.Connectors.Base+import Wumpus.Drawing.Connectors.BoxConnectors+import Wumpus.Drawing.Connectors.ConnectorPaths+import Wumpus.Drawing.Connectors.Loop

@@ -0,0 +1,464 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.Arrowheads+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Arrowheads.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.Arrowheads+  (++    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++  , diamondWideTip+  , odiamondWideTip++  , curveTip+  , revcurveTip++  ) where+++import Wumpus.Drawing.Connectors.Base+import Wumpus.Drawing.Paths.Absolute++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Control.Applicative++++-- | Arrow tips are drawn with a sloid line even if the connector+-- line is dashed (tips also override round corners)++solid_stroke_tip :: DrawingContextF+solid_stroke_tip = reset_drawing_metrics+++type PointGen = Radian -> [Vec2 En]+++filledTipPath :: PointGen -> LocThetaGraphic En+filledTipPath fn = +    localize fill_use_stroke_colour $ promoteR2 $ \pt theta ->+      let vs = fn theta in vertexPP (map (pt .+^) vs) >>= filledPath+++closedTipPath :: PointGen -> LocThetaGraphic En+closedTipPath fn = +    localize solid_stroke_tip $ promoteR2 $ \pt theta ->+      let vs = fn theta in vertexPP (map (pt .+^) vs) >>= closedStroke+++openTipPath :: PointGen -> LocThetaGraphic En+openTipPath fn = +    localize solid_stroke_tip $ promoteR2 $ \pt theta ->+      let vs = fn theta in vertexPP (map (pt .+^) vs) >>= openStroke++++-- | Return @o-a@ and @o-b@:+--+-- >    a+-- >    .\+-- >    . \+-- >  .....o+-- >    . /+-- >    ./+-- >    b+--+tripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En))+tripointsFromTip baselen ang = \theta -> +    (avec (theta + au) hyp, avec (theta + ad) hyp)+  where+    half_ang  = 0.5 * ang +    au        = pi - half_ang+    ad        = half_ang + pi+    hyp       = baselen / (fromRadian $ cos half_ang)++++-- | Return @o-x@ and @o-a@ and @o-b@:+--+-- >       a+-- >      /.+-- >     / .+-- > .. x..o+-- >     \ .+-- >      \.+-- >       b+--+revTripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En, Vec2 En))+revTripointsFromTip baselen ang = \theta -> +    (avec theta (-baselen), oa theta, ob theta)+  where+    half_ang    = 0.5 * ang +    half_height = baselen * (fromRadian $ tan half_ang)+    oa          = \theta -> avec (theta + ang90) half_height+    ob          = \theta -> avec (theta - ang90) half_height+++++zeroVec :: Vec2 En+zeroVec = V2 0 0 ++ang90 :: Radian+ang90 = pi / 2++ang60 :: Radian+ang60 = pi / 3++ang45 :: Radian+ang45 = pi / 4+++len_one :: InterpretUnit u => Query u+len_one = uconvertCtx1 (1::En)++len_two :: InterpretUnit u => Query u+len_two = uconvertCtx1 (2::En)++len_half :: InterpretUnit u => Query u+len_half = uconvertCtx1 (0.5::En)++len_zero :: InterpretUnit u => Query u+len_zero = pure 0++retract_one :: InterpretUnit u => Query u+retract_one = uconvertCtx1 (1::En)++retract_two :: InterpretUnit u => Query u+retract_two = uconvertCtx1 (2::En)+++-- retract_half :: InterpretUnit u => Query u+-- retract_half = uconvertCtx1 (0.5::En)++retract_zero :: InterpretUnit u => Query u+retract_zero = pure 0++++filledTri :: InterpretUnit u => Radian -> ArrowTip u+filledTri ang = +    makeArrowTip retract_one len_one (filledTipPath spec)+  where+    spec theta = let (v1,v2) = tripointsFromTip 1 ang theta +                 in [zeroVec, v1, v2]+++tri90 :: InterpretUnit u => ArrowTip u+tri90 = filledTri ang90++tri60 :: InterpretUnit u => ArrowTip u+tri60 = filledTri ang60++tri45 :: InterpretUnit u => ArrowTip u+tri45 = filledTri ang45+++strokedClosedTri :: InterpretUnit u => Radian -> ArrowTip u+strokedClosedTri ang = +    makeArrowTip retract_one len_one (closedTipPath spec)+  where+    spec theta = let (v1,v2) = tripointsFromTip 1 ang theta +                 in [zeroVec, v1, v2]+++otri90 :: InterpretUnit u => ArrowTip u+otri90 = strokedClosedTri ang90++otri60 :: InterpretUnit u => ArrowTip u+otri60 = strokedClosedTri ang60++otri45 :: InterpretUnit u => ArrowTip u+otri45 = strokedClosedTri ang45+++filledRevTri :: InterpretUnit u => Radian -> ArrowTip u+filledRevTri ang = +    makeArrowTip retract_one len_one (filledTipPath spec)+  where+    spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta +                 in [v0, v1, v2]++revtri90 :: InterpretUnit u => ArrowTip u+revtri90 = filledRevTri ang90++revtri60 :: InterpretUnit u => ArrowTip u+revtri60 = filledRevTri ang60++revtri45 :: InterpretUnit u => ArrowTip u+revtri45 = filledRevTri ang45+++strokedClosedRevTri :: InterpretUnit u => Radian -> ArrowTip u+strokedClosedRevTri ang = +    makeArrowTip retract_one len_one (closedTipPath spec)+  where+    spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta +                 in [v0, v1, v2]+++orevtri90 :: InterpretUnit u => ArrowTip u+orevtri90 = strokedClosedRevTri ang90++orevtri60 :: InterpretUnit u => ArrowTip u+orevtri60 = strokedClosedRevTri ang60++orevtri45 :: InterpretUnit u => ArrowTip u+orevtri45 = strokedClosedRevTri ang45++++strokedBarb :: InterpretUnit u => Radian -> ArrowTip u+strokedBarb ang = +    makeArrowTip retract_zero len_one (openTipPath spec)+  where+    spec theta = let (v1,v2) = tripointsFromTip 1 ang theta +                 in [v1,zeroVec,v2]+++barb90 :: InterpretUnit u => ArrowTip u+barb90 = strokedBarb ang90++barb60 :: InterpretUnit u => ArrowTip u+barb60 = strokedBarb ang60++barb45 :: InterpretUnit u => ArrowTip u+barb45 = strokedBarb ang45+++strokedRevBarb :: InterpretUnit u => Radian -> ArrowTip u+strokedRevBarb ang = +    makeArrowTip retract_one len_one (openTipPath spec)+  where+    spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta +                 in [v1,v0,v2]++revbarb90 :: InterpretUnit u => ArrowTip u+revbarb90 = strokedRevBarb ang90++revbarb60 :: InterpretUnit u => ArrowTip u+revbarb60 = strokedRevBarb ang60++revbarb45 :: InterpretUnit u => ArrowTip u+revbarb45 = strokedRevBarb ang45++++perp :: InterpretUnit u => ArrowTip u+perp = +    makeArrowTip retract_zero len_zero (openTipPath spec)+  where+    spec theta = let oa = avec (theta + ang90) 0.5+                     ob = avec (theta - ang90) 0.5+                 in [oa, ob]+++bracket :: InterpretUnit u => ArrowTip u+bracket = +    makeArrowTip retract_zero len_half (openTipPath spec)+  where+    spec theta = let oa = avec (theta + ang90) 0.5+                     ob = avec (theta - ang90) 0.5+                     dv = avec theta (-0.5)+                 in [ oa ^+^ dv, oa, ob, ob ^+^ dv ]++++diskTip :: InterpretUnit u => ArrowTip u+diskTip = +    makeArrowTip retract_one len_one  +                 (promoteR2 $ \pt theta -> body theta `at` pt)+  where+    body :: Radian -> LocGraphic En+    body theta = let v1 = avec theta (-0.5)+                 in localize fill_use_stroke_colour $ +                      moveStart (displaceVec v1) (filledDisk 0.5)+++odiskTip :: InterpretUnit u => ArrowTip u+odiskTip = +    makeArrowTip retract_one len_one +                 (promoteR2 $ \pt theta -> body theta `at` pt)+  where+    body :: Radian -> LocGraphic En+    body theta = let v1 = avec theta (-0.5)+                 in localize solid_stroke_tip $ +                      moveStart (displaceVec v1) (strokedDisk 0.5)+++-- | squareSpec:+--+-- > +-- >    ,-----a+-- >    |     |+-- > ...v.....o+-- >    |     | +-- >    `-----b+--+squareSpec :: PointGen+squareSpec theta = [ oa ^+^ ov, oa, ob, ob ^+^ ov ]+  where+    oa = avec (theta + ang90) 0.5+    ob = avec (theta - ang90) 0.5+    ov = avec theta (-1)+    ++squareTip :: InterpretUnit u => ArrowTip u+squareTip = +    makeArrowTip retract_one len_one (filledTipPath squareSpec)++osquareTip :: InterpretUnit u => ArrowTip u+osquareTip = +    makeArrowTip retract_one len_one (closedTipPath squareSpec)++++-- | squareSpec:+--+-- > +-- >       a+-- >     /   \+-- > ...w..v..o+-- >     \   / +-- >       b+--+diamondSpec :: En -> PointGen+diamondSpec width theta = [ ow, oa, zeroVec, ob ]+  where+    ow = avec theta (-width)+    ov = avec theta (negate $ 0.5 * width)+    oa = ov ^+^ avec (theta + ang90) 0.5+    ob = ov ^+^ avec (theta - ang90) 0.5+++diamondTip :: InterpretUnit u => ArrowTip u+diamondTip = +    makeArrowTip retract_one len_one (filledTipPath $ diamondSpec 1)++odiamondTip :: InterpretUnit u => ArrowTip u+odiamondTip = +    makeArrowTip retract_one len_one (closedTipPath $ diamondSpec 1)+++diamondWideTip :: InterpretUnit u => ArrowTip u+diamondWideTip = +    makeArrowTip retract_two len_two (filledTipPath $ diamondSpec 2)++odiamondWideTip :: InterpretUnit u => ArrowTip u+odiamondWideTip = +    makeArrowTip retract_two len_two (closedTipPath $ diamondSpec 2)+++curveTipPath :: Point2 En -> Radian -> AbsPath En+curveTipPath pt theta = +    curve1 a b c pt `append` curve1 pt z y x+  where+    ow  = avec theta (-1)+    a   = pt .+^ ow ^+^ avec (theta + ang90) 0.5+    x   = pt .+^ ow ^+^ avec (theta - ang90) 0.5++    (c,b) = trapezoidFromBasePoints 0.125 0.5 pt a+    (y,z) = trapezoidFromBasePoints 0.125 0.5 x pt+++curveTip :: InterpretUnit u => ArrowTip u+curveTip = +    makeArrowTip retract_zero len_one+                 (promoteR2 $ \pt theta -> +                    localize (join_bevel . solid_stroke_tip) $ +                      toPrimPath (curveTipPath pt theta) >>= openStroke)++++curveTipRevPath :: Point2 En -> Radian -> AbsPath En+curveTipRevPath pt theta = +    curve1 a b c p2 `append` curve1 p2 z y x+  where+    p2  = pt .+^ avec theta (-1)+    a   = pt .+^ avec (theta + ang90) 0.5+    x   = pt .+^ avec (theta - ang90) 0.5++    (b,c) = trapezoidFromBasePoints 0.125 0.5 a p2+    (z,y) = trapezoidFromBasePoints 0.125 0.5 p2 x+++revcurveTip :: InterpretUnit u => ArrowTip u+revcurveTip = +    makeArrowTip retract_one len_one+                 (promoteR2 $ \pt theta -> +                    localize (join_bevel . solid_stroke_tip) $ +                      toPrimPath (curveTipRevPath pt theta) >>= openStroke)+++    +-- | 'trapezoidFromBasePoints' : +-- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @+--+-- Control points form an isosceles trapezoid.+--+-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@.+-- +trapezoidFromBasePoints :: (Real u, Floating u) +                        => u -> u -> Point2 u -> Point2 u +                        -> (Point2 u, Point2 u) +trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2)+  where+    base_vec  = pvec p1 p2+    base_len  = vlength base_vec+    theta     = vdirection base_vec+    half_ulen = 0.5 * ratio_to_base * base_len+    base_mid  = displaceParallel (0.5 * base_len) theta p1+    ubase_mid = displacePerpendicular u theta base_mid+    cp1       = displaceParallel (-half_ulen) theta ubase_mid+    cp2       = displaceParallel   half_ulen  theta ubase_mid

@@ -0,0 +1,172 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.Base+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Connectors...+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.Base+  ( ++    Connector    +  , ArrowConnector+  , ArrowTip+  , makeArrowTip++  , leftArrow+  , rightArrow  +  , leftRightArrow+  , uniformArrow  +  +  , promoteConn++  ) where++import Wumpus.Drawing.Paths.Absolute++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++import Control.Applicative+++-- | The type of Connectors - a query from start and end point to +-- a Path.+--+type Connector u = ConnectorQuery u (AbsPath u)++++type ArrowConnector u = ConnectorImage u (AbsPath u)++type TipDraw = Point2 En -> Radian -> GraphicAns En++-- | TipAns - retract_distance * tip length * TipDraw+--+type TipAns u = (u, u, TipDraw)+++data ArrowTip u = ArrowTip { getArrowTip :: CF (TipAns u) }+++++-- | Connector with an arrow tip at the start point (i.e left).+--+leftArrow :: (Real u, Floating u, InterpretUnit u) +          => ArrowTip u -> Connector u -> ArrowConnector u+leftArrow tipl conn = promoteR2 $ \p0 p1 ->+    apply2R2 conn p0 p1 >>= \full_path -> +    getArrowTip tipl    >>= \(dxl,wl,mkl) -> +    uconvertCtxF p0     >>= \emp0     ->       +    let angl            = tipDirectionL wl full_path+        short_path      = shortenL dxl full_path+        deco            = convertTipAns $ mkl emp0 angl+    in fmap (replaceAns full_path) $ +         decorateR0 deco $ toPrimPath short_path >>= openStroke++-- | Connector with an arrow tip at the end point (i.e right).+--+rightArrow :: (Real u, Floating u, InterpretUnit u) +           => ArrowTip u -> Connector u -> ArrowConnector u+rightArrow tipr conn = promoteR2 $ \p0 p1 ->+    apply2R2 conn p0 p1 >>= \full_path -> +    getArrowTip tipr    >>= \(dxr,wr,mkl) -> +    uconvertCtxF p1     >>= \emp1     ->       +    let angr            = tipDirectionR wr full_path+        short_path      = shortenR dxr full_path+        deco            = convertTipAns $ mkl emp1 angr+    in fmap (replaceAns full_path) $ +         decorateR0 deco $ toPrimPath short_path >>= openStroke+++-- | Connector with two arrow tips, possibly different.+--+leftRightArrow :: (Real u, Floating u, InterpretUnit u) +               => ArrowTip u -> ArrowTip u -> Connector u +               -> ArrowConnector u+leftRightArrow tipl tipr conn = promoteR2 $ \p0 p1 ->+    apply2R2 conn p0 p1 >>= \full_path -> +    getArrowTip tipl    >>= \(dxl,wl,mkl) -> +    getArrowTip tipr    >>= \(dxr,wr,mkr) -> +    uconvertCtxF p0     >>= \emp0     ->       +    uconvertCtxF p1     >>= \emp1     ->       +    let angl            = tipDirectionL wl full_path+        angr            = tipDirectionR wr full_path+        short_path      = shortenPath dxl dxr full_path+        deco            = convertTipAns $ mkl emp0 angl `oplus`  mkr emp1 angr  +    in fmap (replaceAns full_path) $ +         decorateR0 deco $ toPrimPath short_path >>= openStroke+++-- | Connector with the same arrow tip at both ends.+--+uniformArrow :: (Real u, Floating u, InterpretUnit u) +             => ArrowTip u -> Connector u -> ArrowConnector u+uniformArrow utip conn = leftRightArrow utip utip conn+++++convertTipAns :: InterpretUnit u => GraphicAns En -> Graphic u+convertTipAns = uconvImageF . pure ++-- | Helper - direction looks best at half the retract distance.+--+tipDirectionL :: (Real u, Floating u) => u -> AbsPath u -> Radian+tipDirectionL u absp | u <= 0   = directionL absp+                     |otherwise = directionL $ shortenL (0.5*u) absp+   +tipDirectionR :: (Real u, Floating u) => u -> AbsPath u -> Radian+tipDirectionR u absp | u <= 0   = directionR absp+                     |otherwise = directionR $ shortenR (0.5*u) absp+   +++makeArrowTip :: Query u -> Query u -> LocThetaGraphic En -> ArrowTip u+makeArrowTip retractq lengthq gf = ArrowTip body+  where+    body = drawingCtx >>= \ctx -> +           let rdist = runCF ctx retractq+               tlen  = runCF ctx lengthq+               drawf = runCF ctx gf+           in return (rdist,tlen,drawf)+++-- | Promote a function from source and dest points to a connector +-- function accounting for the separator values in the +-- DrawingContext.+--+-- This should be used instead of @promoteR2@ for functions +-- building connectors.+--+promoteConn :: (Real u, Floating u, InterpretUnit u) +            => (Point2 u -> Point2 u -> CF a) +            -> CF (Point2 u -> Point2 u -> a)+promoteConn fn = promoteR2 $ \p0 p1 -> +    connectorSrcSpace  >>= \sep0 ->+    connectorDstSpace  >>= \sep1 ->+    connectorSrcOffset >>= \off0 ->+    connectorDstOffset >>= \off1 ->+    let ang = vdirection $ pvec p0 p1+    in fn (displacePerpendicular off0 ang $ p0 .+^ avec ang sep0) +          (displacePerpendicular off1 ang $ p1 .-^ avec ang sep1)+   +--+-- CAUTION - promoteConn projects the spacers along the (straight)+-- connector line. This might not be what is wanted for jointed+-- connectors.+-- 

@@ -0,0 +1,65 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.BoxConnectors+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Box connectors+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.BoxConnectors+  ( +    ConnectorBox+  , connbox++  ) where++-- import Wumpus.Drawing.Paths.Absolute++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++-- NOTE - boxes (currently) seem to only support stroke otherwise+-- they would obliterate what they connect.++++-- | The type of BoxConnectors - a query from start and end point +-- to a Path. +-- +-- Note - unlike a @Connector@, a BoxConnnector is expected to be +-- closed, then filled, stroked or bordered.+--+type ConnectorBox u = ConnectorGraphic u+++--+-- DESIGN NOTE - boxes (probably) should not use source and dest+-- separators.+--+++-- | Draw a stroked, rectangular box around the connector points.+--+-- The rectangle will be inclined to the line.+--+connbox :: (Real u, Floating u, InterpretUnit u) +        => ConnectorBox u+connbox = promoteR2 $ \p0 p1 -> +    connectorSrcArm >>= \src_arm ->+    connectorDstArm >>= \dst_arm ->+    let ang = vdirection $ pvec p0 p1 +        bl  = displaceOrtho (V2 (-src_arm) (-src_arm)) ang p0+        tl  = displaceOrtho (V2 (-src_arm)   src_arm ) ang p0+        br  = displaceOrtho (V2   dst_arm  (-src_arm)) ang p1+        tr  = displaceOrtho (V2   dst_arm    src_arm ) ang p1+    in vertexPP [ bl, br, tr, tl ] >>= closedStroke

@@ -0,0 +1,499 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.ConnectorPaths+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Primitive connectors+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.ConnectorPaths+  ( ++    connline+  , connarc+  , connhdiagh+  , connvdiagv+  +  , conndiagh+  , conndiagv++  , connhdiag+  , connvdiag++  , connabar+  , connbbar++  , connaright+  , connbright++  , connhrr+  , connrrh+  , connvrr+  , connrrv++  , connaloop+  , connbloop++  , connhbezier+  , connvbezier++  ) where++import Wumpus.Drawing.Connectors.Base+import Wumpus.Drawing.Paths.Absolute++import Wumpus.Basic.Geometry.Quadrant           -- package: wumpus-basic+import Wumpus.Basic.Kernel hiding ( promoteR2 )++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++++++-- | Straight line connector.+--+connline :: (Real u, Floating u, InterpretUnit u) => Connector u+connline = promoteConn $ \p0 p1 -> return $ line1 p0 p1++++-- | Form an arc connector.+-- +-- If the conn_arc_angle in the Drawing context is positive the arc+-- will be formed /above/ the straight line joining the points. +-- If the angle is negative it will be drawn below. +-- +-- The notion of /above/ is respective to the line direction, of +-- course.+-- +--+connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) +        => Connector u+connarc = promoteConn $ \p0 p1 -> +    connectorArcAngle >>= \arc_ang ->+    let v1      = pvec p0 p1+        hlen    = 0.5 * vlength v1+        ang     = vdirection v1+        cp0     = p0 .+^ avec (ang + arc_ang) hlen+        cp1     = p1 .+^ avec (pi + ang - arc_ang) hlen+    in return $ curve1 p0 cp0 cp1 p1+++++-- | Horizontal-diagonal-horizontal connector.+--+-- >      --@+-- >     /+-- >  o--+-- +-- Horizontal /arms/ are drawn from the start and end points, a+-- diagonal segment joins the arms. +-- +connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)+          => Connector u+connhdiagh = promoteConn $ \p0 p1 -> +    connectorSrcArm >>= \src_arm ->+    connectorDstArm >>= \dst_arm ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> right p0 p1 src_arm dst_arm+      QUAD_SE -> right p0 p1 src_arm dst_arm+      _       -> left  p0 p1 src_arm dst_arm+  where+    right p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .+^ hvec h0+                                            , p1 .-^ hvec h1, p1 ]++    left  p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .-^ hvec h0 +                                            , p1 .+^ hvec h1, p1 ]++++-- | Vertical-diagonal-vertical connector.+--+-- >  @+-- >  |+-- >   \+-- >    |+-- >    o+--+-- Vertical /arms/ are drawn from the start and end points, a+-- diagonal segment joins the arms. +-- +connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)+          => Connector u+connvdiagv = promoteConn $ \p0 p1 -> +    connectorSrcArm >>= \src_arm ->+    connectorDstArm >>= \dst_arm ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> up   p0 p1 src_arm dst_arm+      QUAD_NW -> up   p0 p1 src_arm dst_arm+      _       -> down p0 p1 src_arm dst_arm+  where+    up   p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .+^ vvec v0+                                           , p1 .-^ vvec v1, p1 ]++    down p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .-^ vvec v0 +                                           , p1 .+^ vvec v1, p1 ]++++-- | Diagonal-horizontal connector.+--+-- >    --@+-- >   /+-- >  o+-- +-- Restricted variant of 'hconndiag' - a diagonal segment is drawn +-- from the start point joining a horizontal arm drawn from the +-- end point+-- +conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)+          => Connector u+conndiagh = promoteConn $ \p0 p1 -> +    connectorDstArm >>= \dst_arm ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> right p0 p1 dst_arm+      QUAD_SE -> right p0 p1 dst_arm+      _       -> left  p0 p1 dst_arm+  where+    right p0 p1 h1 = return $ vertexPath [ p0, p1 .-^ hvec h1, p1 ]++    left  p0 p1 h1 = return $ vertexPath [ p0, p1 .+^ hvec h1, p1 ]+++-- | Diagonal-vertical connector.+--+-- >    @+-- >    |+-- >   /+-- >  o+--+-- Restricted variant of 'vconndiag' - a diagonal segment is drawn +-- from the start point joining a vertical arm drawn from the end +-- point.+-- +conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)+          => Connector u+conndiagv = promoteConn $ \p0 p1 -> +    connectorDstArm >>= \dst_arm ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> up    p0 p1 dst_arm+      QUAD_NW -> up    p0 p1 dst_arm+      _       -> down  p0 p1 dst_arm+  where+    up   p0 p1 v1 = return $ vertexPath [ p0, p1 .-^ vvec v1, p1 ]++    down p0 p1 v1 = return $ vertexPath [ p0, p1 .+^ vvec v1, p1 ]++++-- | Horizontal-diagonal connector.+--+-- >      @+-- >     /+-- >  o--+--+-- Restricted variant of 'hconndiag' - a horizontal arm is drawn+-- from the start point joining a diagonal segment drawn from the +-- end point.+-- +connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)+          => Connector u+connhdiag = promoteConn $ \p0 p1 -> +    connectorSrcArm >>= \src_arm ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> right p0 p1 src_arm+      QUAD_SE -> right p0 p1 src_arm+      _       -> left  p0 p1 src_arm+  where+    right p0 p1 h1 = return $ vertexPath [ p0, p0 .+^ hvec h1, p1 ]++    left  p0 p1 h1 = return $ vertexPath [ p0, p0 .-^ hvec h1, p1 ]+++-- | Vertical-diagonal connector.+--+-- >    @+-- >   /+-- >  |+-- >  o+--+-- Restricted variant of 'vconndiag' - a horizontal arm is drawn+-- from the start point joining a vertical segment drawn from the +-- end point.+-- +connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)+          => Connector u+connvdiag = promoteConn $ \p0 p1 -> +    connectorSrcArm >>= \src_arm ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> up    p0 p1 src_arm+      QUAD_NW -> up    p0 p1 src_arm+      _       -> down  p0 p1 src_arm+  where+    up   p0 p1 v1 = return $ vertexPath [ p0, p0 .+^ vvec v1, p1 ]++    down p0 p1 v1 = return $ vertexPath [ p0, p0 .-^ vvec v1, p1 ]+++-- DESIGN NOTE - should the concept of /above/ and /below/ use +-- quadrants?+--+++-- | Bar connector.+--+-- >  ,----, +-- >  |    |+-- >  o    @  +--+-- The bar is drawn /above/ the points.+--+connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +         => Connector u+connabar = promoteConn $ \p0 p1 ->+    connectorSrcArm >>= \src_arm ->+    connectorDstArm >>= \dst_arm ->+    let ang = vdirection $ pvec p0 p1+    in return $ vertexPath [ p0, adisp_north src_arm ang p0+                           , adisp_north dst_arm ang p1, p1 ]+++-- | Bar connector.+-- +-- >  o    @ +-- >  |    |+-- >  '----'  +--+-- The bar is drawn /below/ the points.+--+connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +         => Connector u+connbbar = promoteConn $ \p0 p1 ->+    connectorSrcArm >>= \src_arm ->+    connectorDstArm >>= \dst_arm ->+    let ang = vdirection $ pvec p0 p1+    in return $ vertexPath [ p0, adisp_south src_arm ang p0+                           , adisp_south dst_arm ang p1, p1 ]++++-- | Right angle connector.+-- +-- >  ,----@ +-- >  | +-- >  o   +--+-- The bar is drawn /above/ the points.+--+connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) +           => Connector u+connaright = promoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->+    let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1]+++-- | Right angle connector.+-- +-- >       @ +-- >       |+-- >  o----'  +--+-- The bar is drawn /below/ the points.+--+connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u) +           => Connector u+connbright = promoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) ->+    let mid = P2 x1 y0 in return $ vertexPath [p0, mid, p1]++++-- Helper ++-- | Derive the direction aka. sign of an arm.+--+directional :: (Num u, Ord u) => u -> u -> u -> u+directional src dst arm = if  src < dst then arm else negate arm+                    +++-- | Connector with two horizontal segements and a joining +-- vertical segment.+--+-- >       ,--@+-- >       |+-- >  o----'  +--+-- The length of the first horizontal segment is the source arm +-- length. The length of the final segment is the remaing +-- horizontal distance. +--+connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) +        => Connector u+connhrr = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+    fmap (directional x0 x1) connectorSrcArm >>= \ src_arm -> +    let a0 = p0 .+^ hvec src_arm+        a1 = a0 .+^ vvec (y1 - y0)+    in return $ vertexPath [p0, a0, a1, p1]+++-- | Connector with two horizontal segements and a joining +-- vertical segment.+--+-- >     ,----@+-- >     |+-- >  o--'  +--+-- The length of the final horizontal segment is the distination +-- arm length. The length of the initial segment is the remaining+-- horizontal distance. +--+connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) +        => Connector u+connrrh = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+    fmap (directional x0 x1) connectorDstArm >>= \ dst_arm -> +    let a1 = p1 .-^ hvec dst_arm+        a0 = a1 .-^ vvec (y1 - y0)+    in return $ vertexPath [p0, a0, a1, p1]+++-- | Connector with two right angles...+--+-- >       @+-- >       |+-- >  ,----'+-- >  |+-- >  o  +--+connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) +        => Connector u+connvrr = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+    fmap (directional y0 y1) connectorSrcArm >>= \ src_arm -> +    let a0 = p0 .+^ vvec src_arm+        a1 = a0 .+^ hvec (x1 - x0)+    in return $ vertexPath [p0, a0, a1, p1]+++-- | Connector with two right angles...+--+-- >       @+-- >       |+-- >  ,----'+-- >  |+-- >  o  +--+connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) +        => Connector u+connrrv = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+    fmap (directional y0 y1) connectorDstArm >>= \ dst_arm -> +    let a1 = p1 .-^ vvec dst_arm+        a0 = a1 .-^ hvec (x1 - x0)+    in return $ vertexPath [p0, a0, a1, p1]+++++-- | Loop connector.+--+-- >  ,---------, +-- >  |         |+-- >  '-o    @--'+--+-- The loop is drawn /above/ the points.+--+connaloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) +          => Connector u+connaloop = loopbody id++-- | Loop connector.+--+-- >  ,-o    @--, +-- >  |         |+-- >  '---------'+--+-- The loop is drawn /above/ the points.+--+connbloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) +          => Connector u+connbloop = loopbody negate++-- | Looping just differs on a negate...+--+loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u)+         => (u -> u) -> Connector u+loopbody fn = promoteConn $ \p0 p1 ->+    connectorSrcArm   >>= \src_arm ->+    connectorDstArm   >>= \dst_arm ->+    connectorLoopSize >>= \loop_len ->+    let ang = vdirection $ pvec p0 p1 +        a0  = displaceParallel (negate src_arm) ang p0+        a1  = displacePerpendicular (fn loop_len) ang a0+        z0  = displaceParallel dst_arm ang p1+        z1  = displacePerpendicular (fn loop_len) ang z0+    in return $ vertexPath [ p0, a0, a1, z1, z0, p1 ]++-- | Bezier curve connector - the control points are positioned +-- horizontally respective to the source and dest.+--+-- >  *--@ +-- >    .  +-- >   . +-- >  o--*  +--+-- Note - the source and dest arm lengths are doubled, generally +-- this produces nicer curves.+--+connhbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)+            => Connector u+connhbezier = promoteConn $ \p0 p1 -> +    fmap (2*) connectorSrcArm   >>= \src_arm ->+    fmap (2*) connectorDstArm   >>= \dst_arm ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> right p0 p1 src_arm dst_arm+      QUAD_SE -> right p0 p1 src_arm dst_arm+      _       -> left  p0 p1 src_arm dst_arm+  where+    right p0 p1 h0 h1 = return $ curve1 p0 (p0 .+^ hvec h0) (p1 .-^ hvec h1) p1++    left  p0 p1 h0 h1 = return $ curve1 p0 (p0 .-^ hvec h0) (p1 .+^ hvec h1) p1+++-- | Bezier curve connector - the control points are positioned +-- vertically respective to the source and dest.+--+-- >        @ +-- >       .|  +-- >  *  .  *+-- >  |.+-- >  o+--+-- Note - the source and dest arm lengths are doubled, generally +-- this produces nicer curves.+--+connvbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)+            => Connector u+connvbezier = promoteConn $ \p0 p1 -> +    fmap (2*) connectorSrcArm   >>= \src_arm ->+    fmap (2*) connectorDstArm   >>= \dst_arm ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> up   p0 p1 src_arm dst_arm+      QUAD_NW -> up   p0 p1 src_arm dst_arm+      _       -> down p0 p1 src_arm dst_arm+  where+    up   p0 p1 v0 v1 = return $ curve1 p0 (p0 .+^ vvec v0) (p1 .-^ vvec v1) p1++    down p0 p1 v0 v1 = return $ curve1 p0 (p0 .-^ vvec v0) (p1 .+^ vvec v1) p1+++

@@ -0,0 +1,86 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.Loop+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Open loop for a circle (useful for automata diagrams).+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.Loop+  ( +    loop+  , loopPoints+  ) where+++import Wumpus.Drawing.Paths.Absolute++import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Kernel+import Wumpus.Core                              -- package: wumpus-core+++import Data.AffineSpace                         -- package: vector-space++++-- | Note this has problems vis adding tips as the actual start+-- and end points are synthesized.+--+loop :: (Real u, Floating u, InterpretUnit u, Tolerance u) +     => ConnectorQuery u (AbsPath u)+loop = promoteR2 $ \ctr radpt -> +   let incl    = lineDirection ctr radpt+       radius  = abs $ vlength $ pvec ctr radpt+       ps      = loopPoints radius ctr incl+   in return $ curvePath ps++-- | Note - intermediate names and quadrants represent a loop +-- drawn upwards.+-- +loopPoints :: (Real u, Floating u) => u -> Point2 u -> Radian -> [Point2 u]+loopPoints circ_radius circ_ctr incl = +    [ startl, cp1, cp2, kitel, cp3, cp4, top, cp5, cp6, kiter, cp7, cp8, startr ]+  where+    hw          = 1.25  * circ_radius+    height      = 3.8   * circ_radius+    hminor      = 2.72  * circ_radius+    hbase       = circ_radius / 3+    theta       = toRadian $ asin $ hbase / circ_radius+    start_vec   = avec (circularModulo $ incl - quarter_pi) (0.26 * circ_radius)+    end_vec     = avec (circularModulo $ incl + quarter_pi) (0.26 * circ_radius)    +    minor_down  = negate $ 0.8 * circ_radius +    major_up    = 0.52 * circ_radius+    top_right   = negate $ 0.8 * circ_radius+    top_left    = 0.8 * circ_radius++    top         = displaceParallel height incl circ_ctr+    kiter       = displaceOrtho (V2 hminor (-hw)) incl circ_ctr+    kitel       = displaceOrtho (V2 hminor (hw) ) incl circ_ctr+    +    startr      = circ_ctr .+^ avec (circularModulo $ incl - theta) circ_radius+    startl      = circ_ctr .+^ avec (circularModulo $ incl + theta) circ_radius++    -- quadrant III+    cp1         = startl .+^ end_vec +    cp2         = displaceParallel minor_down incl kitel++    -- quadrant II +    cp3         = displaceParallel major_up incl kitel+    cp4         = displacePerpendicular top_left incl top++    -- quadrant I+    cp5         = displacePerpendicular top_right incl top+    cp6         = displaceParallel major_up incl kiter++    -- quadrant IV +    cp7         = displaceParallel minor_down incl kiter+    cp8         = startr .+^ start_vec

@@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -58,9 +59,10 @@   import Wumpus.Drawing.Dots.Marks-import Wumpus.Drawing.Text.LRText+import Wumpus.Drawing.Text.Base.RotTextZero -import Wumpus.Basic.Geometry.Intersection       -- package: wumpus-basic+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Geometry.Intersection import Wumpus.Basic.Geometry.Paths import Wumpus.Basic.Geometry.Quadrant import Wumpus.Basic.Kernel               @@ -84,7 +86,6 @@                               , radial_anchor   :: Radian   -> Point2 u                               , cardinal_anchor :: Cardinal -> Point2 u } - type instance DUnit (DotAnchor u) = u  instance CenterAnchor (DotAnchor u) where@@ -153,7 +154,7 @@     fn theta =  displaceVec (rectRadialVector hw hh theta) ctr  -polygonAnchor :: (Real u, Floating u, FromPtSize u) +polygonAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u)                => [Point2 u] -> Point2 u -> DotAnchor u polygonAnchor ps ctr =      DotAnchor { center_anchor   = ctr@@ -172,7 +173,7 @@    in rectangleAnchor hw hh (bl .+^ vec hw hh)  rectangleLDO :: (Real u, Floating u) -             => u -> u -> LocDrawingInfo u (DotAnchor u)+             => u -> u -> LocQuery u (DotAnchor u) rectangleLDO w h =      promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt @@ -182,7 +183,7 @@                                  (\theta -> ctr .+^ (avec theta rad))                                  (radialCardinal rad ctr) -circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u)+circleLDO :: (Floating u, InterpretUnit u) => LocQuery u (DotAnchor u) circleLDO =      promoteR1 $ \pt ->        markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt@@ -191,8 +192,8 @@ -- This might be better taking a function: ctr -> poly_points -- ... ---polygonLDO :: (Real u, Floating u, FromPtSize u) -           => (u -> Point2 u -> [Point2 u]) -> LocDrawingInfo u (DotAnchor u)+polygonLDO :: (Real u, Floating u, InterpretUnit u, Tolerance u) +           => (u -> Point2 u -> [Point2 u]) -> LocQuery u (DotAnchor u) polygonLDO mk =      promoteR1 $ \ctr ->        markHeight >>= \h -> let ps = mk h ctr in pure $ polygonAnchor ps ctr@@ -201,11 +202,11 @@ --------------------------------------------------------------------------------  -type DotLocImage u = LocImage u (DotAnchor u) +type DotLocImage u = LocImage u (DotAnchor u)  type DDotLocImage = DotLocImage Double  -dotChar :: (Floating u, Real u, FromPtSize u) => Char -> DotLocImage u+dotChar :: (Floating u, Real u, InterpretUnit u) => Char -> DotLocImage u dotChar ch = dotText [ch]  @@ -216,73 +217,74 @@ --  -dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u -dotText ss = fmap (bimapL bboxRectAnchor) (textAlignCenter ss)+dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u +dotText ss = pushR1 (mapAns bboxRectAnchor) $ ccTextline ss  -- Note - maybe Wumpus-Basic should have a @swapAns@ function?  -dotHLine :: (Floating u, FromPtSize u) => DotLocImage u+dotHLine :: (Floating u, InterpretUnit u) => DotLocImage u dotHLine = intoLocImage circleLDO markHLine  -dotVLine :: (Floating u, FromPtSize u) => DotLocImage u+dotVLine :: (Floating u, InterpretUnit u) => DotLocImage u dotVLine = intoLocImage circleLDO markVLine  -dotX :: (Floating u, FromPtSize u) => DotLocImage u+dotX :: (Floating u, InterpretUnit u) => DotLocImage u dotX = intoLocImage circleLDO markX -dotPlus :: (Floating u, FromPtSize u) => DotLocImage u+dotPlus :: (Floating u, InterpretUnit u) => DotLocImage u dotPlus = intoLocImage circleLDO markPlus -dotCross :: (Floating u, FromPtSize u) => DotLocImage u+dotCross :: (Floating u, InterpretUnit u) => DotLocImage u dotCross = intoLocImage circleLDO markCross -dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u+dotDiamond :: (Floating u, InterpretUnit u) => DotLocImage u dotDiamond = intoLocImage circleLDO markDiamond -dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u+dotFDiamond :: (Floating u, InterpretUnit u) => DotLocImage u dotFDiamond = intoLocImage circleLDO markFDiamond   -dotDisk :: (Floating u, FromPtSize u) => DotLocImage u+dotDisk :: (Floating u, InterpretUnit u) => DotLocImage u dotDisk = intoLocImage circleLDO markDisk  -dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u+dotSquare :: (Floating u, Real u, InterpretUnit u) => DotLocImage u dotSquare = -    lift0R1 markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare+    markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare    -dotCircle :: (Floating u, FromPtSize u) => DotLocImage u+dotCircle :: (Floating u, InterpretUnit u) => DotLocImage u dotCircle = intoLocImage circleLDO markCircle  -dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u+dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u dotPentagon = intoLocImage circleLDO markPentagon -dotStar :: (Floating u, FromPtSize u) => DotLocImage u+dotStar :: (Floating u, InterpretUnit u) => DotLocImage u dotStar = intoLocImage circleLDO markStar  -dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u+dotAsterisk :: (Floating u, InterpretUnit u) => DotLocImage u dotAsterisk = intoLocImage circleLDO markAsterisk -dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u+dotOPlus :: (Floating u, InterpretUnit u) => DotLocImage u dotOPlus = intoLocImage circleLDO markOPlus -dotOCross :: (Floating u, FromPtSize u) => DotLocImage u+dotOCross :: (Floating u, InterpretUnit u) => DotLocImage u dotOCross = intoLocImage circleLDO markOCross -dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u+dotFOCross :: (Floating u, InterpretUnit u) => DotLocImage u dotFOCross = intoLocImage circleLDO markFOCross  -dotTriangle :: (Real u, Floating u, FromPtSize u) => DotLocImage u+dotTriangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +            => DotLocImage u dotTriangle = intoLocImage (polygonLDO fn) markTriangle   where      fn h ctr = let (bl,br,top) = equilateralTrianglePoints h ctr in [bl,br,top]

@@ -50,7 +50,7 @@   ) where  -import Wumpus.Drawing.Text.LRText+import Wumpus.Drawing.Text.Base.RotTextZero  import Wumpus.Basic.Geometry.Paths              -- package: wumpus-basic import Wumpus.Basic.Kernel        @@ -60,7 +60,6 @@ import Data.AffineSpace                         -- package: vector-space import Data.VectorSpace -import Control.Applicative  -- Marks should be the height of a lower-case letter... @@ -75,52 +74,52 @@  infixr 9 `renderPathWith` -renderPathWith :: LocDrawingInfo u (PrimPath u) -               -> (PrimPath u -> Graphic u) +renderPathWith :: LocQuery u PrimPath +               -> (PrimPath -> Graphic u)                 -> LocGraphic u-renderPathWith m k = m >>= (lift0R1 . k)+renderPathWith qy mk = promoteR1 $ \pt -> apply1R1 qy pt >>= mk   -markChar :: (Real u, Floating u, FromPtSize u) => Char -> LocGraphic u+markChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u markChar ch = markText [ch]    -markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u-markText ss = fmap (replaceL uNil) $ textAlignCenter ss+markText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u+markText ss = pushR1 ignoreAns $ ccTextline ss     -- | Supplied point is the center. ---axialLine :: Fractional u => Vec2 u -> LocGraphic u-axialLine v = moveStart (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)+axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u+axialLine v = moveStart (\ctr -> ctr .-^ (0.5 *^ v)) (locStraightLine v)  -markHLine :: (Fractional u, FromPtSize u) => LocGraphic u -markHLine = lift0R1 markHeight >>= \h -> axialLine (hvec h)+markHLine :: (Fractional u, InterpretUnit u) => LocGraphic u +markHLine = markHeight >>= \h -> axialLine (hvec h)  -markVLine :: (Fractional u, FromPtSize u) => LocGraphic u -markVLine = lift0R1 markHeight >>= \h -> axialLine (vvec h) +markVLine :: (Fractional u, InterpretUnit u) => LocGraphic u +markVLine = markHeight >>= \h -> axialLine (vvec h)   -markX :: (Fractional u, FromPtSize u) => LocGraphic u-markX = lift0R1 markHeight >>= mkX +markX :: (Fractional u, InterpretUnit u) => LocGraphic u+markX = markHeight >>= mkX    where     mkX h = let w = 0.75 * h               in axialLine (vec w h) `oplus` axialLine (vec (-w) h)   -markPlus :: (Fractional u, FromPtSize u) =>  LocGraphic u+markPlus :: (Fractional u, InterpretUnit u) =>  LocGraphic u markPlus = markVLine `oplus` markHLine  -markCross :: (Floating u, FromPtSize u) =>  LocGraphic u+markCross :: (Floating u, InterpretUnit u) =>  LocGraphic u markCross = markHeight >>= mkCross   where     mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (-ang) h)@@ -128,12 +127,11 @@  -- Note - height is extended slightly to look good... -pathDiamond :: (Fractional u, FromPtSize u) -            => LocDrawingInfo u (PrimPath u)-pathDiamond = -    promoteR1 $ \pt -> -      markHeight >>= \h -> let cp = diamondCoordPath (0.5*h) (0.66*h) -                           in return $ coordinatePrimPath pt cp+pathDiamond :: (Fractional u, InterpretUnit u) +            => LocQuery u PrimPath+pathDiamond = promoteR1 $ \pt -> +    markHeight >>= \h -> let cp = diamondCoordPath (0.5*h) (0.66*h) +                         in coordinatePrimPath cp pt   @@ -141,10 +139,10 @@ -- pathDiamond  :: (ctx -> pt -> a) -- ans          :: (ctx -> pt -> prim) -markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u markDiamond = pathDiamond `renderPathWith` closedStroke -markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u markFDiamond = pathDiamond `renderPathWith` filledPath  @@ -155,60 +153,60 @@ -- A named combinator might be better. -- -markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u markBDiamond = pathDiamond `renderPathWith` borderedPath   -- | Note disk is filled. ---markDisk :: (Fractional u, FromPtSize u) => LocGraphic u-markDisk = lift0R1 markHalfHeight >>= filledDisk +markDisk :: (Fractional u, InterpretUnit u) => LocGraphic u+markDisk = markHalfHeight >>= filledDisk   -markSquare :: (Fractional u, FromPtSize u) => LocGraphic u+markSquare :: (Fractional u, InterpretUnit u) => LocGraphic u markSquare = -    lift0R1 markHeight >>= \h -> +    markHeight >>= \h ->      let d = 0.5*(-h) in moveStart (displace d d) $ strokedRectangle h h       -markCircle :: (Fractional u, FromPtSize u) => LocGraphic u-markCircle = lift0R1 markHalfHeight >>= strokedDisk +markCircle :: (Fractional u, InterpretUnit u) => LocGraphic u+markCircle = markHalfHeight >>= strokedDisk  -markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u-markBCircle = lift0R1 markHalfHeight >>= borderedDisk +markBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u+markBCircle = markHalfHeight >>= borderedDisk    -markPentagon :: (Floating u, FromPtSize u) => LocGraphic u-markPentagon = -    promoteR1 $ \pt -> -      markHeight >>= \h -> closedStroke $ pentagonPath pt (0.5*h)+markPentagon :: (Floating u, InterpretUnit u) => LocGraphic u+markPentagon = promoteR1 $ \pt -> +    pentagonPath pt >>= closedStroke   where-    pentagonPath pt hh = coordinatePrimPath pt $ polygonCoordPath 5 hh+    pentagonPath pt = markHalfHeight >>= \hh -> +                      coordinatePrimPath (polygonCoordPath 5 hh) pt     -markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar = lift0R1 markHeight >>= \h -> starLines (0.5*h)+markStar :: (Floating u, InterpretUnit u) => LocGraphic u +markStar = markHeight >>= \h -> starLines (0.5*h) -starLines :: Floating u => u -> LocGraphic u-starLines hh = -    promoteR1 $ \ctr -> let cp = polygonCoordPath 5 hh-                        in step $ map (fn ctr) $ cp ctr+starLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u+starLines hh = promoteR1 $ \ctr -> +    let cp = polygonCoordPath 5 hh+    in step $ map (fn ctr) $ cp ctr   where-    fn p0 p1    = openStroke $ primPath p0 [lineTo p1]+    fn p0 p1    = straightLine p0 p1     step (x:xs) = oconcat x xs     step _      = error "starLines - unreachable"  -markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u-markAsterisk = lift0R1 markHeight >>= asteriskLines+markAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u+markAsterisk = markHeight >>= asteriskLines -asteriskLines :: Floating u => u -> LocGraphic u+asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3   where     ang     = (pi*2) / 6@@ -217,27 +215,28 @@     lineF3  = axialLine (avec ((pi*0.5) + ang + ang) h)  -markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u+markOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u markOPlus = markCircle `oplus` markPlus  -markOCross :: (Floating u, FromPtSize u) => LocGraphic u+markOCross :: (Floating u, InterpretUnit u) => LocGraphic u markOCross = markCircle `oplus` markCross  -markFOCross :: (Floating u, FromPtSize u) => LocGraphic u+markFOCross :: (Floating u, InterpretUnit u) => LocGraphic u markFOCross = markCross `oplus` markBCircle   --- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u+-- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u -- bkCircle = disk (fillAttr attr) (0.5*markHeight attr)    -markTriangle :: (Floating u, FromPtSize u) => LocGraphic u+markTriangle :: (Floating u, InterpretUnit u) => LocGraphic u markTriangle = tripath `renderPathWith` closedStroke   where     tripath = promoteR1 $ \pt -> -                markHeight >>= \h -> let cp = equilateralTriangleCoordPath h -                                     in pure $ coordinatePrimPath pt cp+                markHeight >>= \h -> +                  let cp = equilateralTriangleCoordPath h+                  in coordinatePrimPath cp pt 

@@ -0,0 +1,49 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Axes+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Drawing grids+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Axes+  ( +   +    orthontAxes++  ) where++import Wumpus.Drawing.Connectors++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Core                              -- package: wumpus-core+++-- Note - axes need labels working out...+++-- | Draw axes from (0,0).+--+orthontAxes :: (Real u, Floating u, InterpretUnit u)+            => (Double, Double) -> Graphic u+orthontAxes (w,h) = +    snapmove (1,1) >>= \(V2 w1 h1) ->+    let conn1 = rightArrow barb45 connline+        uw    = w1 * realToFrac w+        uh    = h1 * realToFrac h+        ptX   = displaceH uw zeroPt+        ptY   = displaceV uh zeroPt+    in  localize cap_square $         graphic_ (connect conn1 zeroPt ptX) +                              `oplus` graphic_ (connect conn1 zeroPt ptY)+++    +    

@@ -0,0 +1,229 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Grids+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Drawing grids+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Grids+  ( +   +    GridContextF+  , grid+  , standard_grid+  , grid_major_colour+  , grid_major_line_width+  , grid_major_dotnum+  , grid_minor_subdivisions+  , grid_minor_colour+  , grid_minor_line_width+  , grid_minor_dotnum+  , grid_point_size+  , grid_label_colour++  ) where+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Colour ( black )+++++type GridContextF = GridProps -> GridProps++-- | GridProps control the drawing of grids.+-- +data GridProps = GridProps+      { gp_major_colour   :: RGBi+      , gp_major_lnwidth  :: Double+      , gp_major_dotnum   :: Int+      , gp_minor_subdivs  :: Int+      , gp_minor_colour   :: RGBi+      , gp_minor_lnwidth  :: Double+      , gp_minor_dotnum   :: Int+      , gp_point_size     :: FontSize+      , gp_label_colour   :: RGBi+      }++default_grid_props :: GridProps+default_grid_props = +    GridProps { gp_major_colour     = grey1+              , gp_major_lnwidth    = 1+              , gp_major_dotnum     = 0+              , gp_minor_subdivs    = 5+              , gp_minor_colour     = grey2+              , gp_minor_lnwidth    = 0.5+              , gp_minor_dotnum     = 0+              , gp_point_size       = 10+              , gp_label_colour     = black+              }+  where+    grey1 = RGBi 100 100 100+    grey2 = RGBi 150 150 150 ++++grid :: (Fractional u, InterpretUnit u) +     => GridContextF -> (Int,Int) -> (Int,Int) -> Graphic u  +grid upd bl tr = go (upd default_grid_props)+  where+    go props | gp_minor_subdivs props < 1 = gridMajor bl tr props+             | otherwise = gridMinor bl tr props `oplus` gridMajor bl tr props++++standard_grid :: GridContextF+standard_grid = id++grid_major_colour :: RGBi -> GridContextF+grid_major_colour rgb = (\s -> s { gp_major_colour = rgb })++grid_major_line_width :: Double -> GridContextF+grid_major_line_width lw = (\s -> s { gp_major_lnwidth = lw })++grid_major_dotnum :: Int -> GridContextF+grid_major_dotnum n = (\s -> s { gp_major_dotnum = n })++grid_minor_subdivisions :: Int -> GridContextF+grid_minor_subdivisions n = (\s -> s { gp_major_dotnum = n })++grid_minor_colour :: RGBi -> GridContextF+grid_minor_colour rgb = (\s -> s { gp_minor_colour = rgb })++grid_minor_line_width :: Double -> GridContextF+grid_minor_line_width lw = (\s -> s { gp_minor_lnwidth = lw })++grid_minor_dotnum :: Int -> GridContextF+grid_minor_dotnum n = (\s -> s { gp_minor_dotnum = n })+++grid_point_size :: FontSize -> GridContextF+grid_point_size i = (\s -> s { gp_point_size = i })+++grid_label_colour :: RGBi -> GridContextF+grid_label_colour rgb = (\s -> s { gp_label_colour = rgb })++++--------------------------------------------------------------------------------++++gridMinor :: (Fractional u, InterpretUnit u) +          => (Int,Int) -> (Int,Int) -> GridProps -> Graphic u+gridMinor bl tr props = +    let mi    = minorInterior bl tr (gp_minor_subdivs props)+        minF  = lineProps (gp_minor_colour props) (gp_minor_lnwidth props)+                          (gp_minor_dotnum props)+    in localize minF mi++gridMajor :: (Fractional u, InterpretUnit u) +          => (Int,Int) -> (Int,Int) -> GridProps -> Graphic u+gridMajor bl tr props = +    let mj    = majorInterior bl tr+        outer = outerRect bl tr+        majF  = lineProps (gp_major_colour props) (gp_major_lnwidth props)+                          (gp_major_dotnum props)        +    in localize majF (mj `oplus` outer)+++++lineProps :: RGBi -> Double -> Int -> DrawingContextF+lineProps rgb lw n +    | n < 1     = stroke_colour rgb . set_line_width lw . solid_line +    | otherwise = stroke_colour rgb . set_line_width lw . dashesF +  where+    dashesF = set_dash_pattern $ Dash 0 [(1,n)]+++-- | Coordinates are expected to be normalized.+--+outerRect :: (Fractional u, InterpretUnit u) +          => (Int,Int) -> (Int,Int) -> Graphic u  +outerRect cbl@(xmin,ymin) (xmaj,ymaj) = +    snapmove (xmaj-xmin, ymaj-ymin) >>= \(V2 uw uh) ->+    position cbl                    >>= \bl ->+    strokedRectangle uw uh `at` bl++++-- | The major interior is the snap grid. +--+majorInterior :: (Fractional u, InterpretUnit u)+              => (Int,Int) -> (Int,Int) -> Graphic u+majorInterior cbl@(xmin,ymin) (xmaj,ymaj) = +    snapmove (xmaj-xmin, ymaj-ymin) >>= \(V2 uw uh) ->+    snapmove (1,1)                  >>= \(V2 w1 h1) ->+    position cbl                    >>= \bl ->+    let xcount = sub1 (xmaj - xmin)+        ycount = sub1 (ymaj - ymin)+        hlines = chainlike ycount (displaceV h1) (hline uw)+        vlines = chainlike xcount (displaceH w1) (vline uh)+    in         (apply1R1 hlines $ displaceV h1 bl)  +       `oplus` (apply1R1 vlines $ displaceH w1 bl) +++++-- | The minor interior divides each element of the snap grid.+--+minorInterior :: (Fractional u, InterpretUnit u)+              => (Int,Int) -> (Int,Int) -> Int -> Graphic u+minorInterior cbl@(xmin,ymin) (xmaj,ymaj) scount = +    snapmove (xmaj-xmin, ymaj-ymin) >>= \(V2 uw uh) ->+    snapmove (1,1)                  >>= \(V2 w1 h1) ->+    position cbl                    >>= \bl ->+    let xcount = xmaj - xmin+        ycount = ymaj - ymin+        subw1    = w1 / fromIntegral scount+        subh1    = h1 / fromIntegral scount+        hlines1 = moveStart (displaceV subh1) +                    $ chainlike (scount-1) (displaceV subh1) (hline uw)++        vlines1 = moveStart (displaceH subw1) +                    $ chainlike (scount-1) (displaceH subw1) (vline uh)+        hlines  = chainlike ycount (displaceV h1) hlines1+        vlines  = chainlike xcount (displaceH w1) vlines1++    in         (apply1R1 hlines bl)  +       `oplus` (apply1R1 vlines bl) ++-- This doesn\'t work as an advGraphic+++-- | This is an operation chain should support, but chain needs a +-- rethink...+--+chainlike :: Int -> PointDisplace u -> LocGraphic u -> LocGraphic u+chainlike i mv g = promoteR1 $ \start -> go (i-1) (g `at` start) (mv start)+  where+    go n acc pt | n < 1     = acc+                | otherwise = go (n-1) (acc `oplus` (g `at` pt)) (mv pt)+    +++vline :: InterpretUnit u => u -> LocGraphic u +vline len = locStraightLine $ vvec len++hline :: InterpretUnit u => u -> LocGraphic u +hline len = locStraightLine $ hvec len++++sub1 :: Num u => u -> u+sub1 = subtract 1++

@@ -0,0 +1,91 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Turtle.TurtleClass+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Turtle monad and monad transformer.+--+-- The Turtle monad embodies the LOGO style of imperative +-- drawing - sending commands to update the a cursor.+--+-- While Wumpus generally aims for a more compositional,+-- \"coordinate-free\" style of drawing, some types of diagram +-- are more easily expressed in the LOGO style.+--+-- Note - as turtle drawing with Wumpus is a /local effect/, +-- there is only one instance of TurtleM. Potentially TurtleM +-- will be removed and the functions implemented directly. +--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Turtle.TurtleClass+  (++    Coord++  , TurtleM(..)++  , setsLoc+  , setsLoc_++  -- * movement+  , resetLoc+  , moveLeft+  , moveRight+  , moveUp+  , moveDown+  , nextLine+ ++  ) where++++type Coord = (Int,Int)+++class Monad m => TurtleM m where+  getLoc     :: m (Int,Int)+  setLoc     :: (Int,Int) -> m ()+  getOrigin  :: m (Int,Int)+  setOrigin  :: (Int,Int) -> m ()++++setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a+setsLoc f = getLoc      >>= \coord -> +            let (a,coord') = f coord in setLoc coord' >> return a++setsLoc_ :: TurtleM m => (Coord -> Coord) -> m ()+setsLoc_ f = getLoc     >>= \coord ->  setLoc (f coord)+++resetLoc    :: TurtleM m => m ()+resetLoc    = getOrigin >>= setLoc+++moveRight   :: TurtleM m => m ()+moveRight   = setsLoc_ $ \(x,y)-> (x+1, y)+++moveLeft    :: TurtleM m => m ()+moveLeft    = setsLoc_ $ \(x,y) -> (x-1,y)++moveUp      :: TurtleM m => m ()+moveUp      = setsLoc_ $ \(x,y) -> (x,y+1)++moveDown    :: TurtleM m => m ()+moveDown    = setsLoc_ $ \(x,y) -> (x ,y-1)+++nextLine    :: TurtleM m => m ()+nextLine    = getOrigin >>= \(ox,_) ->+              setsLoc_ $ \(_,y) -> (ox,y-1)+

@@ -0,0 +1,132 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Turtle.TurtleMonad+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Turtle monad transformer.+--+-- The Turtle monad embodies the LOGO style of imperative +-- drawing - sending commands to update the a cursor.+--+-- While Wumpus generally aims for a more compositional,+-- \"coordinate-free\" style of drawing, some types of +-- diagram are more easily expressed in the LOGO style.+--+-- Turtle is only a transformer - it is intended to be run within+-- a 'Drawing'.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Turtle.TurtleMonad+  (+    -- * Re-exports+    module Wumpus.Drawing.Extras.Turtle.TurtleClass++  -- * Turtle transformer+  , TurtleT+  , runTurtleT++   +  ) where++import Wumpus.Drawing.Extras.Turtle.TurtleClass++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+++import Control.Applicative+import Control.Monad+++-- Note - if Turtle is now just a /local effect/ monad is the +-- Turtle class still needed? Afterall, there is (probably)+-- only ever going to be one instance.+--++-- Turtle is a Reader / State monad+-- +-- The env is the horizontal and vertical move distances.+-- +-- The state is the current coordinate and the origin.+--++data TurtleState = TurtleState +      { _turtle_origin   :: (Int,Int)+      , _current_coord   :: (Int,Int)+      }++newtype TurtleT u m a = TurtleT { +          getTurtleT :: TurtleState -> m (a, TurtleState) }++    +type instance MonUnit (TurtleT u m a) = u++-- Functor++++instance Monad m => Functor (TurtleT u m) where+  fmap f m = TurtleT $ \s -> getTurtleT m s >>= \(a,s') ->+                             return (f a, s')+++-- Applicative ++instance Monad m => Applicative (TurtleT u m) where+  pure a    = TurtleT $ \s -> return (a,s)+  mf <*> ma = TurtleT $ \s -> getTurtleT mf s  >>= \(f,s')  ->+                              getTurtleT ma s' >>= \(a,s'') ->+                              return (f a,s'') +++-- Monad ++instance Monad m => Monad (TurtleT u m) where+  return a = TurtleT $ \s -> return (a,s)+  m >>= k  = TurtleT $ \s -> getTurtleT m s   >>= \(a,s')  ->+                             (getTurtleT . k) a s'+++++instance Monad m => TurtleM (TurtleT u m) where+  getLoc      = TurtleT $ \s@(TurtleState _ c) -> return (c,s)+  setLoc c    = TurtleT $ \(TurtleState o _)   -> return ((),TurtleState o c)+  getOrigin   = TurtleT $ \s@(TurtleState o _) -> return (o,s)+  setOrigin o = TurtleT $ \(TurtleState _ c)   -> return ((),TurtleState o c)+++runTurtleT :: (Monad m, Num u) +           => (Int,Int) -> TurtleT u m a -> m a+runTurtleT ogin mf = getTurtleT mf st0 >>= \(a,_) -> return a+  where +    st0 = TurtleState ogin ogin ++++----------------------------------------------------------------------------------+-- Cross instances++instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where+  askDC           = TurtleT $ \s -> askDC >>= \ ctx -> return (ctx,s)+  localize upd mf = TurtleT $ \s -> localize upd (getTurtleT mf s)+++-- This needs undecidable instances...++instance (Monad m, TraceM m, u ~ MonUnit (m ()) ) => TraceM (TurtleT u m) where+  trace a      = TurtleT $ \s -> trace a >> return ((),s)+  fontDelta mf = TurtleT $ \s -> fontDelta $ getTurtleT mf s++

@@ -1,67 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Grids--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Drawing grids--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Grids-  ( -    grid-  , interiorGrid--  ) where--import Wumpus.Drawing.Chains--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Core                              -- package: wumpus-core----grid :: Fractional u => (Int,Int) -> u -> LocGraphic u-grid (nx,ny) incr    -    | nx < 1 || ny < 1 = emptyLocGraphic-    | otherwise        = promoteR1 $ \sw -> -        let rw      = incr * fromIntegral nx-            rh      = incr * fromIntegral ny-            xchn    = horizontalPoints incr-            ychn    = verticalPoints incr-            vline1  = straightLine (vvec rh)-            hline1  = straightLine (hvec rw)-            vlines  = unchain nx emptyLocGraphic vline1 xchn-            hlines  = unchain ny emptyLocGraphic hline1  ychn-        in (hlines `oplus` vlines `oplus` strokedRectangle rw rh) `at` sw------ | 'interiorGrid' : @ increment -> ConnectorGraphic @------ Draw the interior lines of a grid between the /connector/ --- points - start point is interpreted as bottom-left, end-point--- is interpreted as top right.------ The interior lines are calculated with repsect to the 0 and the --- increment, for instance with an increment of 10 but a start --- point @(15,0)@ lines are drawn from @(20,0), (30,0)@ etc.----interiorGrid :: RealFrac u => u -> ConnectorGraphic u-interiorGrid incr = promoteR2 $ \sw ne ->-    let xcc         = innerHorizontals incr-        ycc         = innerVerticals   incr-        (V2 vx vy)  = pvec sw ne-        hline1      = straightLine (hvec vx)-        vline1      = straightLine (vvec vy)-        vlines      = unconnectorChain emptyConnectorGraphic vline1 xcc-        hlines      = unconnectorChain emptyConnectorGraphic hline1 ycc-    in connect (hlines `oplus` vlines) sw ne-

@@ -1,32 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Shim import module for Paths.------ Note MonadicConstruction is not exported, this module is --- somewhat out-of-date and needs a re-think.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths -  ( --    module Wumpus.Drawing.Paths.Base-  , module Wumpus.Drawing.Paths.Connectors-  , module Wumpus.Drawing.Paths.ControlPoints--  ) where--import Wumpus.Drawing.Paths.Base-import Wumpus.Drawing.Paths.Connectors-import Wumpus.Drawing.Paths.ControlPoints-

@@ -0,0 +1,28 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.Abolute+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Shim import module for the Absolute Path modules.+--+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.Absolute+  ( ++    module Wumpus.Drawing.Paths.Base.AbsBuilder+  , module Wumpus.Drawing.Paths.Base.AbsPath++  ) where++import Wumpus.Drawing.Paths.Base.AbsBuilder+import Wumpus.Drawing.Paths.Base.AbsPath+

@@ -1,585 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths.Base--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Extended path type - more amenable for complex drawings than--- the type in Wumpus-Core.------ \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths.Base-  ( --    Path-  , DPath-  , length-  , append-  , pconcat-  , line-  , curve-  , pivot-  , traceLinePoints-  , traceCurvePoints-  , curveByAngles--  , toPrimPath --  , tipL-  , tipR--  , shortenPath-  , shortenL-  , shortenR-  , directionL-  , directionR--  , midway-  , midway_-  , atstart-  , atstart_-  , atend-  , atend_--  , PathViewL(..)-  , DPathViewL-  , PathViewR(..)-  , DPathViewR-  , PathSegment(..)-  , DPathSegment-  , pathViewL-  , pathViewR---  , roundTrail-  , roundInterior--  ) where----import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic-import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl-                                   , ViewR(..), viewr, cons, snoc, join )-import qualified Wumpus.Basic.Utils.JoinList as JL--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace--import Data.List ( foldl' ) --import Prelude hiding ( length )--data Path u = Path { _path_length   :: u -                   , _path_start    :: Point2 u-                   , _path_elements :: JoinList (PathSeg u)-                   , _path_end      :: Point2 u-                   }-  deriving (Eq,Show)--type DPath = Path Double---- Annotating each segment with length is \*\* good \*\*.--- Makes it much more efficient to find the midway point.------ But what do we do about the start point:------ a) put it in the segment - too much info in the type, allows --- consistency problems vis-a-vis gaps in the path.------ b) leave it out - too little info in the type, allows --- consistency problems with length.------ Option (a) is probably most convenient espcially as the --- constructors won\'t be exported.---- Annotation is length...--- -data PathSeg u = LineSeg  { _line_length  :: u -                          , _line_start   :: Point2 u-                          , _line_end     :: Point2 u-                          }-               | CurveSeg { _curve_length :: u -                          , _curve_start  :: Point2 u-                          , _ctrl_pt_one  :: Point2 u-                          , _ctrl_pt_two  :: Point2 u-                          , _curve_end    :: Point2 u-                          }-  deriving (Eq,Show)---type instance DUnit (Path u)    = u-type instance DUnit (PathSeg u) = u---infixr 1 `append`--length :: Num u => Path u -> u-length (Path u _ _ _) = u--append :: Floating u => Path u -> Path u -> Path u-append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2) -    | end1 == start2 = Path (len1+len2) start1 (se1 `join` se2) end2 -    | otherwise      = let joint     = lineSegment end1 start2-                           total_len = len1 + len2 + segmentLength joint-                       in Path total_len start1 (se1 `join` (cons joint se2)) end2 ---- CAUTION - @append@ is using Floating Point equality to see if--- points are equal...---pconcat :: Floating u => Path u -> [Path u] -> Path u-pconcat p0 ps = foldl' append p0 ps--segmentLength :: PathSeg u -> u-segmentLength (LineSeg u _ _)       = u-segmentLength (CurveSeg u _ _ _ _)  = u---segmentStart :: PathSeg u -> Point2 u-segmentStart (LineSeg  _ p0 _)      = p0-segmentStart (CurveSeg _ p0 _ _ _)  = p0--segmentEnd :: PathSeg u -> Point2 u-segmentEnd (LineSeg  _ _ p1)        = p1-segmentEnd (CurveSeg _ _ _ _ p3)    = p3-----lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u -lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1---pathZero :: Floating u => Point2 u -> Path u -pathZero p0 = Path 0 p0 JL.empty p0-   --line :: Floating u => Point2 u -> Point2 u -> Path u -line p0 p1 = let v = vlength $ pvec p0 p1 -             in Path v p0 (JL.one $ LineSeg v p0 p1) p1-   --curve :: (Floating u, Ord u, FromPtSize u)-      => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u -curve p0 p1 p2 p3 = let v = bezierLength (BezierCurve p0 p1 p2 p3)-                    in Path v p0 (JL.one $ CurveSeg v p0 p1 p2 p3) p3---- | A draw a /straight line/ of length 0 at the supplied point. ------ This is /might/ be useful in concatenating curved paths--- as it introduces and extra control point.--- -pivot :: Floating u => Point2 u -> Path u -pivot p0 = Path 0 p0 (JL.one $ LineSeg 0 p0 p0) p0----- | 'traceLinePoints' throws a runtime error if the supplied list--- is empty. ----traceLinePoints :: Floating u => [Point2 u] -> Path u-traceLinePoints []       = error "traceLinePoints - empty point list."-traceLinePoints [a]      = line a a-traceLinePoints (a:b:xs) = step (line a b) b xs-  where-    step acc _ []     = acc-    step acc e (y:ys) = step (acc `append` line e y) y ys----- | 'traceCurvePoints' consumes 4 points from the list on the --- intial step (start, control1, control2, end) then steps --- through the list taking 3 points at a time thereafter--- (control1,control2, end). Leftover points are discarded.    --- --- 'traceCurvePoints' throws a runtime error if the supplied list--- is has less than 4 elements (start, control1, control2, end). ----traceCurvePoints :: (Floating u, Ord u, FromPtSize u) -                 => [Point2 u] -> Path u-traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs-  where-    step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs-    step acc _  _          = acc--traceCurvePoints _            = error "tracePointsCurve - less than 4 elems."---curveByAngles :: (Floating u, Ord u, FromPtSize u) -              => Point2 u -> Radian -> Radian -> Point2 u -> Path u-curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end-  where-    sz     = 0.375 * (vlength $ pvec start end)-    v1     = avec cin  sz-    v2     = avec cout sz------ | Turn a Path into an ordinary PrimPath.------ Assumes path is properly formed - i.e. end point of one --- segment is the same point as the start point of the next--- segment.----toPrimPath :: Num u => Path u -> PrimPath u-toPrimPath (Path _ start segs _) = step1 $ viewl segs-  where-    step1 EmptyL                  = emptyPath start-    step1 (e :< se)               = let (p0,a) = seg1 e in -                                    primPath p0 $ a : step2 (viewl se)--    step2 EmptyL                  = []-    step2 (e :< se)               = seg2 e : step2 (viewl se)-    -    seg1 (LineSeg  _ p0 p1)       = (p0, lineTo p1)-    seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3)- -    seg2 (LineSeg  _ _  p1)       = lineTo p1-    seg2 (CurveSeg _ _  p1 p2 p3) = curveTo p1 p2 p3---------------------------------------------------------------------------------------- tips --tipL :: Path u -> Point2 u-tipL (Path _ sp _ _) = sp---tipR :: Path u -> Point2 u-tipR (Path _ _ _ ep) = ep------- | 'sortenPath' : @ left_dist * right_dist * path -> Path @----shortenPath :: (Real u , Floating u) => u  -> u -> Path u -> Path u-shortenPath l r = shortenL l .  shortenR r -------------------------------------------------------------------------------------- shorten from the left...---- | Note - shortening a line from the left by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the end point.----shortenL :: (Real u, Floating u) => u -> Path u -> Path u-shortenL n (Path u _ segs ep) -    | n >= u                  = line ep ep-    | otherwise               = step n (viewl segs)-  where-    step _ EmptyL     = line ep ep      -- should be unreachable-    step d (e :< se)  = let z  = segmentLength e in-                        case compare d z of-                          GT -> step (d-z) (viewl se)-                          EQ -> makeLeftPath (u-n) se ep-                          LT -> let e1 = shortenSegL d e-                                in Path (u-n) (segmentStart e1) (e1 `cons` se) ep---makeLeftPath :: Floating u => u -> JoinList (PathSeg u) -> Point2 u -> Path u-makeLeftPath u se ep = -    case viewl se of-      EmptyL   -> line ep ep-      (e :< _) -> Path u (segmentStart e) se ep---shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u-shortenSegL n (LineSeg  u p0 p1)        = -    LineSeg  (u-n) (shortenLineL n p0 p1) p1--shortenSegL n (CurveSeg u p0 p1 p2 p3)  = CurveSeg (u-n) q0 q1 q2 q3-  where-    (BezierCurve q0 q1 q2 q3) = snd $ subdividet (n/u) -                                                 (BezierCurve p0 p1 p2 p3)-     ---shortenLineL :: (Real u, Floating u) -             => u -> Point2 u -> Point2 u -> Point2 u-shortenLineL n p0 p1 = p0 .+^ v-  where-    v0 = p1 .-. p0-    v  = avec (vdirection v0) n--------------------------------------------------------------------------------------- shorten from the right ...- --- | Note - shortening a line from the right by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the start point.----shortenR :: (Real u, Floating u) => u -> Path u -> Path u-shortenR n (Path u sp segs _) -    | n >= u                  = line sp sp-    | otherwise               = step n (viewr segs)-  where-    step _ EmptyR     = line sp sp      -- should be unreachable-    step d (se :> e)  = let z = segmentLength e in-                        case compare d z of-                          GT -> step (d-z) (viewr se)-                          EQ -> makeRightPath n sp se-                          LT -> let e1 = shortenSegR d e-                                in Path (u-n) sp (se `snoc` e1) (segmentEnd e1)-                         --makeRightPath :: Floating u => u -> Point2 u -> JoinList (PathSeg u) -> Path u-makeRightPath u sp se = -    case viewr se of-      EmptyR   -> line sp sp-      (_ :> e) -> Path u sp se (segmentEnd e)----shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u-shortenSegR n (LineSeg  u p0 p1)        = -    LineSeg  (u-n) p0 (shortenLineR n p0 p1) --shortenSegR n (CurveSeg u p0 p1 p2 p3)  = CurveSeg (u-n) q0 q1 q2 q3-  where-    (BezierCurve q0 q1 q2 q3) = fst $ subdividet ((u-n)/u) -                                                 (BezierCurve p0 p1 p2 p3)-     ---shortenLineR :: (Real u, Floating u) -             => u -> Point2 u -> Point2 u -> Point2 u-shortenLineR n p0 p1 = p1 .+^ v-  where-    v0 = p0 .-. p1-    v  = avec (vdirection v0) n---------------------------------------------------------------------------------------- line direction---- | Direction of empty path is considered to be 0.----directionL :: (Real u, Floating u) => Path u -> Radian-directionL (Path _ _ se _)  = step $ viewl se-  where-    step (LineSeg  _ p0 p1 :< _)      = lineDirection p1 p0  -- 1-to-0-    step (CurveSeg _ p0 p1 _ _ :< _)  = lineDirection p1 p0-    step _                            = 0       -- should be unreachable----- | Direction of empty path is considered to be 0.----directionR :: (Real u, Floating u) => Path u -> Radian-directionR (Path _ _ se _) = step $ viewr se-  where-    step (_ :> LineSeg  _ p0 p1)      = lineDirection p0 p1-    step (_ :> CurveSeg _ _  _ p2 p3) = lineDirection p2 p3-    step _                            = 0       -- should be unreachable             ------------------------------------------------------------------------------------------ Return direction as well because the calculation is expensive...----midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian)-midway pa@(Path u sp _ _) -    | u == 0    = (sp,0)-    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1)---- Just the midway point.----midway_ :: (Real u, Floating u) => Path u -> Point2 u-midway_ = fst . midway---atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian)-atstart pa@(Path _ sp _ _) = (sp, directionL pa)--atstart_ :: Path u -> Point2 u-atstart_ (Path _ sp _ _) = sp---atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian)-atend pa@(Path _ _ _ ep) = (ep, directionR pa)- --atend_ :: Path u -> Point2 u-atend_ (Path _ _ _ ep) = ep----- nearstart, nearend, verynear ...-------------------------------------------------------------------------------------data PathViewL u = PathOneL (PathSegment u)-                 | PathSegment u :<< Path u-  deriving (Eq,Show) --type DPathViewL = PathViewL Double--data PathViewR u = PathOneR (PathSegment u)-                 | Path u :>> PathSegment u-  deriving (Eq,Show) --type DPathViewR = PathViewR Double---data PathSegment u = Line1  (Point2 u) (Point2 u)-                   | Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u)-  deriving (Eq,Show) --type DPathSegment = PathSegment Double--type instance DUnit (PathViewL u)   = u-type instance DUnit (PathViewR u)   = u-type instance DUnit (PathSegment u) = u--pathViewL :: Num u => Path u -> PathViewL u-pathViewL (Path u _ segs ep) = go (viewl segs)-  where-    go EmptyL                   = error "pathViewL - (not) unreachable."-     -    go (LineSeg v p0 p1 :< se)-        | JL.null se            = PathOneL (Line1 p0 p1)-        | otherwise             = Line1 p0 p1 :<< Path (u-v) p1 se ep--    go (CurveSeg v p0 p1 p2 p3 :< se) -        | JL.null se            = PathOneL (Curve1 p0 p1 p2 p3)-        | otherwise             = Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep---pathViewR :: Num u => Path u -> PathViewR u-pathViewR (Path u _ segs ep) = go (viewr segs)-  where-    go EmptyR                   = error "pathViewR - (not) unreachable."--    go (se :> LineSeg v p0 p1) -        | JL.null se            = PathOneR (Line1 p0 p1)-        | otherwise             = Path (u-v) p1 se ep :>> Line1 p0 p1--    go (se :> CurveSeg v p0 p1 p2 p3) -        | JL.null se            = PathOneR (Curve1 p0 p1 p2 p3)-        | otherwise             = Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3---------------------------------------------------------------------------------------- Round corners---- | The length of the control-point vector wants to be slighly --- longer than half of /d/ (d - being the distance between the --- /truncated/ points and the corner).----cornerCurve :: (Real u, Floating u, FromPtSize u) -            => Point2 u -> Point2 u -> Point2 u -> Path u-cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3-  where-    len1 = 0.6 *  (vlength $ pvec p1 p2)-    len2 = 0.6 *  (vlength $ pvec p3 p2)-    cp1  = p1 .+^ (avec (lineAngle p1 p2) len1)-    cp2  = p3 .+^ (avec (lineAngle p3 p2) len2)----- | 'roundTrail' : @ rounding_distance * [point] -> Path @------ Build a path from the list of vertices, all the interior --- corners are rounded by the rounding distance \*and\* final --- round corner is created \"incorporating\" the start point (as --- the start point becomes a rounded corner the actual path will --- not intersect it). --- --- It is expected that this function will be used to create round --- cornered shapes.--- --- 'roundTrail' throws a runtime error if the input list is empty. --- If the list has one element /the null path/ is built, if the --- list has two elements a straight line is built.----roundTrail :: (Real u, Floating u, FromPtSize u) -           => u -> [Point2 u] -> Path u -roundTrail _ []             = error "roundTrail - empty list."-roundTrail _ [a]            = pathZero a-roundTrail _ [a,b]          = line a b-roundTrail u (start:b:c:xs) = step (lineCurveTrail u start b c) (b:c:xs)-  where-    step acc (m:n:o:ps)     = step (acc `append` lineCurveTrail u m n o) (n:o:ps)-    step acc [n,o]          = acc `append` lineCurveTrail u n o start-                                  `append` lineCurveTrail u o start b -    step acc _              = acc------ | Two parts - line and corner curve...------ Note - the starting point is moved, this function is for --- closed, rounded paths.----lineCurveTrail :: (Real u, Floating u, FromPtSize u) -               => u -> Point2 u -> Point2 u -> Point2 u -> Path u-lineCurveTrail u a b c = line p1 p2 `append` cornerCurve p2 b p3-  where-    p1 = a .+^ (avec (vdirection $ pvec a b) u)-    p2 = b .+^ (avec (vdirection $ pvec b a) u)-    p3 = b .+^ (avec (vdirection $ pvec b c) u)----- | 'roundInterior' : @ rounding_distance * [point] -> Path @------ Build a path from the list of vertices, all the interior --- corners are rounded by the rounding distance. Unlike --- 'roundTrail' there is no /loop around/ to the start point,--- and start path will begin exactly on the start point and end --- exactly on the end point. --- --- 'roundInterior' throws a runtime error if the input list is --- empty. If the list has one element /the null path/ is built, --- if the list has two elements a straight line is built.----roundInterior :: (Real u, Floating u, FromPtSize u) -              => u -> [Point2 u] -> Path u -roundInterior _ []             = error "roundEveryInterior - empty list."-roundInterior _ [a]            = pathZero a-roundInterior _ [a,b]          = line a b-roundInterior u (start:b:c:xs) = let (path1,p1) = lineCurveInter1 u start b c-                                 in step path1 (p1:c:xs)-  where-    step acc (m:n:o:ps)     = let (seg2,p1) = lineCurveInter1 u m n o-                              in step (acc `append` seg2) (p1:o:ps)-    step acc [n,o]          = acc `append` line n o-    step acc _              = acc------ | Two parts - line and corner curve...------ Note - draws a straight line from the starting point - this is --- the first step of an interior (non-closed) rounded path----lineCurveInter1 :: (Real u, Floating u, FromPtSize u) -                => u -> Point2 u -> Point2 u -> Point2 u -> (Path u, Point2 u)-lineCurveInter1 u a b c = -    (line a p2 `append` cornerCurve p2 b p3, p3)-  where-    p2 = b .+^ (avec (vdirection $ pvec b a) u)-    p3 = b .+^ (avec (vdirection $ pvec b c) u)- 

@@ -0,0 +1,561 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.Base.AbsBuilder+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Build absolute paths monadically.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.Base.AbsBuilder+  ( ++    AbsBuild+  , runAbsBuild+  , execAbsBuild+  , evalAbsBuild++  , tip++  , absline+  , abscurve+  , absmove++  , relline+  , relcurve+  , relmove++  , rellineParallel+  , rellinePerpendicular++  , relmoveParallel+  , relmovePerpendicular++++  , ctrlcurve++  , insert+  , vamp+  , cycle+  , setIncline++  -- * Derived operators+  , pen_colour+  , pen_width++  , hline+  , vline+  , aline++  , hmove+  , vmove+  , amove++  , line_up+  , line_down+  , line_left+  , line_right++  , line_up_left+  , line_up_right+  , line_down_left+  , line_down_right++  , line_north+  , line_south+  , line_east+  , line_west+  , line_northeast+  , line_northwest+  , line_southeast+  , line_southwest++  , move_up+  , move_down+  , move_left+  , move_right++  , move_up_left+  , move_up_right+  , move_down_left+  , move_down_right++  , move_north+  , move_south+  , move_east+  , move_west+  , move_northeast+  , move_northwest+  , move_southeast+  , move_southwest+++  ) where++import Wumpus.Drawing.Paths.Base.AbsPath+import qualified Wumpus.Drawing.Paths.Base.AbsPath as A+import Wumpus.Drawing.Paths.Base.BuildCommon+import qualified Wumpus.Drawing.Paths.Base.RelPath as R+++import Wumpus.Basic.Geometry ( half_pi )        -- package: wumpus-basic+import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Control.Applicative hiding ( empty )+import Data.Monoid++import Prelude hiding ( log, cycle )++++-- State monad building is quite good - it ameliorates the problem+-- of joining to the end point of an empty path...++data St u = St+      { current_point     :: Point2 u +      , current_incline   :: Radian+      , cumulative_path   :: AbsPath u+      , active_path       :: (Point2 u, AbsPath u)+      , pen_dc_modifier   :: DrawingContextF+      }++type instance DUnit (St u) = u++type Log u  = BuildLog (Graphic u)+++-- | Absolute Path builder monad.+--+newtype AbsBuild u a = AbsBuild { +          getAbsBuild :: St u -> (a, St u, Log u) }++type instance DUnit (AbsBuild u a) = u+++--------------------------------------------------------------------------------+-- instances++++instance Functor (AbsBuild u) where+  fmap f mf = AbsBuild $ \s0 -> let (a,s1,w1) = getAbsBuild mf s0+                                in (f a, s1, w1)+++instance Applicative (AbsBuild u) where+  pure a    = AbsBuild $ \s0 -> (a,s0,mempty)+  mf <*> ma = AbsBuild $ \s0 -> let (f,s1,w1) = getAbsBuild mf s0+                                    (a,s2,w2) = getAbsBuild ma s1+                                in (f a,s2,w1 `mappend` w2)++instance Monad (AbsBuild u) where+  return a  = AbsBuild $ \s0 -> (a,s0,mempty)+  m >>= k   = AbsBuild $ \s0 -> let (a,s1,w1) = getAbsBuild m s0+                                    (b,s2,w2) = (getAbsBuild . k) a s1+                                in (b, s2, w1 `mappend` w2)++++++-- | The initial state is needs the start point.+--+initSt :: Floating u => Point2 u -> St u+initSt pt = St { current_point     = pt+               , current_incline   = 0+               , cumulative_path   = empty pt+               , active_path       = (pt, empty pt)+               , pen_dc_modifier   = id+               }++-- run  - (path,graphic)+-- exec - graphic+-- eval - path++-- | Note - runAbsBuild drops the monadic answer and returns the+-- constructed path and a trace of the inserts and sub-paths.+--+runAbsBuild :: (Floating u, InterpretUnit u)+            => Point2 u -> AbsBuild u a -> (AbsPath u, Graphic u)+runAbsBuild pt mf = post $ getAbsBuild mf (initSt pt)+  where+    post (_,st,log) = let sub_last  = snd $ active_path st+                          cf        = pen_dc_modifier st+                          log_last  = logSubPath PATH_OPEN cf sub_last+                          log2      = log `mappend` log_last+                          empty_gfx = emptyLocGraphic `at` pt+                          (pen,ins) = extractTrace empty_gfx log2+                      in (cumulative_path st, pen `oplus` ins)+++-- | Run an 'AbsBuild' - return the Graphic formed by the pen +-- trace and the insert trace, /forget/ the outline of the path.+-- +execAbsBuild :: (Floating u, InterpretUnit u)+             => Point2 u -> AbsBuild u a -> Graphic u+execAbsBuild pt mf = snd $ runAbsBuild pt mf++++-- | Run an 'AbsBuild' - return the outline of the path, /forget/+-- the  Graphic formed by the pen trace and the insert trace.+-- +evalAbsBuild :: (Floating u, InterpretUnit u)+             => Point2 u -> AbsBuild u a -> AbsPath u+evalAbsBuild pt mf = fst $ runAbsBuild pt mf++++logSubPath :: InterpretUnit u +           => PathEnd -> DrawingContextF -> AbsPath u -> Log u +logSubPath spe upd subp +    | A.null subp  = mempty+    | otherwise    = pen1 (toPrimPath subp >>= localize upd . drawF)+  where+    drawF = if spe == PATH_OPEN then openStroke else closedStroke++++tellSubClosed :: InterpretUnit u +              => DrawingContextF -> AbsPath u -> AbsBuild u ()+tellSubClosed upd subp = +    AbsBuild $ \s0 -> ((), s0, logSubPath PATH_CLOSED upd subp)++tellSubOpen :: InterpretUnit u +            => DrawingContextF -> AbsPath u -> AbsBuild u ()+tellSubOpen upd subp = +    AbsBuild $ \s0 -> ((), s0, logSubPath PATH_OPEN upd subp)+++tellInsert :: Graphic u -> AbsBuild u ()+tellInsert g1 = +    AbsBuild $ \s0 -> ((),s0, insert1 g1)+++sets_   :: (St u -> St u) -> AbsBuild u ()+sets_ f = AbsBuild $ \s0 -> ((), f s0, mempty)+++gets    :: (St u -> a) -> AbsBuild u a+gets f  = AbsBuild $ \s0 -> (f s0, s0, mempty)++++--------------------------------------------------------------------------------+-- operations++tip :: AbsBuild u (Point2 u)+tip = gets current_point++-- | Helper - extend the path.+--+extendPath :: (Point2 u -> AbsPath u -> AbsPath u) -> Point2 u -> AbsBuild u ()+extendPath fn end_pt = sets_ upd+  where+    upd = (\s pt i j -> s { current_point    = end_pt+                          , cumulative_path  = fn pt i+                          , active_path      = bimapR (fn pt) j })+           <*> current_point <*> cumulative_path <*> active_path++absline :: Floating u => Point2 u -> AbsBuild u ()+absline p1 = extendPath (\_ acc -> acc `snocLineTo` p1) p1++++abscurve :: (Floating u, Ord u, Tolerance u)+        => Point2 u -> Point2 u -> Point2 u -> AbsBuild u ()+abscurve p1 p2 p3 = extendPath (\_ acc -> snocCurveTo acc p1 p2 p3) p3++++   +-- | 'absmove' is a pen up.+--+absmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +       => Point2 u -> AbsBuild u ()+absmove p1 = +    gets active_path            >>= \(_,ans) -> +    gets pen_dc_modifier        >>= \cf -> +    tellSubOpen cf ans          >> sets_ upd +  where+    upd   = (\s i -> s { current_point   = p1+                       , cumulative_path = i `snocLineTo` p1+                       , active_path     = (p1, empty p1) }) +              <*> cumulative_path+++relline :: Floating u => Vec2 u -> AbsBuild u ()+relline v1 = gets current_point >>= \pt -> absline (pt .+^ v1)+++relcurve :: (Floating u, Ord u, Tolerance u)+         => Vec2 u -> Vec2 u -> Vec2 u -> AbsBuild u ()+relcurve v1 v2 v3 = +    gets current_point >>= \pt -> +    abscurve (pt .+^ v1) (pt .+^ v1 ^+^ v2) (pt .+^ v1 ^+^ v2 ^+^ v3)+++relmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +        => Vec2 u -> AbsBuild u ()+relmove v1 = gets current_point >>= \pt -> absmove (pt .+^ v1)++++rellineParallel :: Floating u => u -> AbsBuild u ()+rellineParallel u = gets current_incline >>= \ang -> relline (avec ang u)++rellinePerpendicular :: Floating u => u -> AbsBuild u ()+rellinePerpendicular u = +    gets current_incline >>= \ang -> relline (avec (fn ang) u)+  where+    fn = circularModulo . (+ half_pi)++relmoveParallel :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +                => u -> AbsBuild u ()+relmoveParallel u = gets current_incline >>= \ang -> relmove (avec ang u)+++relmovePerpendicular :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +                     => u -> AbsBuild u ()+relmovePerpendicular u = +    gets current_incline >>= \ang -> relmove (avec (fn ang) u)+  where+    fn = circularModulo . (+ half_pi)++++ctrlcurve :: (Floating u, Ord u, Tolerance u) +          => Radian -> Radian -> Point2 u -> AbsBuild u ()+ctrlcurve cin cout p1 = +    extendPath (\p0 acc -> acc `append` controlCurve p0 cin cout p1) p1++++insert :: Num u => LocGraphic u -> AbsBuild u ()+insert gf = gets current_point >>= \pt -> tellInsert (gf `at` pt)+++penCtxUpdate :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +             => DrawingContextF -> AbsBuild u ()+penCtxUpdate cf = relmove (V2 0 0) >> sets_ upd+  where+    upd = (\s f -> s { pen_dc_modifier = cf . f })+            <*> pen_dc_modifier++++-- Note - vamps should be a data type then we can have libraries +-- of them.++vamp :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +     => Vamp u -> AbsBuild u ()+vamp (Vamp vnext vstart upd relp path_end) = +    gets current_point >>= \p0 -> +    relmove vnext >> drawF upd (R.toAbsPath (p0 .+^ vstart) relp)+  where+    drawF = if path_end == PATH_OPEN then tellSubOpen else tellSubClosed++cycle :: (Floating u, InterpretUnit u) => AbsBuild u ()+cycle = +    gets current_point    >>= \pt -> +    gets pen_dc_modifier  >>= \cf ->+    gets active_path      >>= \(start,acc) -> +    tellSubClosed cf (acc `snocLineTo` start) >> +    sets_ (\s -> s { active_path = (pt, empty pt)})+++setIncline :: Radian -> AbsBuild u ()+setIncline ang = sets_ upd+  where+    upd = (\s -> s { current_incline = ang })+++--------------------------------------------------------------------------------+-- Derived operators+++pen_colour :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +           => RGBi -> AbsBuild u ()+pen_colour rgb = penCtxUpdate (stroke_colour rgb)++pen_width  :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +           => Double -> AbsBuild u ()+pen_width d = penCtxUpdate (set_line_width d)+++++hline :: Floating u => u -> AbsBuild u ()+hline dx = relline (hvec dx)++vline :: Floating u => u -> AbsBuild u ()+vline dy = relline (vvec dy)++aline :: Floating u => u -> AbsBuild u ()+aline u = gets current_incline >>= \ang -> relline (avec ang u)++hmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +      => u -> AbsBuild u ()+hmove dx = relmove (hvec dx)++vmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +      => u -> AbsBuild u ()+vmove dy = relmove (vvec dy)+++amove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +      => u -> AbsBuild u ()+amove u = gets current_incline >>= \ang -> relmove (avec ang u)++++line_up :: Floating u => u -> AbsBuild u ()+line_up u = relline (vvec u)++line_down :: Floating u => u -> AbsBuild u ()+line_down u = relline (vvec $ negate u)++line_left :: Floating u => u -> AbsBuild u ()+line_left u = relline (hvec $ negate u)+ +line_right :: Floating u => u -> AbsBuild u ()+line_right u = relline (hvec u)++-- | Diagonal lines ++line_up_left :: Floating u => u -> AbsBuild u ()+line_up_left u = relline (vec (-u) u)++line_up_right :: Floating u => u -> AbsBuild u ()+line_up_right u = relline (vec u u)++line_down_left :: Floating u => u -> AbsBuild u ()+line_down_left u = relline (vec (-u) (-u))++line_down_right :: Floating u => u -> AbsBuild u ()+line_down_right u = relline (vec u (-u))+++-- Cardinal lines++line_north :: Floating u => u -> AbsBuild u ()+line_north = vline+++line_south :: Floating u => u -> AbsBuild u ()+line_south =  vline . negate++line_east :: Floating u => u -> AbsBuild u ()+line_east = hline++line_west :: Floating u => u -> AbsBuild u ()+line_west = hline . negate+++line_northeast ::  Floating u => u -> AbsBuild u ()+line_northeast = relline . avec (0.25 * pi)++line_northwest ::  Floating u => u -> AbsBuild u ()+line_northwest = relline . avec (0.75 * pi)++line_southeast ::  Floating u => u -> AbsBuild u ()+line_southeast = relline . avec (1.75 * pi)++line_southwest ::  Floating u => u -> AbsBuild u ()+line_southwest = relline . avec (1.25 * pi)+++++move_up :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +        => u -> AbsBuild u ()+move_up u = relmove (vvec u)++move_down :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +          => u -> AbsBuild u ()+move_down u = relmove (vvec $ negate u)++move_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +          => u -> AbsBuild u ()+move_left u = relmove (hvec $ negate u)+ +move_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u)  +           => u -> AbsBuild u ()+move_right u = relmove (hvec u)++++-- | Diagonal moves ++move_up_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +             => u -> AbsBuild u ()+move_up_left u = relmove (vec (-u) u)++move_up_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +              => u -> AbsBuild u ()+move_up_right u = relmove (vec u u)++move_down_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +               => u -> AbsBuild u ()+move_down_left u = relmove (vec (-u) (-u))++move_down_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +                => u -> AbsBuild u ()+move_down_right u = relmove (vec u (-u))+++-- Cardinal moves++move_north :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +           => u -> AbsBuild u ()+move_north = vmove+++move_south :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +           => u -> AbsBuild u ()+move_south =  vmove . negate++move_east :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +          => u -> AbsBuild u ()+move_east = hmove++move_west :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +          => u -> AbsBuild u ()+move_west = hmove . negate+++move_northeast :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +               => u -> AbsBuild u ()+move_northeast = relmove . avec (0.25 * pi)++move_northwest :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +               => u -> AbsBuild u ()+move_northwest = relmove . avec (0.75 * pi)++move_southeast :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +               => u -> AbsBuild u ()+move_southeast = relmove . avec (1.75 * pi)++move_southwest :: (Floating u, Ord u, Tolerance u, InterpretUnit u) +               => u -> AbsBuild u ()+move_southwest = relmove . avec (1.25 * pi)+++