wumpus-drawing 0.3.0 → 0.4.0

raw patch · 61 files changed

+3124/−3099 lines, 61 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

• CHANGES +26/−0
• demo/Arrowheads.hs +9/−9
• demo/Automata.hs +14/−6
• demo/ClipPic.hs +52/−52
• demo/ColourCharts.hs +6/−4
• demo/Connectors.hs +6/−6
• demo/DotPic.hs +48/−49
• demo/FeatureModel.hs +2/−2
• demo/FontPic.hs +5/−5
• demo/LeftRightText.hs +12/−23
• demo/PetriNet.hs +9/−9
• demo/SampleShapes.hs +16/−14
• demo/SingleChar.hs +3/−3
• demo/SingleLine.hs +3/−2
• demo/Symbols.hs +2/−2
• demo/TableChains.hs +0/−26
• src/Wumpus/Drawing/Basis/DrawingPrimitives.hs +136/−0
• src/Wumpus/Drawing/Basis/LocTrace.hs +252/−0
• src/Wumpus/Drawing/Basis/RefTrace.hs +297/−0
• src/Wumpus/Drawing/Basis/TraceGraphic.hs +168/−0
• src/Wumpus/Drawing/Connectors.hs +0/−2
• src/Wumpus/Drawing/Connectors/Arrowheads.hs +155/−104
• src/Wumpus/Drawing/Connectors/Base.hs +118/−72
• src/Wumpus/Drawing/Connectors/BoxConnectors.hs +6/−6
• src/Wumpus/Drawing/Connectors/ConnectorPaths.hs +28/−28
• src/Wumpus/Drawing/Connectors/Loop.hs +0/−86
• src/Wumpus/Drawing/Dots/AnchorDots.hs +111/−60
• src/Wumpus/Drawing/Dots/Marks.hs +0/−242
• src/Wumpus/Drawing/Dots/SimpleDots.hs +267/−0
• src/Wumpus/Drawing/Extras/Axes.hs +12/−13
• src/Wumpus/Drawing/Extras/Clip.hs +41/−0
• src/Wumpus/Drawing/Extras/Grids.hs +71/−90
• src/Wumpus/Drawing/Extras/Loop.hs +95/−0
• src/Wumpus/Drawing/Extras/Turtle/TurtleClass.hs +0/−91
• src/Wumpus/Drawing/Extras/Turtle/TurtleMonad.hs +0/−132
• src/Wumpus/Drawing/Paths/Absolute.hs +3/−3
• src/Wumpus/Drawing/Paths/Base/AbsBuilder.hs +0/−561
• src/Wumpus/Drawing/Paths/Base/AbsPath.hs +41/−2
• src/Wumpus/Drawing/Paths/Base/BuildCommon.hs +0/−129
• src/Wumpus/Drawing/Paths/Base/PathBuilder.hs +576/−0
• src/Wumpus/Drawing/Paths/Base/RelBuilder.hs +0/−520
• src/Wumpus/Drawing/Paths/Base/RelPath.hs +126/−46
• src/Wumpus/Drawing/Paths/Relative.hs +2/−2
• src/Wumpus/Drawing/Paths/Vamps.hs +10/−20
• src/Wumpus/Drawing/Shapes/Base.hs +24/−29
• src/Wumpus/Drawing/Shapes/Circle.hs +2/−2
• src/Wumpus/Drawing/Shapes/Diamond.hs +4/−4
• src/Wumpus/Drawing/Shapes/Ellipse.hs +2/−2
• src/Wumpus/Drawing/Shapes/Parallelogram.hs +47/−92
• src/Wumpus/Drawing/Shapes/Rectangle.hs +4/−6
• src/Wumpus/Drawing/Shapes/Semicircle.hs +47/−35
• src/Wumpus/Drawing/Shapes/Semiellipse.hs +27/−29
• src/Wumpus/Drawing/Shapes/Trapezium.hs +34/−114
• src/Wumpus/Drawing/Shapes/Triangle.hs +33/−40
• src/Wumpus/Drawing/Text/Base/Common.hs +5/−5
• src/Wumpus/Drawing/Text/Base/DocTextZero.hs +29/−25
• src/Wumpus/Drawing/Text/Base/Label.hs +90/−6
• src/Wumpus/Drawing/Text/Base/PosChar.hs +3/−3
• src/Wumpus/Drawing/Text/Base/RotTextZero.hs +22/−236
• src/Wumpus/Drawing/VersionNumber.hs +2/−2
• wumpus-drawing.cabal +21/−48

@@ -1,4 +1,30 @@ ++0.2.0 to 0.3.0:++  * Moved Turtle and Grids into the @Wumpus.Drawing.Extras@+    name-space. Modules here are considered sketches.++  * Re-implemented arrowheads and connectors.++  * Re-implemented monadic path construction. This is now +    essentially \"turtle drawing\" with a path trace.++  * Removed chains - a simplified implementation is now +    provided by Wumpus-Basic.++  * Re-implemented and expanded Text.  ++0.1.0 to 0.2.0:++  * Added new Shapes.++  * Move Geometry modules to Wumpus-Basic.++  * Re-implemented Chains.++  * Re-implemented LR-Text. Added CatText.+ 0.1.0:    * Initial release - this is a split from @Wumpus-Basic@ making 

@@ -13,7 +13,7 @@  import Wumpus.Core                              -- package: wumpus-core -+import Data.Monoid import System.Directory  main :: IO ()@@ -38,7 +38,7 @@ arrow_drawing =      drawTracing $ localize dotted_line $ tableGraphic arrtable -arrtable :: [(String, ArrowTip Double)]+arrtable :: [(String, ArrowTip)] arrtable =      [ ("tri90",                 tri90)     , ("tri60",                 tri60)@@ -74,7 +74,7 @@   -tableGraphic :: [(String, ArrowTip Double)] -> TraceDrawing Double ()+tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double () tableGraphic tips =      drawl start $ chain_ chn_alg (map makeArrowDrawing tips)   where@@ -87,12 +87,12 @@   -makeArrowDrawing :: (String, ArrowTip Double) -> LocGraphic Double-makeArrowDrawing (name, utip) = aconn `oplus` lbl+makeArrowDrawing :: (String, ArrowTip) -> LocGraphic Double+makeArrowDrawing (name, utip) = aconn `mappend` lbl   where-    aconn = promoteR1 $ \pt -> fmap ignoreAns $ -              connect (uniformArrow utip connline) pt (displaceH 60 pt)+    aconn = ignoreAns $ promoteLoc $ \pt ->+              connect pt (displace (hvec 60) pt) (uniformArrow utip connline) -    lbl   = promoteR1 $ \pt -> fmap ignoreAns $ -              atStartAddr (textline name) (displaceH 66 pt) WW+    lbl   = ignoreAns $ promoteLoc $ \pt -> +              textline name WW `at` (displace (hvec 66) pt) 

@@ -4,6 +4,7 @@ module Automata where  import Wumpus.Drawing.Connectors+import Wumpus.Drawing.Extras.Loop import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero@@ -57,11 +58,12 @@      return () -+-- Monadic at - this is a hack that needs a rethink...+--  infixr 1 `mat` -mat :: LocImage u a -> Query (Point2 u) -> Image u a-mat img mq = mq >>= \pt -> img `at` pt+mat :: LocImage u a -> Query u (Point2 u) -> Image u a+mat img mq = zapQuery mq >>= \pt -> img `at` pt  state :: String -> DLocImage DCircle state ss = @@ -84,12 +86,12 @@              => a -> b -> Image u (AbsPath u) straightconn a b =     let (p0,p1) = radialConnectorPoints a b-    in connect (rightArrow tri45 connline) p0 p1+    in connect p0 p1 (rightArrow tri45 connline)   astraightconn :: ( Real u, Floating u, InterpretUnit u)               => Anchor u -> Anchor u -> Image u (AbsPath u)-astraightconn p0 p1 = connect (rightArrow tri45 connline) p0 p1+astraightconn p0 p1 = connect p0 p1 (rightArrow tri45 connline)   -- Note - there is a problem with @rightArrow@ as @loop@@@ -97,7 +99,13 @@ -- 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+arrloop ctr p1 = +    zapQuery (loop zradius ctr zincl) >>= \absp -> +    rightArrowPath tri45 absp +  where+    v1      = pvec ctr p1+    zradius = vlength v1+    zincl   = vdirection v1   

@@ -13,7 +13,8 @@ module ClipPic where  import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Extras.Clip+import Wumpus.Drawing.Paths.Relative import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic@@ -22,13 +23,14 @@  import Data.AffineSpace                         -- package: vector-space +import Data.Monoid import System.Directory   main :: IO () main = do      createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx $ top_pic `vconcat` clip_pic+    let pic1 = runCtxPictureU std_ctx clip_pic     writeEPS "./out/clip_pic.eps" pic1     writeSVG "./out/clip_pic.svg" pic1 @@ -37,74 +39,72 @@ std_ctx = standardContext 14  -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- clip_pic :: CtxPicture-clip_pic = drawTracing $ do-    mapM_ draw $ [ clip1, clip2, clip3, clip4 ]+clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do+    drawl (P2   0 320) $ closedRelPath FILL path01+    drawl (P2 112 320) $ localize (fill_colour powder_blue) $ closedRelPath FILL path02+    drawl (P2 384 416) $ closedRelPath FILL path03+    drawl (P2 328 512) $ closedRelPath FILL path04+    drawl (P2   0   0) $ clip1+    drawl (P2 112   0) $ clip2+    drawl (P2 384  96) $ clip3+    drawl (P2 328 192) $ clip4  -background :: RGBi -> Graphic Double-background rgb = -    fmap ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288+background :: RGBi -> LocGraphic Double+background rgb = promoteLoc $ \_ -> +    ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288   where     ihh = chain (tableDown 18 (86,16)) (replicate 112 iheartHaskell) --- 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)+clip1 :: LocGraphic Double+clip1 = locClip path01 $ background black   -clip2 :: Graphic Double-clip2 = toPrimPath path02 >>= \pp -> clipGraphic pp (background medium_violet_red)+clip2 :: LocGraphic Double+clip2 = locClip path02 $ background medium_violet_red -clip3 :: Graphic Double-clip3 = toPrimPath path03 >>= \pp -> clipGraphic pp (background black)+clip3 :: LocGraphic Double+clip3 = locClip path03 $ background black -clip4 :: Graphic Double-clip4 = toPrimPath path04 >>= \pp -> clipGraphic pp (background black)+clip4 :: LocGraphic Double+clip4 = locClip path04 $ background black   iheartHaskell :: LocGraphic Double-iheartHaskell = promoteR1 $ \pt -> -    let body  = plainTextLine "I Haskell" `at` pt+iheartHaskell = promoteLoc $ \pt -> +    let body  = dcTextlabel "I Haskell" `at` pt         heart = localize (set_font symbol) $ -                  plainTextLine "&heart;" `at` (pt .+^ hvec 7)-    in body `oplus` heart+                  dcTextlabel "&heart;" `at` (pt .+^ hvec 7)+    in body `mappend` heart  -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))+-- zeroPt+path01 :: RelPath Double+path01 = evalPathSpec $  hline 80 +                      >> line (vec 112 160) +                      >> line (vec (-112) 160)+                      >> hline (-80)+                      >> line (vec 112 (-160))+                      >> line (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))+-- (P2 112 0)+path02 :: RelPath Double+path02 = evalPathSpec  $  hline 80 +                       >> line (vec 72 112)+                       >> line (vec 72 (-112))+                       >> hline 80+                       >> line (vec (-224) 320)+                       >> hline (-80)+                       >> line (vec 112 (-160))+                       >> line (vec (-112) (-160)) -path03 :: AbsPath Double-path03 = evalAbsBuild (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) +-- (P2 384 96) +path03 :: RelPath Double+path03 = evalPathSpec $ hline 96 >> vline 56 >> hline (-136)  -path04 :: AbsPath Double-path04 = evalAbsBuild (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) +-- (P2 328 192)+path04 :: RelPath Double+path04 = evalPathSpec  $ hline 152 >> vline 56 >> hline (-192)  

@@ -4,11 +4,13 @@  import ColourChartUtils +import Wumpus.Drawing.Basis.DrawingPrimitives  import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core +import Data.Monoid import System.Directory  @@ -44,14 +46,14 @@ tableGraphic row_count xs = draw $ (chain_ chn gs) `at` pt   where     chn  = tableDown row_count (152,11)-    pt   = displaceV (fromIntegral $ 11 * row_count) zeroPt +    pt   = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt      gs   = map (uncurry colourSample) xs      colourSample :: String -> RGBi -> LocGraphic Double colourSample name rgb = localize (fill_colour rgb) $ -    promoteR1 $ \pt ->  -      oplus (borderedRectangle 15 10 `at` pt)-            (plainTextLine name `at` displace 20 2 pt)+    promoteLoc $ \pt ->  +      mappend (blRectangle FILL_STROKE 15 10 `at` pt)+              (dcTextlabel name `at` displace (vec 20 2) pt)          

@@ -13,7 +13,7 @@ import Wumpus.Core                              -- package: wumpus-core  -+import Data.Monoid import System.Directory  @@ -76,13 +76,13 @@  makeConnDrawing :: (String, Connector Double) -> DLocGraphic  makeConnDrawing (ss,conn) = -    promoteR1 $ \p0 -> fn p0 (displace 60 40 p0) +    promoteLoc $ \p0 -> fn p0 (displace (vec 60 40) p0)    where-    fn p0 p1   = disk p0 `oplus` disk p1 `oplus` dcon p0 p1 `oplus` lbl p1+    fn p0 p1   = mconcat [disk p0, disk p1, dcon p0 p1, lbl p1] -    disk pt    = localize (fill_colour red) $ filledDisk 2 `at` pt-    dcon p0 p1 = fmap ignoreAns $ connect (uniformArrow curveTip conn) p0 p1+    disk pt    = localize (fill_colour red) $ dcDisk FILL 2 `at` pt+    dcon p0 p1 = ignoreAns $ connect p0 p1 (uniformArrow curveTip conn) -    lbl  pt    = fmap ignoreAns $ atStartAddr (textline ss) (displaceH 10 pt) WW+    lbl  pt    = ignoreAns $ textline ss WW `at` (displace (hvec 10) pt)  

@@ -4,6 +4,8 @@  import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.AnchorDots+import Wumpus.Drawing.Paths.Relative+import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic@@ -11,8 +13,7 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space-+import Data.Monoid import System.Directory  main :: IO ()@@ -30,68 +31,66 @@     makeCtx :: FontLoadResult -> DrawingContext-makeCtx = fill_colour peru . set_font helvetica . metricsContext 24+makeCtx = fill_colour peru . set_font helvetica . metricsContext 14   dot_pic :: CtxPicture-dot_pic = drawTracing $ tableGraphic $ -    [ dotHLine-    , dotVLine-    , dotX-    , dotPlus-    , dotCross-    , dotDiamond-    , dotDisk-    , dotSquare-    , dotCircle-    , dotPentagon-    , dotStar-    , dotAsterisk-    , dotOPlus-    , dotOCross-    , dotFOCross-    , dotFDiamond-    , dotText "%" -    , dotTriangle+dot_pic = drawTracing $ tableGraphic dottable+++dottable :: [(String, DotLocImage Double)]+dottable =   +    [ ("smallDisk",     smallDisk)+    , ("largeDisk",     largeDisk)+    , ("smallCirc",     smallCirc)+    , ("largeCirc",     largeCirc)+    , ("dotNone",       dotNone)+    , ("dotHLine",      dotHLine)+    , ("dotVLine",      dotVLine)+    , ("dotX",          dotX)+    , ("dotPlus",       dotPlus)+    , ("dotCross",      dotCross)+    , ("dotDiamond",    dotDiamond)+    , ("dotDisk",       dotDisk)+    , ("dotSquare",     dotSquare)+    , ("dotCircle",     dotCircle)+    , ("dotPentagon",   dotPentagon)+    , ("dotStar",       dotStar)+    , ("dotAsterisk",   dotAsterisk)+    , ("dotOPlus",      dotOPlus)+    , ("dotOCross",     dotOCross)+    , ("dotFOCross",    dotFOCross)+    , ("dotFDiamond",   dotFDiamond)+    , ("dotText" ,      dotText "%")+    , ("dotTriangle",   dotTriangle)      ]  -tableGraphic :: [DotLocImage Double] -> TraceDrawing Double ()++tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double () tableGraphic imgs =      draw $ chain_ chn_alg (map makeDotDrawing imgs) `at` pt   where-    row_count   = length imgs-    chn_alg     = tableDown row_count (1,36)-    pt          = displaceV (fromIntegral $ 36 * row_count) zeroPt +    row_count   = 18+    chn_alg     = tableDown row_count (180,36)+    pt          = displace (vvec $ fromIntegral $ 36 * row_count) zeroPt    --- This is a bit convoluted - maybe there should be chain-run --- functions for TraceDrawings as well as LocGraphics? -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 -> fmap ignoreAns $ dotF `at` p1) all_points)+makeDotDrawing :: (String, DotLocImage Double) -> DLocGraphic +makeDotDrawing (name,df) = +    drawing `mappend` moveStart (vec 86 14) lbl   where-    dashline = \ps -> localize attrUpd $ vertexPP ps >>= openStroke--    attrUpd  :: DrawingContext -> DrawingContext-    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]-+    drawing     = execPathSpec $ +                    updatePen path_style >> +                    insertl dot >> mapM (\v -> line v >> insertl dot) steps --- Should these produce a DashPattern or a StrokeAttr?+    lbl         = ignoreAns $ promoteLoc $ \pt -> +                    textline name WW `at` pt -evenDashes :: Int -> DashPattern -evenDashes n = Dash 0 [(n,n)]+    steps       = [V2 25 15, V2 25 (-15), V2 25 15]+    dot         = ignoreAns df+    path_style  = packed_dotted . stroke_colour cadet_blue -dashOffset :: Int -> DashPattern -> DashPattern-dashOffset _ Solid       = Solid-dashOffset n (Dash _ xs) = Dash n xs 

@@ -87,12 +87,12 @@   connWith :: ( Real u, Floating u, InterpretUnit u ) -         => ArrowTip u -> Box u -> Box u -> TraceDrawing u (AbsPath u)+         => ArrowTip -> 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 $ connect (rightArrow arrh connline) p0 p1+   drawi $ connect p0 p1 (rightArrow arrh connline)  infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` 

@@ -42,7 +42,7 @@   makeLabel :: RGBi -> FontDef -> Int -> DLocGraphic-makeLabel rgb ft sz = localize upd (plainTextLine $ fontMsg ft sz)+makeLabel rgb ft sz = localize upd (dcTextlabel $ fontMsg ft sz)   where     upd = text_colour rgb . font_attr ft sz  @@ -59,14 +59,14 @@ pointChain :: (Int -> DLocGraphic) -> DLocImage DPoint2 pointChain fn = chain chn_alg $ map fn point_sizes   where-    chn_alg = linear $ iterationScheme start step+    chn_alg = linearChain $ 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)+    step (pt,[])     = ((displace (vvec 50) pt, []), pt)+    step (pt,(y:ys)) = ((displace (vvec $ fromIntegral $ 2 + y)  pt, ys), pt)  fontGraphic :: RGBi -> FontDef -> DLocGraphic -fontGraphic rgb ft = locGraphic_ $ pointChain mkGF+fontGraphic rgb ft = ignoreAns $ pointChain mkGF   where     mkGF sz = makeLabel rgb ft sz 

@@ -1,23 +1,12 @@ {-# OPTIONS -Wall #-} --- Note - @main@ is more convoluted than would normally be --- expected as it supports both sources of glyph metrics - the --- GhostScript distribution or the Core 14 metrics from Adobe.--- --- \"Real\" applications would be expected to choose one source. ------ I-am-not-a-lawyer, but it does look as though the Adobe font--- metrics are redistributable, the GhostScript metrics are --- seemingly redistributable under the same terms as the larger--- GhostScript distribution.---    module LeftRightText where   import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Dots.Marks+import Wumpus.Drawing.Dots.SimpleDots import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -84,47 +73,47 @@     fn = illustrateBoundedLocGraphic     redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u-redPlus = localize (stroke_colour red) markPlus+redPlus = localize (stroke_colour red) dotPlus    -- single line -- ne_oneline :: BoundedLocGraphic Double-ne_oneline = textline "north east" `startAddr` NE+ne_oneline = textline "north east" NE   -- single line -- se_oneline :: BoundedLocGraphic Double-se_oneline = textline "south east" `startAddr` SE+se_oneline = textline "south east" SE  -- single line -- ss_oneline :: BoundedLocGraphic Double-ss_oneline = textline "south" `startAddr` SS+ss_oneline = textline "south" SS  -- single line -- sw_oneline :: BoundedLocGraphic Double-sw_oneline = textline "south west" `startAddr` SW+sw_oneline = textline "south west" SW    -- single line rot -- ssr_single :: BoundedLocGraphic Double-ssr_single = rtextline (0.25*pi) "south rot45" `startAddr` SS+ssr_single = rtextline (0.25*pi) "south rot45"  SS  -- single line rot -- swr_single :: BoundedLocGraphic Double-swr_single = rtextline (0.25*pi)  "south west rot45" `startAddr` SW+swr_single = rtextline (0.25*pi)  "south west rot45" SW  -- single line rot -- ner_single :: BoundedLocGraphic Double-ner_single = rtextline (0.25*pi)  "north east rot45" `startAddr`  NE+ner_single = rtextline (0.25*pi)  "north east rot45" NE   cc_oneline :: BoundedLocGraphic Double@@ -136,14 +125,14 @@   left_text :: BoundedLocGraphic Double-left_text = multiAlignLeft dummy_text `startAddr` CENTER+left_text = multiAlignLeft dummy_text CENTER   right_text :: BoundedLocGraphic Double-right_text = multiAlignRight dummy_text `startAddr` CENTER+right_text = multiAlignRight dummy_text CENTER  center_text :: BoundedLocGraphic Double-center_text = multiAlignCenter dummy_text `startAddr` CENTER+center_text = multiAlignCenter dummy_text CENTER  dummy_text :: String  dummy_text = unlines $ [ "The quick brown"

@@ -100,39 +100,39 @@   straightconn :: ConnectorGraphic Double-straightconn = connectorGraphic_ $ rightArrow tri45 connline+straightconn = ignoreAns $ rightArrow tri45 connline   connectorC :: ConnectorGraphic Double connectorC = -    connectorGraphic_ $ localize (uniform_arm_len  (30::Double)) -                      $ rightArrow tri45 connbbar+    ignoreAns $ localize (uniform_arm_len  (30::Double)) +              $ rightArrow tri45 connbbar  connectorC' :: ConnectorGraphic Double connectorC' = -    connectorGraphic_ $ localize (uniform_arm_len  (30::Double)) +    ignoreAns $ localize (uniform_arm_len  (30::Double))                        $ rightArrow tri45 connabar  connectorD :: ConnectorGraphic Double-connectorD = connectorGraphic_ $ rightArrow tri45 connarc+connectorD = ignoreAns $ rightArrow tri45 connarc  connectorD' :: ConnectorGraphic Double connectorD' = -    connectorGraphic_ $ localize (conn_arc_angle $ negate $ pi / 12) +    ignoreAns $ localize (conn_arc_angle $ negate $ pi / 12)                        $ rightArrow tri45 connarc   lblParensParens :: DLocGraphic lblParensParens = -    locGraphic_ $ localize (set_font helvetica) $ ccTextline "(),()"+    ignoreAns $ localize (set_font helvetica) $ ccTextline "(),()"  lblParensParensParens :: DLocGraphic lblParensParensParens = -    locGraphic_ $ localize (set_font helvetica) $ ccTextline "(),(),()"+    ignoreAns $ localize (set_font helvetica) $ ccTextline "(),(),()"    lblBold :: String -> DLocGraphic lblBold ss = -    locGraphic_ $ localize (set_font helvetica_bold) $ ccTextline ss+    ignoreAns $ localize (set_font helvetica_bold) $ ccTextline ss 

@@ -7,7 +7,7 @@   import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Dots.Marks+import Wumpus.Drawing.Dots.SimpleDots import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs@@ -18,6 +18,7 @@ import Wumpus.Core                              -- package: wumpus-core  import Control.Monad+import Data.Monoid import System.Directory  main :: IO ()@@ -67,7 +68,7 @@       , shapePic (apexAnchor >=> bottomCorners) $ semiellipse 100 150)      , ( "trapezium"       ,  shapePic (bottomCorners >=> topCorners >=> midPoints 4) $ -          ztrapezium 300 150)+          trapezium 300 200 150)     , ( "triangle"       , shapePic (apexAnchor >=> bottomCorners >=> midPoints 3) $            triangle 300 150 )@@ -154,7 +155,8 @@     return ()       where     shape   = strokedShape $ setDecoration textF sh-    textF   = lift1R2 $ locGraphic_ (startAddr (multiAlignCenter name) CENTER)+    textF   = promoteLocTheta $ \pt _ -> +                ignoreAns (multiAlignCenter name CENTER) `at` pt      deg10   = d2r (10::Double)     deg110  = d2r (110::Double)@@ -171,19 +173,19 @@  label :: (Real u, Floating u, InterpretUnit u)        => Cardinal -> String -> LocGraphic u-label cpos ss = markX `oplus` msg+label cpos ss = dotX `mappend` msg   where     (rpos,fn)     = go cpos-    msg           = locGraphic_ $ moveStart (fn 10) $ -                       startAddr (multiAlignCenter ss) rpos+    msg           = ignoreAns $ moveStart (fn 10) $ +                       multiAlignCenter ss rpos -    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)+    go NORTH      = (SS, go_north)+    go NORTH_EAST = (SW, go_north_east)+    go EAST       = (WW, go_east) +    go SOUTH_EAST = (NW, go_south_east)+    go SOUTH      = (NN, go_south)+    go SOUTH_WEST = (NE, go_south_west)+    go WEST       = (EE, go_west)+    go NORTH_WEST = (SE, go_north_west)    

@@ -5,7 +5,7 @@   import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Dots.Marks+import Wumpus.Drawing.Dots.SimpleDots import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -62,9 +62,9 @@     draw $ redPlus `at` P2 200 0    where-    fn addr obj = illustrateBoundedLocGraphic (runPosObjectR2 obj `startAddr` addr)+    fn addr obj = illustrateBoundedLocGraphic $ (runPosObject addr obj)   redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u-redPlus = localize (stroke_colour red) markPlus+redPlus = localize (stroke_colour red) dotPlus 

@@ -12,6 +12,7 @@  import Wumpus.Core                              -- package: wumpus-core +import Data.Monoid import System.Directory  @@ -52,9 +53,9 @@       testDraw :: RectAddress -> LocGraphic Double-testDraw rpos = filledDisk 2 `oplus` (locGraphic_ ans)+testDraw rpos = dcDisk FILL 2 `mappend` (ignoreAns ans)   where-    ans = textline "Qwerty" `startAddr` rpos+    ans = textline "Qwerty" rpos   

@@ -36,8 +36,8 @@   where     chn_alg         = tableDown 30 (100,20)      start           = P2 0 (30*20)-    sdraw (s,_)     = plainTextLine s-    ldraw (_,name)  = moveStart (displaceH 16) (plainTextLine name)+    sdraw (s,_)     = dcTextlabel s+    ldraw (_,name)  = moveStart (hvec 16) (dcTextlabel name)   all_letters :: [(String, String)]

@@ -1,26 +0,0 @@-{-# OPTIONS -Wall #-}--module TableChains where---import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Extras.Grids--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Core                              -- package: wumpus-core--import System.Directory--main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx table_drawing-    writeEPS "./out/table_chains01.eps" pic1-    writeSVG "./out/table_chains01.svg" pic1--std_ctx :: DrawingContext-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)

@@ -0,0 +1,136 @@+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.DrawingPrimitives+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Alternative to the @DrawingPrimitives@ module in Wumpus-Basic.+-- +-- The drawing primitives here are either slightly higher level or+-- less general (more quirky).+--+-- This module is expected to be imported qualified - other modules+-- (e.g. shapes and paths) are likely to export conflicting names.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.DrawingPrimitives+  (+++  -- * Lines++    hline+  , vline+  , pivotLine++  -- * Rectangles+  , blRectangle+  , ctrRectangle+++  -- * Arc and wedge+  , arc+  , wedge++  )++  where++import Wumpus.Basic.Geometry                    -- package: wumpus-basic+import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++--------------------------------------------------------------------------------+-- Lines++-- | Draw a vertical line.+-- +vline :: InterpretUnit u => u -> LocGraphic u +vline len = locStraightLine $ vvec len++-- | Draw a horizontal line.+-- +hline :: InterpretUnit u => u -> LocGraphic u +hline len = locStraightLine $ hvec len++++-- | @pivotLine@ : @ left_length * right_length * incline -> LocGraphic @+--+-- Draw a /pivot/ line. The start point is a pivot along the line, +-- not the end. The left and right distances are the extension of+-- the line from the pivot. +--+pivotLine :: (Floating u, InterpretUnit u) => u -> u -> Radian -> LocGraphic u+pivotLine lu ru ang = promoteLoc $ \pt -> +    straightLine (pt .+^ avec (ang+pi) lu) (pt .+^ avec ang ru)+++--------------------------------------------------------------------------------+-- Rectangles++++-- | Draw a rectangle, start point is bottom left.+--+blRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u+blRectangle = dcRectangle+++-- | Draw a rectangle, start point is bottom left.+--+ctrRectangle :: (Fractional u, InterpretUnit u) +             => DrawStyle -> u -> u -> LocGraphic u+ctrRectangle sty w h = +    moveStart (vec (-hw) (-hh)) $ dcRectangle sty w h+  where+    hw = 0.5 * w+    hh = 0.5 * h+++++--------------------------------------------------------------------------------+-- Wedge+++-- | arc : radius * apex_angle+-- +arc :: (Floating u, InterpretUnit u) => u -> Radian -> LocThetaGraphic u+arc radius ang = promoteLocTheta $ \pt inclin -> +    let ps = bezierArcPoints ang radius inclin pt+    in zapQuery (curvePP ps) >>= dcOpenPath++-- | wedge : radius * apex_angle+-- +wedge :: (Floating u, InterpretUnit u) +      => DrawStyle -> u -> Radian -> LocThetaGraphic u+wedge sty radius ang = promoteLocTheta $ \pt inclin -> +    let ps = bezierArcPoints ang radius inclin pt+    in uconvertCtxF pt      >>= \dpt -> +       mapM uconvertCtxF ps >>= \dps -> +       dcClosedPath sty (build dpt dps)+  where+    -- Note - this relies on an implicit straight line cycle back +    -- to the start point.+    --+    build :: DPoint2 -> [DPoint2] -> PrimPath+    build pt []         = emptyPrimPath pt+    build pt (p1:ps)    = let cs = curves ps+                          in absPrimPath pt (absLineTo p1 : cs)+    +    curves (a:b:c:ps)   = absCurveTo a b c : curves ps+    curves _            = []+    

@@ -0,0 +1,252 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.LocTrace+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Writer monad with imperative /turtle/ style movement to build +-- LocGraphics.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.LocTrace+  (++  -- * LocTrace monads+    LocTrace+  , LocTraceT++  , runLocTrace+  , evalLocTrace+  , execLocTrace++  , runLocTraceT+  , evalLocTraceT+  , execLocTraceT++  , liftLocTraceT++  -- * LocTrace classes+  , LocTraceM(..)+  , LocForkTraceM(..)++  -- * Derived operations+  , hmoveBy+  , vmoveBy++  )++  where++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.VectorSpace                         -- package: vector-space++import Control.Applicative+import Control.Monad+import Data.Monoid++-- | LocTrace is a writer state monad.+--+-- The writer accumulates a LocGraphic the state is a cumulative+-- displacement vector (called a cursor below).+--+newtype LocTrace u a = LocTrace { +          getLocTrace :: Vec2 u -> (a, Vec2 u, LocGraphic u )}+++type instance DUnit (LocTrace u a) = u+++-- Do we need a transformer version +-- | LocTrace is a writer state monad.+--+-- The writer accumulates a LocGraphic the state is a cumulative+-- displacement vector.+--+newtype LocTraceT u m a = LocTraceT { +          getLocTraceT :: Vec2 u -> m (a, Vec2 u, LocGraphic u )}+++type instance DUnit (LocTraceT u m a) = u+++type instance MonUnit (LocTrace u a) = u+type instance MonUnit (LocTraceT u m a) = u+++-- Functor++instance Functor (LocTrace u) where+  fmap f ma = LocTrace $ \v0 -> let (a,v1,o) = getLocTrace ma v0+                                in (f a, v1, o)++instance Monad m => Functor (LocTraceT u m) where+  fmap f ma = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,v1,o) -> +                                 return (f a, v1, o)++-- Applicative++instance Applicative (LocTrace u) where+  pure a    = LocTrace $ \v0 -> (a, v0, mempty)+  mf <*> ma = LocTrace $ \v0 -> +                let (f,v1,o1) = getLocTrace mf v0+                    (a,v2,o2) = getLocTrace ma v1+                in (f a, v2, o1 `mappend` o2)+++++instance Monad m => Applicative (LocTraceT u m) where+  pure a    = LocTraceT $ \v0 -> return (a, v0, mempty)+  mf <*> ma = LocTraceT $ \v0 -> +                getLocTraceT mf v0 >>= \(f,v1,o1) ->+                getLocTraceT ma v1 >>= \(a,v2,o2) ->+                return (f a, v2, o1 `mappend` o2)++++-- Monad++instance Monad (LocTrace u) where+  return a  = LocTrace $ \v0 -> (a, v0, mempty)+  ma >>= k  = LocTrace $ \v0 -> +                let (a,v1,o1) = getLocTrace ma v0+                    (b,v2,o2) = (getLocTrace . k) a v1+                in (b, v2, o1 `mappend` o2)++instance Monad m => Monad (LocTraceT u m) where+  return a  = LocTraceT $ \v0 -> return (a, v0, mempty)+  ma >>= k  = LocTraceT $ \v0 -> +                getLocTraceT ma v0 >>= \(a,v1,o1) ->+                (getLocTraceT . k) a v1 >>= \(b,v2,o2) -> +                return (b, v2, o1 `mappend` o2)++++runLocTrace :: Num u => LocTrace u a -> (a, Vec2 u, LocGraphic u)+runLocTrace mf = getLocTrace mf (V2 0 0)+++-- | Forget the generated LocImage, just return the /answer/.+--+evalLocTrace :: Num u => LocTrace u a -> a+evalLocTrace = post . runLocTrace+  where+    post (a,_,_) = a++-- | Forget the /answer/, just return the generated LocImage.+--+execLocTrace :: Num u => LocTrace u a -> LocGraphic u+execLocTrace = post . runLocTrace+  where+    post (_,_,o) = o++++runLocTraceT :: (Monad m, Num u) +             => LocTraceT u m a -> m (a, Vec2 u, LocGraphic u)+runLocTraceT mf = getLocTraceT mf (V2 0 0)+++-- | Forget the generated LocImage, just return the /answer/.+--+evalLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m a+evalLocTraceT = liftM post . runLocTraceT+  where+    post (a,_,_) = a++-- | Forget the /answer/, just return the generated LocImage.+--+execLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m (LocGraphic u)+execLocTraceT = liftM post . runLocTraceT+  where+    post (_,_,o) = o++++liftLocTraceT :: Monad m => m a -> LocTraceT u m a +liftLocTraceT ma = LocTraceT $ \v0 -> +                             ma >>= \a -> return (a,v0,mempty)+++++-- | 'insertl' analogue to Writer monad @tell@.+--+class Monad m => LocTraceM (m :: * -> *) where+  insertl   :: MonUnit (m ()) ~ u => LocGraphic u -> m ()+  insertl_  :: MonUnit (m ()) ~ u => LocImage u a -> m ()+  +  moveBy    :: MonUnit (m ()) ~ u => Vec2 u -> m ()+  location  :: MonUnit (m ()) ~ u => m (Vec2 u)+++  insertl_ = insertl . ignoreAns ++++-- Note - @reset@ steals a too general name. +-- It needs changing...++-- | Add operations for branching (fork at the current point)+-- and resetting to the start point.+-- +-- Not all drawings that support tracing support branching. For+-- instance Paths can be built by tracing but they always need +-- a cumulative progression of /next point/ they cannot resrt to +-- the start point and go in a differnt direction.+-- +class LocTraceM m => LocForkTraceM (m :: * -> *) where+  reset     :: m ()++  -- Branch is like @local@ in the Reader monad.+  branch    :: m a -> m a+++++instance Num u => LocTraceM (LocTrace u) where+  insertl gf  = LocTrace $ \v0 -> ((), v0, moveStart v0 gf)+  moveBy v    = LocTrace $ \v0 -> ((), v0 ^+^ v, mempty)+  location    = LocTrace $ \v0 -> (v0, v0, mempty)++instance Num u => LocForkTraceM (LocTrace u) where+  reset       = LocTrace $ \_  -> ((), V2 0 0, mempty)+  branch ma   = LocTrace $ \v0 -> let (a,_,o) = getLocTrace ma v0 in (a,v0,o)+  ++instance (Monad m, Num u) => LocTraceM (LocTraceT u m) where+  insertl gf  = LocTraceT $ \v0 -> return ((), v0, moveStart v0 gf)+  moveBy v    = LocTraceT $ \v0 -> return ((), v0 ^+^ v, mempty)+  location    = LocTraceT $ \v0 -> return (v0, v0, mempty)++instance (LocTraceM m, Num u) => LocForkTraceM (LocTraceT u m) where+  reset       = LocTraceT $ \_  -> return ((), V2 0 0, mempty)+  branch ma   = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,_,o) -> +                                   return (a,v0,o)+++--------------------------------------------------------------------------------+-- Derived operations+++-- | Move the /cursor/ horizontally.+--+hmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m ()+hmoveBy dx = moveBy (hvec dx)++-- | Move the /cursor/ vertically.+--+vmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m ()+vmoveBy dx = moveBy (vvec dx)

@@ -0,0 +1,297 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.RefTrace+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Writer monad with imperative /turtle/ style movement to build +-- LocGraphics and /references/ allowing connectors between +-- objects.+--+-- Note - references are not /feedback/. Subsequent nodes cannot+-- be place at anchors of previous nodes - anchors only allow+-- connectors to be drawn between located nodes.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.RefTrace+  (++    -- * Re-exports+    LocTraceM(..)++  , RefTrace+  , RefTraceT++  , Ref+  , RefTraceM(..)++  , runRefTrace+  , runRefTraceT++  , unaryLink+  , binaryLink+  , multiwayLink+  )++  where++import Wumpus.Drawing.Basis.LocTrace++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import qualified Wumpus.Basic.Utils.JoinList as JL++import Wumpus.Core                              -- package: wumpus-core++import Data.VectorSpace                         -- package: vector-space++import Control.Applicative+import Control.Monad+import qualified Data.IntMap as IntMap+import Data.Maybe+import Data.Monoid+++++newtype RefTrace u z a = RefTrace { +          getRefTrace :: RefSt u z -> (a, RefSt u z) }+++type instance MonUnit (RefTrace u z a) = u++newtype RefTraceT u z m a = RefTraceT { +          getRefTraceT :: RefSt u z -> m (a, RefSt u z) }+++type instance MonUnit (RefTraceT u z m a) = u+++newtype Ref = Ref { getRefUid :: Int }+++-- GRAPHIC or LOC_GRAPHIC?   cf. connectors...+--+-- TODO - make this an newtype and only export an arity family of +-- constructors.+-- +-- Maybe we only support the arity2 (connector) and list (path) cases?+--+-- type Elaboration u ans = IntMap.IntMap ans -> Graphic u++data LinkRef u ans = +      Unary { refU    :: Ref +            , ancrU   :: ans -> Point2 u+            , drawU   :: LocGraphic u +            }+    | Binary { refB1  :: Ref +             , refB2  :: Ref +             , ancrB1 :: ans -> Point2 u+             , ancrB2 :: ans -> Point2 u+             , drawB  :: ConnectorGraphic u+             }+    | Multiway { refLs :: [Ref]+               , ancrM :: ans -> Point2 u+               , drawM :: [Point2 u] -> Graphic u+               }++data RefSt u z = RefSt +      { uid_count       :: Int+      , current_tip     :: Vec2 u+      , ref_acc         :: LocImage u (IntMap.IntMap z)+      , ref_links       :: JL.JoinList (LinkRef u z)+      }++++type instance DUnit (RefSt u z) = u++type RefStF u z = RefSt u z -> RefSt u z +++zeroRefSt :: Num u => RefSt u z+zeroRefSt = RefSt { uid_count   = 0+                  , current_tip = V2 0 0+                  , ref_acc     = mempty+                  , ref_links   = mempty      +                  }+++++-- Functor++instance Functor (RefTrace u z) where+  fmap f ma = RefTrace $ \s0 -> let (a,s1) = getRefTrace ma s0 in (f a, s1)++instance Monad m => Functor (RefTraceT u z m) where+  fmap f ma = RefTraceT $ \s0 -> getRefTraceT ma s0 >>= \(a,s1) ->+                                 return (f a, s1)++++-- Applicative++instance Applicative (RefTrace u z) where+  pure a    = RefTrace $ \s0 -> (a, s0)+  mf <*> ma = RefTrace $ \s0 -> +                let (f,s1) = getRefTrace mf s0+                    (a,s2) = getRefTrace ma s1+                in (f a, s2)++++instance Monad m => Applicative (RefTraceT u z m) where+  pure a    = RefTraceT $ \s0 -> return (a, s0)+  mf <*> ma = RefTraceT $ \s0 -> getRefTraceT mf s0 >>= \(f,s1) -> +                                 getRefTraceT ma s1 >>= \(a,s2) ->+                                 return (f a, s2)++++-- Monad++instance Monad (RefTrace u z) where+  return a  = RefTrace $ \s0 -> (a, s0)+  ma >>= k  = RefTrace $ \s0 -> +                let (a,s1) = getRefTrace ma s0+                in (getRefTrace . k) a s1+++instance Monad m => Monad (RefTraceT u z m) where+  return a  = RefTraceT $ \s0 -> return (a, s0)+  ma >>= k  = RefTraceT $ \s0 -> getRefTraceT ma s0 >>= \(a,s1) ->+                                 (getRefTraceT . k) a s1+                ++++-- LocTraceM++instance Num u => LocTraceM (RefTrace u z) where+  insertl gf  = RefTrace $ \s0 -> ((), insertSt gf s0)+  moveBy v    = RefTrace $ \s0 -> ((), moveSt v s0)+  location    = RefTrace $ \s0 -> (current_tip s0, s0)+++instance (Monad m, Num u) => LocTraceM (RefTraceT u z m) where+  insertl gf  = RefTraceT $ \s0 -> return ((), insertSt gf s0)+  moveBy v    = RefTraceT $ \s0 -> return ((), moveSt v s0)+  location    = RefTraceT $ \s0 -> return (current_tip s0, s0)++++-- Run functions++runRefTrace :: Num u => RefTrace u ans a -> LocImage u a+runRefTrace mf = post $ getRefTrace mf zeroRefSt+  where+    post (a,st) = replaceAns a $ reconcileRefSt st+++runRefTraceT :: (Monad m, Num u) => RefTraceT u ans m a -> m (LocImage u a)+runRefTraceT mf = liftM post $ getRefTraceT mf zeroRefSt+  where+    post (a,st) = replaceAns a $ reconcileRefSt st++++-- Note we have to drop the vector++reconcileRefSt :: RefSt u z -> LocGraphic u+reconcileRefSt st = +    step (ref_acc st) (JL.toList $ ref_links st)+  where+    step img xs = ignoreAns $ elaborate img (\a -> mconcat $ map (fn a) xs)+    +    fn im (Unary r1 ar1 gf) = +      maybe mempty (\pt -> promoteLoc $ \_ -> applyLoc gf pt) (projectRef r1 ar1 im)+   +    fn im (Binary r1 r2 ar1 ar2 conn) = +      case (projectRef r1 ar1 im, projectRef r2 ar2 im) of+        (Just p1, Just p2) -> promoteLoc $ \_ -> applyConn conn p1 p2+        _                  -> mempty+++    fn im (Multiway rs ar1 gf) = +        let ps = catMaybes $ map (\a -> projectRef a ar1 im) rs+        in promoteLoc $ \_ -> gf ps+                                 +++projectRef :: Ref -> (ans -> Point2 u) -> IntMap.IntMap ans -> Maybe (Point2 u)+projectRef r ancr im = ancr <$> IntMap.lookup (getRefUid r) im++-- Note - probably this supports Tree which is not a Trace monad...++class Monad m => RefTraceM (m :: * -> *) where+  type MonRef m :: *+  insertRef   :: (MonRef m ~ a, MonUnit (m ()) ~ u) => LocImage u a -> m Ref+  linkRef     :: (MonRef m ~ a, MonUnit (m ()) ~ u) => LinkRef u a -> m ()++instance Num u => RefTraceM (RefTrace u z) where+  type MonRef (RefTrace u z) = z+  insertRef img = RefTrace $ \s0 -> let (ix,s1) = incrementSt img s0+                                    in (Ref ix, s1)++  linkRef fn    = RefTrace $ \s0 -> ((), snocLink fn s0)  +++moveSt :: Num u => Vec2 u -> RefStF u z +moveSt v = (\s i -> s { current_tip = i ^+^ v }) +             <*> current_tip++insertSt :: Num u => LocImage u z2 -> RefStF u ans+insertSt gf = (\s ac v1 -> let g1 = ignoreAns $ moveStart v1 gf+                           in s { ref_acc = decorate ac g1 }) +                <*> ref_acc <*> current_tip++snocLink :: LinkRef u ans -> RefStF u ans+snocLink fn = (\s i -> s { ref_links = JL.snoc i fn }) +                <*> ref_links+++incrementSt :: Num u +            => LocImage u ans -> RefSt u ans -> (Int, RefSt u ans)+incrementSt img s0 = (uid_count s0, upd s0)+  where+    upd = (\s ac v1 ix -> let img1 = moveStart v1 img+                          in s { ref_acc   = fn ix ac img1+                               , uid_count = ix+1 }) +                <*> ref_acc <*> current_tip <*> uid_count ++    fn ix ac gf = fmap (\(a,b) -> IntMap.insert ix b a) $ both ac gf++++unaryLink :: (ans -> Point2 u) -> LocGraphic u -> Ref -> LinkRef u ans+unaryLink f gf = \r1 -> Unary { refU    = r1+                              , ancrU   = f+                              , drawU   = gf+                              }++binaryLink :: (ans -> Point2 u) -> (ans -> Point2 u) +           -> ConnectorGraphic u -> Ref -> Ref +           -> LinkRef u ans+binaryLink f g conn = \r1 r2 -> Binary { refB1  = r1+                                       , refB2  = r2 +                                       , ancrB1 = f+                                       , ancrB2 = g+                                       , drawB  = conn+                                       }+++multiwayLink :: (ans -> Point2 u) -> ([Point2 u] -> Graphic u) -> [Ref] +             -> LinkRef u ans+multiwayLink f gf = \rs -> Multiway { refLs = rs+                                    , ancrM = f+                                    , drawM = gf+                                    }

@@ -0,0 +1,168 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.TraceGraphic+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Build multi-part Graphics with an accumulator (i.e. a Writer +-- monad).+--+-- Note - the run functions for the transformer and the plain+-- monad are quite different. This is mandated by the need to  +-- single-thread the DrawingContext through the transformer.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.TraceGraphic+  (+    TraceGraphic+  , TraceGraphicT++  , TraceGraphicM(..)++  , runTraceGraphic+  , runTraceGraphicT++  , liftTraceGraphicT++  ) where+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Control.Applicative+import Data.Monoid++++newtype TraceGraphic u a = TraceGraphic { +    getTraceGraphic :: DrawingContext -> (a, CatPrim) }+++newtype TraceGraphicT u m a = TraceGraphicT { +    getTraceGraphicT :: DrawingContext -> m (a, CatPrim) }+++type instance MonUnit (TraceGraphic u a)    = u+type instance MonUnit (TraceGraphicT u m a) = u+++-- Functor++instance Functor (TraceGraphic u) where+  fmap f ma = TraceGraphic $ \ctx -> let (a,w1) = getTraceGraphic ma ctx+                                     in (f a,w1)+++instance Monad m => Functor (TraceGraphicT u m) where+  fmap f ma = TraceGraphicT $ \ctx -> getTraceGraphicT ma ctx >>= \(a,w1) -> +                                      return (f a,w1)+++-- Applicative++instance Applicative (TraceGraphic u) where+  pure a    = TraceGraphic $ \_   -> (a, mempty)+  mf <*> ma = TraceGraphic $ \ctx -> +                let (f,w1) = getTraceGraphic mf ctx+                    (a,w2) = getTraceGraphic ma ctx+                in (f a,w1 `mappend` w2)+++instance Monad m => Applicative (TraceGraphicT u m) where+  pure a    = TraceGraphicT $ \_   -> return (a, mempty)+  mf <*> ma = TraceGraphicT $ \ctx -> +                getTraceGraphicT mf ctx >>= \(f,w1) ->+                getTraceGraphicT ma ctx >>= \(a,w2) -> +                return (f a,w1 `mappend` w2)++++-- Monad++instance Monad (TraceGraphic u) where+  return a  = TraceGraphic $ \_   -> (a, mempty)+  ma >>= k  = TraceGraphic $ \ctx -> +                let (a,w1) = getTraceGraphic ma ctx+                    (b,w2) = (getTraceGraphic . k) a ctx+                in (b, w1 `mappend` w2)+               ++instance Monad m => Monad (TraceGraphicT u m) where+  return a  = TraceGraphicT $ \_   -> return (a, mempty)+  ma >>= k  = TraceGraphicT $ \ctx -> +                getTraceGraphicT ma ctx      >>= \(a,w1) -> +                (getTraceGraphicT . k) a ctx >>= \(b,w2) -> +                return (b, w1 `mappend` w2)+               +++-- DrawingCtxM++instance DrawingCtxM (TraceGraphic u) where+  askDC           = TraceGraphic $ \ctx -> (ctx, mempty)+  asksDC f        = TraceGraphic $ \ctx -> (f ctx, mempty)+  localize upd ma = TraceGraphic $ \ctx -> getTraceGraphic ma (upd ctx)++++instance Monad m => DrawingCtxM (TraceGraphicT u m) where+  askDC           = TraceGraphicT $ \ctx -> return (ctx, mempty)+  asksDC f        = TraceGraphicT $ \ctx -> return (f ctx, mempty)+  localize upd ma = TraceGraphicT $ \ctx -> getTraceGraphicT ma (upd ctx)++++-- TraceGraphicM++class Monad m => TraceGraphicM m where+  tellImage   :: MonUnit (m ()) ~ u => Image u a -> m a+  tellImage_  :: MonUnit (m ()) ~ u => Image u a -> m ()++  tellImage_ ma = tellImage ma >> return ()+++instance TraceGraphicM (TraceGraphic u) where+  tellImage  img = TraceGraphic $ \ctx -> +                     let (PrimW o a) = runImage ctx img in (a,o)++  tellImage_ img = TraceGraphic $ \ctx -> +                     let (PrimW o _) = runImage ctx img in ((),o)+++instance Monad m => TraceGraphicM (TraceGraphicT u m) where+  tellImage  img = TraceGraphicT $ \ctx ->  +                     let (PrimW o a) = runImage ctx img in return (a,o) ++  tellImage_ img = TraceGraphicT $ \ctx -> +                     let (PrimW o _) = runImage ctx img in return ((),o)+++runTraceGraphic :: TraceGraphic u a -> Image u a+runTraceGraphic mf = askDC >>= \ctx -> let (a,o) = getTraceGraphic mf ctx+                                       in replaceAns a $ primGraphic o+++-- | Note - this needs DrawingContext as an explicit parameter,+-- and hence it returns a pair of @(a, HPrim u)@ rather than an+-- Image.+--+-- It is expected this will be wrapped in to form a specific+-- TraceDrawing /draw/ function for the amalgamated monad.+-- +runTraceGraphicT :: Monad m +                 => DrawingContext -> TraceGraphicT u m a -> m (a, HPrim u)+runTraceGraphicT ctx mf = +    getTraceGraphicT mf ctx >>= \(a,o) -> return (a, singleH o)+++liftTraceGraphicT :: Monad m => m a -> TraceGraphicT u m a +liftTraceGraphicT ma = TraceGraphicT $ \_ -> ma >>= \a -> return (a,mempty)+

@@ -20,7 +20,6 @@   , module Wumpus.Drawing.Connectors.Base   , module Wumpus.Drawing.Connectors.BoxConnectors   , module Wumpus.Drawing.Connectors.ConnectorPaths-  , module Wumpus.Drawing.Connectors.Loop    ) where @@ -28,4 +27,3 @@ import Wumpus.Drawing.Connectors.Base import Wumpus.Drawing.Connectors.BoxConnectors import Wumpus.Drawing.Connectors.ConnectorPaths-import Wumpus.Drawing.Connectors.Loop

@@ -69,7 +69,6 @@ import Data.AffineSpace                         -- package: vector-space import Data.VectorSpace -import Control.Applicative   @@ -85,20 +84,23 @@  filledTipPath :: PointGen -> LocThetaGraphic En filledTipPath fn = -    localize fill_use_stroke_colour $ promoteR2 $ \pt theta ->-      let vs = fn theta in vertexPP (map (pt .+^) vs) >>= filledPath+    localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta ->+      let vs = fn theta +      in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcClosedPath FILL   closedTipPath :: PointGen -> LocThetaGraphic En closedTipPath fn = -    localize solid_stroke_tip $ promoteR2 $ \pt theta ->-      let vs = fn theta in vertexPP (map (pt .+^) vs) >>= closedStroke+    localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->+      let vs = fn theta +      in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcClosedPath STROKE   openTipPath :: PointGen -> LocThetaGraphic En openTipPath fn = -    localize solid_stroke_tip $ promoteR2 $ \pt theta ->-      let vs = fn theta in vertexPP (map (pt .+^) vs) >>= openStroke+    localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->+      let vs = fn theta +      in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcOpenPath   @@ -145,9 +147,6 @@   -zeroVec :: Vec2 En-zeroVec = V2 0 0 - ang90 :: Radian ang90 = pi / 2 @@ -158,153 +157,165 @@ 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 :: Radian -> ArrowTip filledTri ang = -    makeArrowTip retract_one len_one (filledTipPath spec)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = filledTipPath spec+      }   where     spec theta = let (v1,v2) = tripointsFromTip 1 ang theta                   in [zeroVec, v1, v2] --tri90 :: InterpretUnit u => ArrowTip u+-- | Filled triangle - apex is 90 deg.+--+tri90 :: ArrowTip tri90 = filledTri ang90 -tri60 :: InterpretUnit u => ArrowTip u+-- | Filled triangle - apex is 60 deg.+--+tri60 :: ArrowTip tri60 = filledTri ang60 -tri45 :: InterpretUnit u => ArrowTip u+-- | Filled triangle - apex is 45 deg.+--+tri45 :: ArrowTip tri45 = filledTri ang45  -strokedClosedTri :: InterpretUnit u => Radian -> ArrowTip u+strokedClosedTri :: Radian -> ArrowTip strokedClosedTri ang = -    makeArrowTip retract_one len_one (closedTipPath spec)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = closedTipPath spec+      }   where     spec theta = let (v1,v2) = tripointsFromTip 1 ang theta                   in [zeroVec, v1, v2]  -otri90 :: InterpretUnit u => ArrowTip u+otri90 :: ArrowTip otri90 = strokedClosedTri ang90 -otri60 :: InterpretUnit u => ArrowTip u+otri60 :: ArrowTip otri60 = strokedClosedTri ang60 -otri45 :: InterpretUnit u => ArrowTip u+otri45 :: ArrowTip otri45 = strokedClosedTri ang45  -filledRevTri :: InterpretUnit u => Radian -> ArrowTip u+filledRevTri :: Radian -> ArrowTip filledRevTri ang = -    makeArrowTip retract_one len_one (filledTipPath spec)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = filledTipPath spec+      }   where     spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta                   in [v0, v1, v2] -revtri90 :: InterpretUnit u => ArrowTip u+revtri90 :: ArrowTip revtri90 = filledRevTri ang90 -revtri60 :: InterpretUnit u => ArrowTip u+revtri60 :: ArrowTip revtri60 = filledRevTri ang60 -revtri45 :: InterpretUnit u => ArrowTip u+revtri45 :: ArrowTip revtri45 = filledRevTri ang45  -strokedClosedRevTri :: InterpretUnit u => Radian -> ArrowTip u+strokedClosedRevTri :: Radian -> ArrowTip strokedClosedRevTri ang = -    makeArrowTip retract_one len_one (closedTipPath spec)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = closedTipPath spec+      }   where     spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta                   in [v0, v1, v2]  -orevtri90 :: InterpretUnit u => ArrowTip u+orevtri90 :: ArrowTip orevtri90 = strokedClosedRevTri ang90 -orevtri60 :: InterpretUnit u => ArrowTip u+orevtri60 :: ArrowTip orevtri60 = strokedClosedRevTri ang60 -orevtri45 :: InterpretUnit u => ArrowTip u+orevtri45 :: ArrowTip orevtri45 = strokedClosedRevTri ang45   -strokedBarb :: InterpretUnit u => Radian -> ArrowTip u+strokedBarb :: Radian -> ArrowTip strokedBarb ang = -    makeArrowTip retract_zero len_one (openTipPath spec)+    ArrowTip+      { retract_distance = const 0+      , tip_half_len     = 0.5+      , tip_deco         = openTipPath spec+      }   where     spec theta = let (v1,v2) = tripointsFromTip 1 ang theta                   in [v1,zeroVec,v2]  -barb90 :: InterpretUnit u => ArrowTip u+barb90 :: ArrowTip barb90 = strokedBarb ang90 -barb60 :: InterpretUnit u => ArrowTip u+barb60 :: ArrowTip barb60 = strokedBarb ang60 -barb45 :: InterpretUnit u => ArrowTip u+barb45 :: ArrowTip barb45 = strokedBarb ang45  -strokedRevBarb :: InterpretUnit u => Radian -> ArrowTip u+strokedRevBarb :: Radian -> ArrowTip strokedRevBarb ang = -    makeArrowTip retract_one len_one (openTipPath spec)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = openTipPath spec+      }   where     spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta                   in [v1,v0,v2] -revbarb90 :: InterpretUnit u => ArrowTip u+revbarb90 :: ArrowTip revbarb90 = strokedRevBarb ang90 -revbarb60 :: InterpretUnit u => ArrowTip u+revbarb60 :: ArrowTip revbarb60 = strokedRevBarb ang60 -revbarb45 :: InterpretUnit u => ArrowTip u+revbarb45 :: ArrowTip revbarb45 = strokedRevBarb ang45   -perp :: InterpretUnit u => ArrowTip u+perp :: ArrowTip perp = -    makeArrowTip retract_zero len_zero (openTipPath spec)+    ArrowTip+      { retract_distance = const 0+      , tip_half_len     = 0+      , tip_deco         = 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 :: ArrowTip bracket = -    makeArrowTip retract_zero len_half (openTipPath spec)+    ArrowTip+      { retract_distance = const 0+      , tip_half_len     = 0.5+      , tip_deco         = openTipPath spec+      }   where     spec theta = let oa = avec (theta + ang90) 0.5                      ob = avec (theta - ang90) 0.5@@ -313,26 +324,32 @@   -diskTip :: InterpretUnit u => ArrowTip u+diskTip :: ArrowTip diskTip = -    makeArrowTip retract_one len_one  -                 (promoteR2 $ \pt theta -> body theta `at` pt)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = promoteLocTheta $ \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)+                      moveStart v1 (dcDisk FILL 0.5)  -odiskTip :: InterpretUnit u => ArrowTip u+odiskTip :: ArrowTip odiskTip = -    makeArrowTip retract_one len_one -                 (promoteR2 $ \pt theta -> body theta `at` pt)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = promoteLocTheta $ \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)+                      moveStart v1 (dcDisk STROKE 0.5)   -- | squareSpec:@@ -352,13 +369,21 @@     ov = avec theta (-1)      -squareTip :: InterpretUnit u => ArrowTip u+squareTip :: ArrowTip squareTip = -    makeArrowTip retract_one len_one (filledTipPath squareSpec)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = filledTipPath squareSpec+      } -osquareTip :: InterpretUnit u => ArrowTip u+osquareTip :: ArrowTip osquareTip = -    makeArrowTip retract_one len_one (closedTipPath squareSpec)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = closedTipPath squareSpec+      }   @@ -380,22 +405,38 @@     ob = ov ^+^ avec (theta - ang90) 0.5  -diamondTip :: InterpretUnit u => ArrowTip u+diamondTip :: ArrowTip diamondTip = -    makeArrowTip retract_one len_one (filledTipPath $ diamondSpec 1)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = filledTipPath (diamondSpec 1)+      } -odiamondTip :: InterpretUnit u => ArrowTip u+odiamondTip :: ArrowTip odiamondTip = -    makeArrowTip retract_one len_one (closedTipPath $ diamondSpec 1)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = closedTipPath (diamondSpec 1)+      }  -diamondWideTip :: InterpretUnit u => ArrowTip u+diamondWideTip :: ArrowTip diamondWideTip = -    makeArrowTip retract_two len_two (filledTipPath $ diamondSpec 2)+    ArrowTip+      { retract_distance = const 2+      , tip_half_len     = 1.0+      , tip_deco         = filledTipPath (diamondSpec 2)+      } -odiamondWideTip :: InterpretUnit u => ArrowTip u+odiamondWideTip :: ArrowTip odiamondWideTip = -    makeArrowTip retract_two len_two (closedTipPath $ diamondSpec 2)+    ArrowTip+      { retract_distance = const 2+      , tip_half_len     = 1.0+      , tip_deco         = closedTipPath (diamondSpec 2)+      }   curveTipPath :: Point2 En -> Radian -> AbsPath En@@ -410,12 +451,17 @@     (y,z) = trapezoidFromBasePoints 0.125 0.5 x pt  -curveTip :: InterpretUnit u => ArrowTip u+curveTip :: ArrowTip curveTip = -    makeArrowTip retract_zero len_one-                 (promoteR2 $ \pt theta -> -                    localize (join_bevel . solid_stroke_tip) $ -                      toPrimPath (curveTipPath pt theta) >>= openStroke)+    ArrowTip+      { retract_distance = const 0+      , tip_half_len     = 0.5+      , tip_deco         = body+      }+  where+    body = promoteLocTheta $ \pt theta -> +             localize (join_bevel . solid_stroke_tip) $ +               zapQuery (toPrimPath $ curveTipPath pt theta) >>= dcOpenPath   @@ -431,12 +477,17 @@     (z,y) = trapezoidFromBasePoints 0.125 0.5 p2 x  -revcurveTip :: InterpretUnit u => ArrowTip u+revcurveTip :: ArrowTip revcurveTip = -    makeArrowTip retract_one len_one-                 (promoteR2 $ \pt theta -> -                    localize (join_bevel . solid_stroke_tip) $ -                      toPrimPath (curveTipRevPath pt theta) >>= openStroke)+    ArrowTip+      { retract_distance = const 1+      , tip_half_len     = 0.5+      , tip_deco         = body+      }+  where+    body = promoteLocTheta $ \pt theta -> +             localize (join_bevel . solid_stroke_tip) $ +               zapQuery (toPrimPath $ curveTipRevPath pt theta) >>= dcOpenPath       @@ -458,7 +509,7 @@     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+    base_mid  = dispParallel (0.5 * base_len) theta p1+    ubase_mid = dispPerpendicular u theta base_mid+    cp1       = dispParallel (-half_ulen) theta ubase_mid+    cp2       = dispParallel   half_ulen  theta ubase_mid

@@ -18,16 +18,19 @@   (       Connector    ++  , ArrowTip(..)   , ArrowConnector-  , ArrowTip-  , makeArrowTip    , leftArrow   , rightArrow     , leftRightArrow   , uniformArrow  ++  , rightArrowPath+   -  , promoteConn+  , buildConn    ) where @@ -39,91 +42,143 @@  import Data.AffineSpace                         -- package: vector-space --import Control.Applicative-+import Data.Monoid  -- | The type of Connectors - a query from start and end point to  -- a Path. -- type Connector u = ConnectorQuery u (AbsPath u) +-- | Arrowhead /algorithm/ - the components of an arrowhead.+-- +-- Retract distance may have to account for line width.+--+data ArrowTip = ArrowTip+      { retract_distance :: Double -> En+      , tip_half_len     :: En+      , tip_deco         :: LocThetaGraphic En+      } +-- Ideally there should be a plus operation to combine tips +-- allowing double tips.+--   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) +runArrowTip :: InterpretUnit u => ArrowTip -> Query u (u, u, LocThetaGraphic u)+runArrowTip (ArrowTip df len deco) = +   getLineWidth             >>= \lw    -> +   uconvertCtx1 (df lw)     >>= \uretd ->+   uconvertCtx1 len         >>= \ulen  ->+   return (uretd, ulen, uconvF deco) -data ArrowTip u = ArrowTip { getArrowTip :: CF (TipAns u) } +-- | Connector with an arrow tip at the end point (i.e right).+--+rightArrow :: (Real u, Floating u, InterpretUnit u) +            => ArrowTip -> Connector u -> ArrowConnector u+rightArrow alg conn = promoteConn $ \p0 p1 ->+    zapConnectorQuery conn p0 p1 >>= \full_path -> +    rightArrowPath alg full_path     -- | 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+            => ArrowTip -> Connector u -> ArrowConnector u+leftArrow alg conn = promoteConn $ \p0 p1 ->+    zapConnectorQuery conn p0 p1 >>= \full_path -> +    leftArrowPath alg full_path   --- | Connector with two arrow tips, possibly different.+-- | Connector with different arrow tips at the start point and +-- end points. -- 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+               => ArrowTip -> ArrowTip ->  Connector u -> ArrowConnector u+leftRightArrow algl algr conn = promoteConn $ \p0 p1 ->+    zapConnectorQuery conn p0 p1 >>= \full_path -> +    leftRightArrowPath algl algr full_path   --- | Connector with the same arrow tip at both ends.++-- | Connector with the same arrow tip at the start point and +-- end points. -- uniformArrow :: (Real u, Floating u, InterpretUnit u) -             => ArrowTip u -> Connector u -> ArrowConnector u-uniformArrow utip conn = leftRightArrow utip utip conn+               => ArrowTip ->  Connector u -> ArrowConnector u+uniformArrow alg conn = promoteConn $ \p0 p1 ->+    zapConnectorQuery conn p0 p1 >>= \full_path -> +    leftRightArrowPath alg alg full_path    +-- TODO - possible there are opportunities to be more +-- compositional here. -convertTipAns :: InterpretUnit u => GraphicAns En -> Graphic u-convertTipAns = uconvImageF . pure  +-- | Path with an arrow tip at the start point (i.e left).+--+-- TODO - shortening a curve does not seem to be working properly...+-- +--+leftArrowPath :: (Real u, Floating u, InterpretUnit u) +              => ArrowTip -> AbsPath u -> Image u (AbsPath u)+leftArrowPath alg full_path =+    zapQuery (runArrowTip alg) >>= \(retract, len, deco) -> +    let short_path      = if retract > 0 then shortenL retract full_path +                                         else full_path+        mid_ang         = tipDirectionL len full_path+        tip             = applyLocTheta deco (tipL full_path) mid_ang+    in replaceAns full_path $ +         decorate tip $ zapQuery (toPrimPath short_path) >>= dcOpenPath++++-- | Path with an arrow tip at the end point (i.e right).+--+-- TODO - shortening a curve does not seem to be working properly...+-- +--+rightArrowPath :: (Real u, Floating u, InterpretUnit u) +               => ArrowTip -> AbsPath u -> Image u (AbsPath u)+rightArrowPath alg full_path =+    zapQuery (runArrowTip alg) >>= \(retract, len, deco) -> +    let short_path      = if retract > 0 then shortenR retract full_path +                                         else full_path+        mid_ang         = tipDirectionR len full_path+        tip             = applyLocTheta deco (tipR full_path) mid_ang+    in replaceAns full_path $ +         decorate tip $ zapQuery (toPrimPath short_path) >>= dcOpenPath+++++-- | Path with an arrow tip at the end point (i.e right).+--+-- TODO - shortening a curve does not seem to be working properly...+-- +--+leftRightArrowPath :: (Real u, Floating u, InterpretUnit u) +                   => ArrowTip -> ArrowTip -> AbsPath u -> Image u (AbsPath u)+leftRightArrowPath algl algr full_path =+    zapQuery (runArrowTip algl) >>= \(retractl, lenl, decol) -> +    zapQuery (runArrowTip algr) >>= \(retractr, lenr, decor) -> +    let short_path      = shortenPath retractl retractr full_path+        mid_angl        = tipDirectionL lenl full_path+        mid_angr        = tipDirectionR lenr full_path+        tipl            = applyLocTheta decol (tipL full_path) mid_angl+        tipr            = applyLocTheta decor (tipR full_path) mid_angr+    in replaceAns full_path $ +         decorate (tipl `mappend` tipr) $ +            zapQuery (toPrimPath short_path) >>= dcOpenPath++++ -- | Helper - direction looks best at half the retract distance. -- tipDirectionL :: (Real u, Floating u) => u -> AbsPath u -> Radian@@ -136,37 +191,28 @@      -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 +-- This should be used instead of @promoteConn@ 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 -> +buildConn :: (Real u, Floating u, InterpretUnit u) +            => (Point2 u -> Point2 u -> Image u a) +            -> ConnectorImage u a+buildConn fn = promoteConn $ \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)+    in fn (dispPerpendicular off0 ang $ p0 .+^ avec ang sep0) +          (dispPerpendicular off1 ang $ p1 .-^ avec ang sep1)     ----- CAUTION - promoteConn projects the spacers along the (straight)+-- CAUTION - buildConn projects the spacers along the (straight) -- connector line. This might not be what is wanted for jointed -- connectors. -- 

@@ -54,12 +54,12 @@ -- connbox :: (Real u, Floating u, InterpretUnit u)          => ConnectorBox u-connbox = promoteR2 $ \p0 p1 -> +connbox = promoteConn $ \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+        bl  = dispOrtho (V2 (-src_arm) (-src_arm)) ang p0+        tl  = dispOrtho (V2 (-src_arm)   src_arm ) ang p0+        br  = dispOrtho (V2   dst_arm  (-src_arm)) ang p1+        tr  = dispOrtho (V2   dst_arm    src_arm ) ang p1+    in zapQuery (vertexPP [ bl, br, tr, tl ]) >>= dcClosedPath STROKE

@@ -51,7 +51,7 @@ import Wumpus.Drawing.Paths.Absolute  import Wumpus.Basic.Geometry.Quadrant           -- package: wumpus-basic-import Wumpus.Basic.Kernel hiding ( promoteR2 )+import Wumpus.Basic.Kernel hiding ( promoteConn )  import Wumpus.Core                              -- package: wumpus-core @@ -65,7 +65,7 @@ -- | Straight line connector. -- connline :: (Real u, Floating u, InterpretUnit u) => Connector u-connline = promoteConn $ \p0 p1 -> return $ line1 p0 p1+connline = qpromoteConn $ \p0 p1 -> return $ line1 p0 p1   @@ -81,7 +81,7 @@ -- connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u)          => Connector u-connarc = promoteConn $ \p0 p1 -> +connarc = qpromoteConn $ \p0 p1 ->      connectorArcAngle >>= \arc_ang ->     let v1      = pvec p0 p1         hlen    = 0.5 * vlength v1@@ -104,7 +104,7 @@ --  connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)           => Connector u-connhdiagh = promoteConn $ \p0 p1 -> +connhdiagh = qpromoteConn $ \p0 p1 ->      connectorSrcArm >>= \src_arm ->     connectorDstArm >>= \dst_arm ->     case quadrant $ vdirection $ pvec p0 p1 of@@ -133,7 +133,7 @@ --  connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)           => Connector u-connvdiagv = promoteConn $ \p0 p1 -> +connvdiagv = qpromoteConn $ \p0 p1 ->      connectorSrcArm >>= \src_arm ->     connectorDstArm >>= \dst_arm ->     case quadrant $ vdirection $ pvec p0 p1 of@@ -161,7 +161,7 @@ --  conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)           => Connector u-conndiagh = promoteConn $ \p0 p1 -> +conndiagh = qpromoteConn $ \p0 p1 ->      connectorDstArm >>= \dst_arm ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> right p0 p1 dst_arm@@ -186,7 +186,7 @@ --  conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)           => Connector u-conndiagv = promoteConn $ \p0 p1 -> +conndiagv = qpromoteConn $ \p0 p1 ->      connectorDstArm >>= \dst_arm ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> up    p0 p1 dst_arm@@ -211,7 +211,7 @@ --  connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)           => Connector u-connhdiag = promoteConn $ \p0 p1 -> +connhdiag = qpromoteConn $ \p0 p1 ->      connectorSrcArm >>= \src_arm ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> right p0 p1 src_arm@@ -236,7 +236,7 @@ --  connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)           => Connector u-connvdiag = promoteConn $ \p0 p1 -> +connvdiag = qpromoteConn $ \p0 p1 ->      connectorSrcArm >>= \src_arm ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> up    p0 p1 src_arm@@ -263,12 +263,12 @@ -- connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u)           => Connector u-connabar = promoteConn $ \p0 p1 ->+connabar = qpromoteConn $ \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 ]+    in return $ vertexPath [ p0, dispDirectionTheta UP src_arm ang p0+                           , dispDirectionTheta UP dst_arm ang p1, p1 ]   -- | Bar connector.@@ -281,12 +281,12 @@ -- connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u)           => Connector u-connbbar = promoteConn $ \p0 p1 ->+connbbar = qpromoteConn $ \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 ]+    in return $ vertexPath [ p0, dispDirectionTheta DOWN src_arm ang p0+                           , dispDirectionTheta DOWN dst_arm ang p1, p1 ]   @@ -300,7 +300,7 @@ -- connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u)             => Connector u-connaright = promoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->+connaright = qpromoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->     let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1]  @@ -314,7 +314,7 @@ -- connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u)             => Connector u-connbright = promoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) ->+connbright = qpromoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) ->     let mid = P2 x1 y0 in return $ vertexPath [p0, mid, p1]  @@ -341,7 +341,7 @@ -- connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u)          => Connector u-connhrr = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+connhrr = qpromoteConn $ \ 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)@@ -361,7 +361,7 @@ -- connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u)          => Connector u-connrrh = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+connrrh = qpromoteConn $ \ 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)@@ -378,7 +378,7 @@ -- connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u)          => Connector u-connvrr = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+connvrr = qpromoteConn $ \ 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)@@ -395,7 +395,7 @@ -- connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u)          => Connector u-connrrv = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+connrrv = qpromoteConn $ \ 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)@@ -432,15 +432,15 @@ -- loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u)          => (u -> u) -> Connector u-loopbody fn = promoteConn $ \p0 p1 ->+loopbody fn = qpromoteConn $ \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+        a0  = dispParallel (negate src_arm) ang p0+        a1  = dispPerpendicular (fn loop_len) ang a0+        z0  = dispParallel dst_arm ang p1+        z1  = dispPerpendicular (fn loop_len) ang z0     in return $ vertexPath [ p0, a0, a1, z1, z0, p1 ]  -- | Bezier curve connector - the control points are positioned @@ -456,7 +456,7 @@ -- connhbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)             => Connector u-connhbezier = promoteConn $ \p0 p1 -> +connhbezier = qpromoteConn $ \p0 p1 ->      fmap (2*) connectorSrcArm   >>= \src_arm ->     fmap (2*) connectorDstArm   >>= \dst_arm ->     case quadrant $ vdirection $ pvec p0 p1 of@@ -483,7 +483,7 @@ -- connvbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)             => Connector u-connvbezier = promoteConn $ \p0 p1 -> +connvbezier = qpromoteConn $ \p0 p1 ->      fmap (2*) connectorSrcArm   >>= \src_arm ->     fmap (2*) connectorDstArm   >>= \dst_arm ->     case quadrant $ vdirection $ pvec p0 p1 of

@@ -1,86 +0,0 @@-{-# 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,7 +1,4 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -32,6 +29,14 @@   , DDotLocImage    -- * Dots with anchor points+  , smallDisk+  , largeDisk++  , smallCirc+  , largeCirc+++  , dotNone   , dotChar   , dotText   , dotHLine@@ -58,13 +63,11 @@   ) where  -import Wumpus.Drawing.Dots.Marks+import Wumpus.Drawing.Dots.SimpleDots ( MarkSize )+import qualified Wumpus.Drawing.Dots.SimpleDots as SD import Wumpus.Drawing.Text.Base.RotTextZero -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.Geometry                    -- package: wumpus-basic import Wumpus.Basic.Kernel                 import Wumpus.Core                              -- package: wumpus-core@@ -74,17 +77,15 @@  import Control.Applicative --- An existential thing that supports anchors.--- This means any dot can retun the same (opaque) structure------ But it does mean that which anchor class are supported is --- fixed - the datatype needs a field for each one.--- Supporting north, southeast etc. will also be tedious...++-- | All dots return the same thing a 'DotAnchor' which supports +-- the same (limited) see of anchors. ---data DotAnchor u = forall s.  -                    DotAnchor { center_anchor   :: Point2 u-                              , radial_anchor   :: Radian   -> Point2 u-                              , cardinal_anchor :: Cardinal -> Point2 u }+data DotAnchor u = DotAnchor +      { center_anchor   :: Point2 u+      , radial_anchor   :: Radian   -> Point2 u+      , cardinal_anchor :: Cardinal -> Point2 u +      }  type instance DUnit (DotAnchor u) = u @@ -144,16 +145,33 @@ polyCardinal f NORTH_WEST           = f (0.75 * pi)   +-- | All anchors are the center!+--+zeroAnchor :: Point2 u -> DotAnchor u+zeroAnchor ctr = +    DotAnchor { center_anchor   = ctr+              , radial_anchor   = const ctr +              , cardinal_anchor = const ctr } + rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u rectangleAnchor hw hh ctr =      DotAnchor { center_anchor   = ctr               , radial_anchor   = fn                 , cardinal_anchor = rectCardinal hw hh ctr }   where-    fn theta =  displaceVec (rectRadialVector hw hh theta) ctr+    fn theta =  displace (rectRadialVector hw hh theta) ctr  +circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u+circleAnchor rad ctr = +    DotAnchor { center_anchor   = ctr+              , radial_anchor   = fn +              , cardinal_anchor = radialCardinal rad ctr }+  where+    fn theta = displace (avec theta rad) ctr++ polygonAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u)                => [Point2 u] -> Point2 u -> DotAnchor u polygonAnchor ps ctr = @@ -172,33 +190,41 @@        hh = 0.5 * (y2 - y1)    in rectangleAnchor hw hh (bl .+^ vec hw hh) -rectangleLDO :: (Real u, Floating u) -             => u -> u -> LocQuery u (DotAnchor u)-rectangleLDO w h = -    promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt +zeroLDO :: LocQuery u (DotAnchor u)+zeroLDO = qpromoteLoc $ \pt -> return $ zeroAnchor pt -circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u-circleAnchor rad ctr = DotAnchor ctr -                                 (\theta -> ctr .+^ (avec theta rad))-                                 (radialCardinal rad ctr)+rectangleLDO :: (Real u, Floating u, InterpretUnit u) +             => MarkSize -> MarkSize -> LocQuery u (DotAnchor u)+rectangleLDO w h = qpromoteLoc $ \pt -> +    (\uw uh -> rectangleAnchor (uw*0.5) (uh*0.5) pt) +      <$> uconvertCtx1 w <*> uconvertCtx1 h -circleLDO :: (Floating u, InterpretUnit u) => LocQuery u (DotAnchor u)-circleLDO = -    promoteR1 $ \pt -> -      markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt  --- This might be better taking a function: ctr -> poly_points--- ...----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+circleLDO :: (Floating u, InterpretUnit u) +          => MarkSize -> LocQuery u (DotAnchor u)+circleLDO rad = qpromoteLoc $ \pt -> +    uconvertCtx1 rad >>= \urad ->  pure $ circleAnchor urad pt  +-- Probably better just using bounding circle for polygons +-- If you really care about anchors use shapes+-- ++-- Triangle probably benefits proper calculation...++triangleLDO :: (Real u, Floating u, Tolerance u, InterpretUnit u) +            => MarkSize -> LocQuery u (DotAnchor u)+triangleLDO h = qpromoteLoc $ \pt -> +    uconvertCtx1 h >>= \uh -> +    let alg = pathIterateLocus $ fn3 $ equilateralTriangleVertices uh+        ps  = runPathAlgPoint pt alg+    in return $ polygonAnchor ps pt+  where+    fn3 (a,b,c) = [a,b,c]++ --------------------------------------------------------------------------------  @@ -206,6 +232,27 @@  type DDotLocImage = DotLocImage Double  ++dotNone :: InterpretUnit u => DotLocImage u+dotNone = intoLocImage zeroLDO SD.dotNone++++smallDisk :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+smallDisk = intoLocImage (circleLDO 0.25) SD.smallDisk+++largeDisk :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+largeDisk = intoLocImage (circleLDO 1.00) SD.largeDisk++smallCirc :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+smallCirc = intoLocImage (circleLDO 0.25) SD.smallCirc+++largeCirc :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+largeCirc = intoLocImage (circleLDO 1.00) SD.largeCirc++ dotChar :: (Floating u, Real u, InterpretUnit u) => Char -> DotLocImage u dotChar ch = dotText [ch] @@ -218,73 +265,77 @@   dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u -dotText ss = pushR1 (mapAns bboxRectAnchor) $ ccTextline ss+dotText ss = fmap bboxRectAnchor $ ccTextline ss  -- Note - maybe Wumpus-Basic should have a @swapAns@ function?   dotHLine :: (Floating u, InterpretUnit u) => DotLocImage u-dotHLine = intoLocImage circleLDO markHLine+dotHLine = intoLocImage (circleLDO 0.5) SD.dotHLine   dotVLine :: (Floating u, InterpretUnit u) => DotLocImage u-dotVLine = intoLocImage circleLDO markVLine+dotVLine = intoLocImage (circleLDO 0.5) SD.dotVLine   dotX :: (Floating u, InterpretUnit u) => DotLocImage u-dotX = intoLocImage circleLDO markX+dotX = intoLocImage (circleLDO 0.5) SD.dotX  dotPlus :: (Floating u, InterpretUnit u) => DotLocImage u-dotPlus = intoLocImage circleLDO markPlus+dotPlus = intoLocImage (circleLDO 0.5) SD.dotPlus  dotCross :: (Floating u, InterpretUnit u) => DotLocImage u-dotCross = intoLocImage circleLDO markCross+dotCross = intoLocImage (circleLDO 0.5) SD.dotCross  dotDiamond :: (Floating u, InterpretUnit u) => DotLocImage u-dotDiamond = intoLocImage circleLDO markDiamond+dotDiamond = intoLocImage (circleLDO 0.5) SD.dotDiamond  dotFDiamond :: (Floating u, InterpretUnit u) => DotLocImage u-dotFDiamond = intoLocImage circleLDO markFDiamond+dotFDiamond = intoLocImage (circleLDO 0.5) SD.dotFDiamond    dotDisk :: (Floating u, InterpretUnit u) => DotLocImage u-dotDisk = intoLocImage circleLDO markDisk+dotDisk = intoLocImage (circleLDO 0.5) SD.dotDisk   dotSquare :: (Floating u, Real u, InterpretUnit u) => DotLocImage u-dotSquare = -    markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare+dotSquare = intoLocImage (rectangleLDO 1 1) SD.dotSquare     dotCircle :: (Floating u, InterpretUnit u) => DotLocImage u-dotCircle = intoLocImage circleLDO markCircle+dotCircle = intoLocImage (circleLDO 0.5) SD.dotCircle   dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u-dotPentagon = intoLocImage circleLDO markPentagon+dotPentagon = intoLocImage (circleLDO 0.5) SD.dotPentagon  dotStar :: (Floating u, InterpretUnit u) => DotLocImage u-dotStar = intoLocImage circleLDO markStar+dotStar = intoLocImage (circleLDO 0.5) SD.dotStar   dotAsterisk :: (Floating u, InterpretUnit u) => DotLocImage u-dotAsterisk = intoLocImage circleLDO markAsterisk+dotAsterisk = intoLocImage (circleLDO 0.5) SD.dotAsterisk  dotOPlus :: (Floating u, InterpretUnit u) => DotLocImage u-dotOPlus = intoLocImage circleLDO markOPlus+dotOPlus = intoLocImage (circleLDO 0.5) SD.dotOPlus  dotOCross :: (Floating u, InterpretUnit u) => DotLocImage u-dotOCross = intoLocImage circleLDO markOCross+dotOCross = intoLocImage (circleLDO 0.5) SD.dotOCross  dotFOCross :: (Floating u, InterpretUnit u) => DotLocImage u-dotFOCross = intoLocImage circleLDO markFOCross+dotFOCross = intoLocImage (circleLDO 0.5) SD.dotFOCross   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]+dotTriangle = intoLocImage (triangleLDO 1) SD.dotTriangle+++intoLocImage :: LocQuery u a -> LocImage u z -> LocImage u a+intoLocImage mq gf = promoteLoc $ \pt -> +                     askDC >>= \ctx -> +                     let ans = runLocQuery pt ctx mq+                     in replaceAns ans $ applyLoc gf pt

@@ -1,242 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Dots.Marks--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Marks - dots without anchor handles.------ The text and char marks need loaded glyph metrics for proper --- centering. ------ \*\* WARNING \*\* - names are expected to change - filled and--- background-filled marks need a naming convention.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Dots.Marks-  ( ---  -- * Marks-    markChar-  , markText--  , markHLine-  , markVLine-  , markX-  , markPlus-  , markCross-  , markDiamond-  , markFDiamond-  , markBDiamond -  , markDisk-  , markSquare-  , markCircle  -  , markPentagon-  , markStar-  , markAsterisk-  , markOPlus-  , markOCross-  , markFOCross-  , markTriangle--  ) where---import Wumpus.Drawing.Text.Base.RotTextZero--import Wumpus.Basic.Geometry.Paths              -- package: wumpus-basic-import Wumpus.Basic.Kernel        --import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace----- Marks should be the height of a lower-case letter...---- NOTES------ TikZ has both stroked and bordered (filled and outline-stroked)--- marks e.g. square and square*--------infixr 9 `renderPathWith`--renderPathWith :: LocQuery u PrimPath -               -> (PrimPath -> Graphic u) -               -> LocGraphic u-renderPathWith qy mk = promoteR1 $ \pt -> apply1R1 qy pt >>= mk----markChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u-markChar ch = markText [ch]-----markText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u-markText ss = pushR1 ignoreAns $ ccTextline ss------- | Supplied point is the center.----axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u-axialLine v = moveStart (\ctr -> ctr .-^ (0.5 *^ v)) (locStraightLine v)---markHLine :: (Fractional u, InterpretUnit u) => LocGraphic u -markHLine = markHeight >>= \h -> axialLine (hvec h)---markVLine :: (Fractional u, InterpretUnit u) => LocGraphic u -markVLine = markHeight >>= \h -> axialLine (vvec h) ---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, InterpretUnit u) =>  LocGraphic u-markPlus = markVLine `oplus` markHLine---markCross :: (Floating u, InterpretUnit u) =>  LocGraphic u-markCross = markHeight >>= mkCross-  where-    mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (-ang) h)-    ang       = pi*0.25  ---- Note - height is extended slightly to look good...--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------ closedStroke :: (a -> ctx -> prim) --- pathDiamond  :: (ctx -> pt -> a)--- ans          :: (ctx -> pt -> prim)--markDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-markDiamond = pathDiamond `renderPathWith` closedStroke--markFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-markFDiamond = pathDiamond `renderPathWith` filledPath----- Note - the (const . fn) composition doesn\'t /tell/ much about--- what is going on - though obviously it can be decoded - make --- the function obvious to the second argument. --- --- A named combinator might be better.-----markBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-markBDiamond = pathDiamond `renderPathWith` borderedPath----- | Note disk is filled.----markDisk :: (Fractional u, InterpretUnit u) => LocGraphic u-markDisk = markHalfHeight >>= filledDisk----markSquare :: (Fractional u, InterpretUnit u) => LocGraphic u-markSquare = -    markHeight >>= \h -> -    let d = 0.5*(-h) in moveStart (displace d d) $ strokedRectangle h h-    ---markCircle :: (Fractional u, InterpretUnit u) => LocGraphic u-markCircle = markHalfHeight >>= strokedDisk---markBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u-markBCircle = markHalfHeight >>= borderedDisk ----markPentagon :: (Floating u, InterpretUnit u) => LocGraphic u-markPentagon = promoteR1 $ \pt -> -    pentagonPath pt >>= closedStroke-  where-    pentagonPath pt = markHalfHeight >>= \hh -> -                      coordinatePrimPath (polygonCoordPath 5 hh) pt-- ---markStar :: (Floating u, InterpretUnit u) => LocGraphic u -markStar = markHeight >>= \h -> starLines (0.5*h)--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    = straightLine p0 p1-    step (x:xs) = oconcat x xs-    step _      = error "starLines - unreachable"---markAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u-markAsterisk = markHeight >>= asteriskLines--asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u-asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3-  where-    ang     = (pi*2) / 6-    lineF1  = axialLine (vvec h)-    lineF2  = axialLine (avec ((pi*0.5) + ang)    h)-    lineF3  = axialLine (avec ((pi*0.5) + ang + ang) h)---markOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u-markOPlus = markCircle `oplus` markPlus---markOCross :: (Floating u, InterpretUnit u) => LocGraphic u-markOCross = markCircle `oplus` markCross---markFOCross :: (Floating u, InterpretUnit u) => LocGraphic u-markFOCross = markCross `oplus` markBCircle ----- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u--- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) ----markTriangle :: (Floating u, InterpretUnit u) => LocGraphic u-markTriangle = tripath `renderPathWith` closedStroke-  where-    tripath = promoteR1 $ \pt -> -                markHeight >>= \h -> -                  let cp = equilateralTriangleCoordPath h-                  in coordinatePrimPath cp pt-

@@ -0,0 +1,267 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Dots.SimpleDots+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Simple dots - no anchor handles.+-- +-- Use these where you just want to draw Dots, and do not need+-- connectors between them. +--+-- The text and char marks need loaded glyph metrics for proper +-- centering. +--+-- \*\* WARNING \*\* - names are expected to change - filled and+-- background-filled marks need a naming convention.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Dots.SimpleDots+  ( ++  -- * Unit for marks (0.75 the font size)+    MarkSize++  , smallDisk+  , largeDisk+  , smallCirc+  , largeCirc  ++++  -- * Dots+  , dotNone++  , dotChar+  , dotText++  , dotHLine+  , dotVLine+  , dotX+  , dotPlus+  , dotCross+  , dotDiamond+  , dotFDiamond+  , dotBDiamond +  , dotDisk+  , dotSquare+  , dotCircle  +  , dotPentagon+  , dotStar+  , dotAsterisk+  , dotOPlus+  , dotOCross+  , dotFOCross+  , dotTriangle++  ) where+++import Wumpus.Drawing.Text.Base.RotTextZero++import Wumpus.Basic.Geometry                    -- package: wumpus-basic+import Wumpus.Basic.Kernel        ++import Wumpus.Core                              -- package: wumpus-core++import Data.VectorSpace                         -- package: vector-space++import Data.Monoid++-- Marks should be the height of a lower-case letter...++-- NOTES+--+-- TikZ has both stroked and bordered (filled and outline-stroked)+-- marks e.g. square and square*+--++-- Cap height is a good size for Dots.+++-- | MarkUnit is a contextual unit like 'Em' and 'En'.+-- +-- It is 3\/4 of the current font size.+--+newtype MarkSize = MarkSize { getMarkSize :: Double }+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)++instance Show MarkSize where+  showsPrec p d = showsPrec p (getMarkSize d)+++instance InterpretUnit MarkSize where+  normalize sz a = (realToFrac  a) * 0.75 * fromIntegral sz+  dinterp sz d   = (4/3) * (realToFrac d) / (fromIntegral sz)+++umark :: InterpretUnit u => LocGraphic MarkSize -> LocGraphic u+umark = uconvF+++-- | Filled disk - radius 0.25 MarkSize.+--+smallDisk :: InterpretUnit u => LocGraphic u+smallDisk = umark $ dcDisk FILL 0.25+++-- | Filled disk - radius 1.0 MarkSize.+--+largeDisk :: InterpretUnit u => LocGraphic u+largeDisk = umark $ dcDisk FILL 1+++-- | Stroked disk (circle) - radius 0.25 MarkSize.+--+smallCirc :: InterpretUnit u => LocGraphic u+smallCirc = umark $ dcDisk STROKE 0.25+++-- | Stroked disk (circle) - radius 1.0 MarkSize.+--+largeCirc :: InterpretUnit u => LocGraphic u+largeCirc = umark $ dcDisk STROKE 1+++-- possibly:+-- szCirc :: u -> LocGraphic u++dotNone :: InterpretUnit u => LocGraphic u+dotNone = emptyLocImage++dotChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u+dotChar ch = dotText [ch]++++dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u+dotText ss = ignoreAns $ ccTextline ss+++++-- | Supplied point is the center.+--+axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u+axialLine v = moveStart (negateV (0.5 *^ v)) (locStraightLine v)+++dotHLine :: (Fractional u, InterpretUnit u) => LocGraphic u +dotHLine = umark $ axialLine (hvec 1)+++dotVLine :: (Fractional u, InterpretUnit u) => LocGraphic u +dotVLine = umark $ axialLine (vvec 1) +++dotX :: (Fractional u, InterpretUnit u) => LocGraphic u+dotX = umark $ axialLine (vec 0.75 1) `mappend` axialLine (vec (-0.75) 1)++++dotPlus :: (Fractional u, InterpretUnit u) =>  LocGraphic u+dotPlus = dotVLine `mappend` dotHLine+++dotCross :: (Floating u, InterpretUnit u) =>  LocGraphic u+dotCross = +    umark $ axialLine (avec ang 1) `mappend` axialLine (avec (-ang) 1)+  where +    ang = pi*0.25  ++++++dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u+dotDiamond = umark $ drawVertexPathAlg STROKE (diamondPathAlg 0.5 0.66)++dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u+dotFDiamond = umark $ drawVertexPathAlg FILL (diamondPathAlg 0.5 0.66)++++dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u+dotBDiamond = umark $ drawVertexPathAlg FILL_STROKE (diamondPathAlg 0.5 0.66)+++-- | Note disk is filled.+--+dotDisk :: (Fractional u, InterpretUnit u) => LocGraphic u+dotDisk = umark $ dcDisk FILL 0.5++++dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u+dotSquare = umark $ drawVertexPathAlg STROKE (rectanglePathAlg 1 1)+++dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u+dotCircle = umark $ dcDisk STROKE 0.5+++dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u+dotBCircle = umark $ dcDisk FILL_STROKE 0.5++++dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u+dotPentagon = umark $ drawVertexPathAlg STROKE (polygonPathAlg 5 0.5)+ +++dotStar :: (Floating u, InterpretUnit u) => LocGraphic u +dotStar = umark $ starLines 0.5++starLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u+starLines hh = promoteLoc $ \ctr -> +    let ps = runPathAlgPoint ctr $ polygonPathAlg 5 hh+    in step $ map (fn ctr) ps+  where+    fn p0 p1    = straightLine p0 p1+    step (x:xs) = mconcat $ x:xs+    step _      = error "starLines - unreachable"+++dotAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u+dotAsterisk = umark $ asteriskLines 1++asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u+asteriskLines h = lineF1 `mappend` lineF2 `mappend` lineF3+  where+    ang     = (pi*2) / 6+    lineF1  = axialLine (vvec h)+    lineF2  = axialLine (avec ((pi*0.5) + ang)    h)+    lineF3  = axialLine (avec ((pi*0.5) + ang + ang) h)+++dotOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u+dotOPlus = dotCircle `mappend` dotPlus+++dotOCross :: (Floating u, InterpretUnit u) => LocGraphic u+dotOCross = dotCircle `mappend` dotCross+++dotFOCross :: (Floating u, InterpretUnit u) => LocGraphic u+dotFOCross = dotBCircle `mappend` dotCross+++-- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u+-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) ++++dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u+dotTriangle = umark $ drawVertexPathAlg STROKE alg +  where+    alg = pathIterateLocus $ fn3 $ equilateralTriangleVertices 1+    fn3 = \(a,b,c) -> [a,b,c]

@@ -26,24 +26,23 @@ import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Core                              -- package: wumpus-core +import Data.Monoid  -- Note - axes need labels working out...  --- | Draw axes from (0,0).+-- | Simple orthonormal axes using snap grid units. -- orthontAxes :: (Real u, Floating u, InterpretUnit u)-            => (Double, Double) -> Graphic u-orthontAxes (w,h) = -    snapmove (1,1) >>= \(V2 w1 h1) ->+            => (Int,Int) -> (Int,Int) -> LocGraphic u+orthontAxes (xl,xr) (yl,yr) = +    promoteLoc $ \(P2 x y) -> +    snapmove (1,1) >>= \(V2 uw uh) ->     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)-+        xPtl  = P2 (x - (uw * fromIntegral xl)) y+        xPtr  = P2 (x + (uw * fromIntegral xr)) y+        yPtl  = P2 x (y - (uh * fromIntegral yl))+        yPtr  = P2 x (y + (uh * fromIntegral yr))+    in  localize cap_square $           ignoreAns (connect xPtl xPtr conn1) +                              `mappend` ignoreAns (connect yPtl yPtr conn1) -    -    

@@ -0,0 +1,41 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Clip+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Clipping paths.+--+-- Note - at the moment there is nothing much to this module.+-- Ideally, clipping would be defined in Wumpus-Basic, but clipping+-- needs a higher level path object than Wumpus-Basic provides.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Clip+  ( +   +    locClip++  ) where+++import Wumpus.Drawing.Paths.Relative++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+++++-- | Clip a LocGraphic.+--+locClip :: InterpretUnit u => RelPath u -> LocGraphic u -> LocGraphic u+locClip rp gf = promoteLoc $ \pt -> +    zapQuery (toPrimPath pt rp) >>= \pp -> clipImage pp (gf `at` pt)+

@@ -20,6 +20,8 @@     GridContextF   , grid   , standard_grid+  , dotted_major_grid+   , grid_major_colour   , grid_major_line_width   , grid_major_dotnum@@ -33,11 +35,14 @@   ) where  +import Wumpus.Drawing.Basis.DrawingPrimitives+import Wumpus.Drawing.Basis.LocTrace+ import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Core                              -- package: wumpus-core import Wumpus.Core.Colour ( black ) -+import Data.Monoid   type GridContextF = GridProps -> GridProps@@ -74,18 +79,16 @@   -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 +dotted_major_grid :: GridContextF+dotted_major_grid = +    grid_minor_subdivisions 0 . grid_major_dotnum 2++-- Setters for client code.+ grid_major_colour :: RGBi -> GridContextF grid_major_colour rgb = (\s -> s { gp_major_colour = rgb }) @@ -96,7 +99,7 @@ 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_subdivisions n = (\s -> s { gp_minor_subdivs = n })  grid_minor_colour :: RGBi -> GridContextF grid_minor_colour rgb = (\s -> s { gp_minor_colour = rgb })@@ -117,28 +120,20 @@   --------------------------------------------------------------------------------- ---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)+-- Drawing context updaters... +major_line_update :: GridProps -> DrawingContextF+major_line_update (GridProps { gp_major_colour  = rgb+                             , gp_major_lnwidth = lnwidth+                             , gp_major_dotnum  = dotnum }) = +    lineProps rgb lnwidth dotnum  +minor_line_update :: GridProps -> DrawingContextF+minor_line_update (GridProps { gp_minor_colour  = rgb+                             , gp_minor_lnwidth = lnwidth+                             , gp_minor_dotnum  = dotnum }) = +    lineProps rgb lnwidth dotnum    lineProps :: RGBi -> Double -> Int -> DrawingContextF@@ -149,81 +144,67 @@     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) +grid :: (Fractional u, InterpretUnit u) +     => GridContextF -> Int -> Int -> LocGraphic u  +grid upd nx ny = +    snapmove (1,1) >>= \(V2 uw uh) ->+    let props  = upd default_grid_props+        width  = uw * fromIntegral nx+        height = uh * fromIntegral ny+        intrr = gridInterior nx width uw ny height uh props+        rect   = localize (major_line_update props) $ +                   blRectangle STROKE width height+    in intrr `mappend` rect +                  +gridInterior :: (Fractional u, InterpretUnit u) +             => Int -> u -> u -> Int -> u -> u -> GridProps -> LocGraphic u+gridInterior nx w uw ny h uh props = hlines `mappend` vlines+  where+    hlines = horizontalLines ny w uh props+    vlines = verticalLines   nx h uw props  --- | 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)+horizontalLines :: (Fractional u, InterpretUnit u) +                => Int -> u -> u -> GridProps -> LocGraphic u+horizontalLines numh w uh props@(GridProps { gp_minor_subdivs = subs })+    | subs > 0  = let dy = uh / (fromIntegral subs)+                      n  = (numh * subs) - 1+                  in moveStart (vvec dy) $ minorMajor n subs (vvec dy) mnr mjr+    | otherwise = moveStart (vvec uh) $ duplicate numh (vvec uh) mjr+  where+    mnr  = localize (minor_line_update props) $ hline w+    mjr  = localize (major_line_update props) $ hline w -        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)+verticalLines :: (Fractional u, InterpretUnit u) +              => Int -> u -> u -> GridProps -> LocGraphic u+verticalLines numv h uw props@(GridProps { gp_minor_subdivs = subs })+    | subs > 0  = let dx = uw / (fromIntegral subs)+                      n  = (numv * subs) - 1+                  in moveStart (hvec dx) $ minorMajor n subs (hvec dx) mnr mjr+    | otherwise = moveStart (hvec uw) $ duplicate numv (hvec uw) mjr   where-    go n acc pt | n < 1     = acc-                | otherwise = go (n-1) (acc `oplus` (g `at` pt)) (mv pt)-    +    mnr  = localize (minor_line_update props) $ vline h+    mjr  = localize (major_line_update props) $ vline h  -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+minorMajor :: Num u +           => Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u +           -> LocGraphic u+minorMajor count alt mv mnr mjr = execLocTrace (step count)+  where+    step n | n <= 0           = return ()+           | n `mod` alt == 0 = insertl mjr >> moveBy mv >> step (n-1)+           | otherwise        = insertl mnr >> moveBy mv >> step (n-1)+   

@@ -0,0 +1,95 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.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.Extras.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+++-- TODO - Loop is a decoration not a connector.+-- It should probably have the same signature as wedge / arc.++-- | Generate a loop - suitable for decorating a circle.+--+-- The radius and the (implicit) start point are the center and +-- radius of the initial circle not the loop itself.+--+loop :: (Real u, Floating u, InterpretUnit u, Tolerance u) +      => u -> Point2 u -> Radian -> Query u (AbsPath u)+loop zradius zctr ang = return $ curvePath $ loopPoints zradius zctr ang++++-- Should be able to use trig to get a loop suitable for+-- decorating rectangles (provided the start-to-end arc is smaller+-- than the side length+++++-- | 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         = dispParallel height incl circ_ctr+    kiter       = dispOrtho (V2 hminor (-hw)) incl circ_ctr+    kitel       = dispOrtho (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         = dispParallel minor_down incl kitel++    -- quadrant II +    cp3         = dispParallel major_up incl kitel+    cp4         = dispPerpendicular top_left incl top++    -- quadrant I+    cp5         = dispPerpendicular top_right incl top+    cp6         = dispParallel major_up incl kiter++    -- quadrant IV +    cp7         = dispParallel minor_down incl kiter+    cp8         = startr .+^ start_vec

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

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

@@ -18,11 +18,11 @@ module Wumpus.Drawing.Paths.Absolute   (  -    module Wumpus.Drawing.Paths.Base.AbsBuilder-  , module Wumpus.Drawing.Paths.Base.AbsPath+    module Wumpus.Drawing.Paths.Base.AbsPath+  , module Wumpus.Drawing.Paths.Base.PathBuilder    ) where -import Wumpus.Drawing.Paths.Base.AbsBuilder import Wumpus.Drawing.Paths.Base.AbsPath+import Wumpus.Drawing.Paths.Base.PathBuilder 

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

@@ -49,6 +49,8 @@   -- * Conversion   , toPrimPath +  , openAbsPath+  , closedAbsPath    -- * Shortening   , shortenPath@@ -79,6 +81,7 @@   , pathViewL   , pathViewR +  , optimizeLines    , roundTrail   , roundInterior@@ -269,7 +272,7 @@ -- Length is the length of the path as it is drawn, it is not a  -- count of the number or path segments. ----- Length is cached so this operation is cheap - though this put +-- Length is cached so this operation is cheap - though this puts -- a tax on the build operations.  --  length :: Num u => AbsPath u -> u@@ -400,8 +403,16 @@   +openAbsPath :: InterpretUnit u +            => AbsPath u -> Image u (AbsPath u)+openAbsPath rp = replaceAns rp $+    zapQuery (toPrimPath rp) >>= dcOpenPath  +closedAbsPath :: InterpretUnit u +              => DrawStyle -> AbsPath u -> Image u (AbsPath u)+closedAbsPath sty rp = replaceAns rp $ +    zapQuery (toPrimPath rp) >>= dcClosedPath sty   -- | Turn a Path into an ordinary PrimPath.@@ -410,7 +421,7 @@ -- segment is the same point as the start point of the next -- segment. ---toPrimPath :: InterpretUnit u => AbsPath u -> Query PrimPath+toPrimPath :: InterpretUnit u => AbsPath u -> Query u PrimPath toPrimPath (AbsPath _ start segs _) =      uconvertCtxF start       >>= \dstart ->      T.mapM uconvertCtxF segs >>= \dsegs  ->@@ -689,6 +700,34 @@   +--------------------------------------------------------------------------------+++-- Path should be same length afterwards.++optimizeLines :: (Real u, Floating u, Ord u, Tolerance u) +              => AbsPath u -> AbsPath u+optimizeLines (AbsPath _ sp0 segs _) = outer (zeroPath sp0) (viewl segs)+  where+    outer acc (AbsLineSeg _ p0 p1 :< se)                = +        inner acc (vdirection $ pvec p0 p1) p0 p1 (viewl se)++    outer acc (AbsCurveSeg _ _ p1 p2 p3 :< se)          = +        outer (snocCurveTo acc p1 p2 p3) (viewl se)++    outer acc EmptyL                                    = acc++    inner acc d1 sp ep (AbsLineSeg _ p0 p1 :< se)       =+        let d2 = vdirection $ pvec p0 p1 in +        if (d1 == d2) +          then inner acc d1 sp p1 (viewl se)+          else inner (acc `snocLineTo` ep) d2 ep p1 (viewl se)++    inner acc _  _  ep (AbsCurveSeg _ _ p1 p2 p3 :< se) = +        let acc1 = snocCurveTo (snocLineTo acc ep) p1 p2 p3+        in outer acc1 (viewl se)++    inner acc _  _  ep EmptyL                           = acc `snocLineTo` ep  -------------------------------------------------------------------------------- -- Round corners

@@ -1,129 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths.Base.BuildCommon--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Common data types for the monadic builders.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths.Base.BuildCommon-  ( --    BuildLog-  , PathEnd(..)-  , Vamp(..)-  -  , extractTrace-  , addInsert-  , addPen--  , insert1-  , pen1-     -  ) where--import Wumpus.Drawing.Paths.Base.RelPath ( RelPath )--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.Utils.HList--import Wumpus.Core                              -- package: wumpus-core--import Data.Monoid---- | Monadic builders allow both inserts (patterned after TikZ)--- which are decorations along the path and sub paths that are --- stroked and possibly closed.----data BuildLog a  = Log { insert_trace    :: H a-                       , pen_trace       :: H a-                       }-                 | NoLog--data PathEnd = PATH_CLOSED | PATH_OPEN-  deriving (Eq,Show)---data Vamp u = Vamp -      { vamp_move_span  :: Vec2 u-      , vamp_move_start :: Vec2 u-      , vamp_dc_update  :: DrawingContextF-      , vamp_deco_path  :: RelPath u-      , vamp_path_end   :: PathEnd-      }--type instance DUnit (Vamp u) = u------------------------------------------------------------------------------------- instances--instance Monoid (BuildLog a) where-  mempty                        = NoLog-  NoLog     `mappend` b         = b-  a         `mappend` NoLog     = a-  Log li lp `mappend` Log ri rp = Log (li `appendH` ri) (lp `appendH` rp)------- | Extract the pen and insert drawings from a 'BuildLog'.------ Any sub-paths traced by the pen are drawn at the back in the --- Z-order.----extractTrace :: OPlus a => a -> BuildLog a -> (a,a)-extractTrace zero NoLog           = (zero,zero)-extractTrace zero (Log ins pen)   = (pent,inst)-  where-    pent = altconcat zero $ toListH $ pen -    inst = altconcat zero $ toListH $ ins----- | Add an /insert/.------ This is a decoration drawn at the /current point/ during path--- building.--- -addInsert :: a -> BuildLog a -> BuildLog a-addInsert a NoLog = Log { insert_trace = wrapH a, pen_trace = emptyH }-addInsert a s@(Log { insert_trace=i }) = s { insert_trace = i `snocH` a }----- | Build a trace from an /insert/.------ This is a decoration drawn at the /current point/ during path--- building.--- -insert1 :: a -> BuildLog a-insert1 a = Log { insert_trace = wrapH a, pen_trace = emptyH }---- | Add a /pen/ drawing. ------ This is a stroked path sub-path formed prior to a @moveto@ --- instruction. Moveto is synonymous with /pen up/ - at a pen up--- and sub-path is drawn as a trace.--- -addPen :: a -> BuildLog a -> BuildLog a-addPen a NoLog = Log { insert_trace = wrapH a, pen_trace = emptyH }-addPen a s@(Log { pen_trace=i }) = s { pen_trace = i `snocH` a }----- | Build a trace from an /insert/.------ This is a decoration drawn at the /current point/ during path--- building.--- -pen1 :: a -> BuildLog a-pen1 a = Log { insert_trace = emptyH, pen_trace = wrapH a }---

@@ -0,0 +1,576 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.Base.PathBuilder+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Build relative paths monadically.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.Base.PathBuilder+  ( ++    LocTraceM(..) -- re-export++  , PathSpec+  , PathSpecT++  , Vamp+  , PathTerm(..)+  , makeVamp++  , runPathSpec+  , execPathSpec+  , evalPathSpec++  , runPathSpecT+  , execPathSpecT+  , evalPathSpecT++  , execPivot+  , execPivotT+++  , PathOpM(..)+++  -- * Derived operators+  , pen_colour+  , pen_width++  , lines++  , hline+  , vline+  , aline++ +  ) where++import Wumpus.Drawing.Basis.LocTrace+import Wumpus.Drawing.Paths.Base.RelPath+-- import qualified Wumpus.Drawing.Paths.Base.RelPath as R+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++import Data.VectorSpace                         -- package: vector-space++import Control.Applicative+import Control.Monad+import Data.Monoid+import Prelude hiding ( null, cycle, lines )+++++++-- | The vector part of the @active_path@ is its start point. +-- This allows cycled paths.+--+data BuildSt u = BuildSt +      { cumulative_tip    :: Vec2 u+      , cumulative_path   :: RelPath u+      , current_incline   :: Radian+      , active_path       :: ActivePath u+      , pen_trace         :: LocGraphic u+      , ins_trace         :: LocGraphic u+      , pen_dc_modifier   :: DrawingContextF+      }++      -- TODO - is incline worthwhile?+++-- | The vector for @PEN_DOWN@ is the start-point not the current+-- tip. +-- +-- Startpoint is needed for cycling a path.+-- +data ActivePath u = PEN_UP+                  | PEN_DOWN (Vec2 u) (RelPath u)+      ++++type instance DUnit (BuildSt u) = u+type instance DUnit (ActivePath u) = u+++newtype PathSpec u a = PathSpec { +      getPathSpec :: BuildSt u -> (a, BuildSt u) }+++newtype PathSpecT u m a = PathSpecT { +      getPathSpecT :: BuildSt u -> m (a, BuildSt u) } +++-- Note - splitting the state between BuildSt and the /path tip/+-- in LocTrace as actually detrimental to clarity of the code +-- below. It would make some sense to add the tip and the insert +-- trace to @BuildSt@ so everything is in one place.+++type instance MonUnit (PathSpec u a) = u+type instance MonUnit (PathSpecT u m a) = u+++-- | Vamps...+--+data Vamp u = Vamp +       { vamp_move :: Vec2 u+       , vamp_path :: RelPath u+       , vamp_term :: PathTerm+       }+++type instance DUnit (Vamp u) = u+++data PathTerm = SUBPATH_OPEN | SUBPATH_CLOSED DrawStyle+  deriving (Eq,Show)+++makeVamp :: Vec2 u -> RelPath u -> PathTerm -> Vamp u+makeVamp v1 ph pe = Vamp { vamp_move = v1+                         , vamp_path = ph+                         , vamp_term = pe  +                         }+++--------------------------------------------------------------------------------+-- instances+++-- Functor++instance Functor (PathSpec u) where+  fmap f mf = PathSpec $ \s0 -> let (a,s1) = getPathSpec mf s0 in (f a,s1)++instance Monad m => Functor (PathSpecT u m) where+  fmap f mf = PathSpecT $ \s0 -> +                getPathSpecT mf s0 >>= \(a,s1) -> return (f a,s1)+++-- Applicative+                                +instance Applicative (PathSpec u) where+  pure a    = PathSpec $ \s0 -> (a, s0)+  mf <*> ma = PathSpec $ \s0 -> let (f,s1) = getPathSpec mf s0 +                                    (a,s2) = getPathSpec ma s1+                                in (f a, s2)++instance Monad m => Applicative (PathSpecT u m) where+  pure a    = PathSpecT $ \s0 -> return (a, s0)+  mf <*> ma = PathSpecT $ \s0 -> +                getPathSpecT mf s0 >>= \(f,s1) ->+                getPathSpecT ma s1 >>= \(a,s2) ->+                return (f a, s2)+++-- Monad++instance Monad (PathSpec u) where+  return a  = PathSpec $ \s0 -> (a, s0)+  ma >>= k  = PathSpec $ \s0 -> +                let (a,s1) = getPathSpec ma s0 in (getPathSpec . k) a s1 ++instance Monad m => Monad (PathSpecT u m) where+  return a  = PathSpecT $ \s0 -> return (a, s0)+  ma >>= k  = PathSpecT $ \s0 -> +                getPathSpecT ma s0 >>= \(a,s1) -> (getPathSpecT . k) a s1+            +++-- | Make the initial build state.+--+zeroBuildSt :: InterpretUnit u => BuildSt u+zeroBuildSt = BuildSt { cumulative_tip    = V2 0 0+                      , cumulative_path   = mempty+                      , current_incline   = 0+                      , active_path       = PEN_UP+                      , pen_trace         = mempty+                      , ins_trace         = mempty+                      , pen_dc_modifier   = id+                      }+++-- The /full/ versions throw away only parts of the @BuildSt@ .+--+++-- | Run a PathSpec - return a five-tuple.+--+-- > (ans, path, end_vector, pen_trace, insert_trace) +--+-- > ans - is the monadic answer, usually ().+--+-- > path - is the relative path formed by all movements during +-- > the build. This includes movement where the pen is _up_.+--+-- > end_vector - is the cumulative displacement from the start +-- > point.+--+-- > pen_trace - is ...+--+-- > insert_trace - +--+runPathSpec :: (Floating u, InterpretUnit u)+            => PathSpec u a +            -> (a, RelPath u, Vec2 u, LocGraphic u, LocGraphic u)+runPathSpec mf = +    post $ getPathSpec mf zeroBuildSt +  where+    post (a,st) = let (ph,end,pen,ins) = postBuildSt st+                  in (a,ph,end,pen,ins)++-- | /Close/ the BuildSt, extracting the values.+--+-- A partly drawn sub path will be added to the pen trace as an+-- open sub path.+--+postBuildSt :: InterpretUnit u +            => BuildSt u -> (RelPath u, Vec2 u, LocGraphic u, LocGraphic u)+postBuildSt s0 = step (penUp SUBPATH_OPEN s0) +  where+    step st = ( cumulative_path st+              , cumulative_tip st+              , pen_trace st+              , ins_trace st )+++++-- | Run an 'PathSpec' - return the LocGraphic formed by the pen +-- trace and the insert trace, /forget/ the outline of the path.+-- +-- Note - the insert trace is printed above the pen trace in the +-- z-order.+-- +execPathSpec :: (Floating u, InterpretUnit u)+             => PathSpec u a -> LocGraphic u+execPathSpec mf = post $ runPathSpec mf+  where+    post (_,_,_,g1,g2) = g1 `mappend` g2++++-- | Run an 'PathSpec' - return the outline of the path, /forget/+-- the the pen trace and the insert trace.+-- +evalPathSpec :: (Floating u, InterpretUnit u)+             => PathSpec u a -> RelPath u+evalPathSpec mf = post $ runPathSpec mf+  where+    post (_,ph,_,_,_) = ph+++-- | Transformer version of 'runPathSpec'+--+runPathSpecT :: (Monad m, Floating u, InterpretUnit u)+             => PathSpecT u m a +             -> m (a, RelPath u, Vec2 u, LocGraphic u, LocGraphic u)+runPathSpecT mf = +    liftM post $ getPathSpecT mf zeroBuildSt +  where+    post (a,st) = let (ph,end,pen,ins) = postBuildSt st+                  in (a,ph,end,pen,ins)+++-- | Transformer version of 'execPathSpec'+--+execPathSpecT :: (Monad m, Floating u, InterpretUnit u)+              => PathSpecT u m a -> m (LocGraphic u)+execPathSpecT mf = liftM post $ runPathSpecT mf+  where+    post (_,_,_,g1,g2) = g1 `mappend` g2+++-- | Transformer version of 'evalPathSpec'.+-- +evalPathSpecT :: (Monad m, Floating u, InterpretUnit u)+              => PathSpecT u m a -> m (RelPath u)+evalPathSpecT mf = liftM post $ runPathSpecT mf+  where+    post (_,ph,_,_,_) = ph+++++-- | Form a \"pivot path\" drawing from two path specifications.+-- The start point of the drawing is the pivot formed by joining+-- the paths.+--+execPivot :: (Floating u, InterpretUnit u)+          => PathSpec u a -> PathSpec u a -> LocGraphic u+execPivot ma mb = moveStart (negateV v) $ pen `mappend` ins+  where+   (v, _, _, pen, ins) = runPathSpec ( ma >> location >>= \ans -> +                                       mb >> return ans )++-- | Transformer version of 'execPivot'.+-- +execPivotT :: (Floating u, InterpretUnit u, Monad m)+           => PathSpecT u m a -> PathSpecT u m a -> m (LocGraphic u)+execPivotT ma mb = +    liftM post $ runPathSpecT ( ma >> location >>= \ans -> +                                mb >> return ans )+  where+    post (v, _, _, pen, ins) = moveStart (negateV v) $ pen `mappend` ins+       +++ +--------------------------------------------------------------------------------++-- BuildSt modifiers.++type BuildStF u = BuildSt u -> BuildSt u +++-- | Helper - extend the path with a line.+-- +-- This is an implicit PEN_DOWN if the active pen is UP.+--+extendPath :: Floating u +           => Vec2 u -> BuildStF u+extendPath v1 = (\s v0 ph pa -> s { cumulative_tip   = v0 ^+^ v1+                                  , cumulative_path  = updP ph+                                  , active_path      = updA v0 pa })+           <*> cumulative_tip <*> cumulative_path <*> active_path+   where+     updP ph                   = snocLineTo ph v1+     updA tip PEN_UP           = PEN_DOWN tip (line1 v1)+     updA _   (PEN_DOWN v0 ph) = PEN_DOWN v0 (snocLineTo ph v1)+++++-- | Helper - extend the path with a curve.+--+-- This is an implicit PEN_DOWN if the active pen is UP.+-- +extendPathC :: (Floating u, Ord u, Tolerance u)+            => Vec2 u -> Vec2 u -> Vec2 u -> BuildStF u+extendPathC c1 c2 c3 = +    (\s v0 ph pa -> s { cumulative_tip   = v0 ^+^ c1 ^+^ c2 ^+^ c3+                      , cumulative_path  = updP ph+                      , active_path      = updA v0 pa })+      <*> cumulative_tip <*> cumulative_path <*> active_path+   where+     updP ph                   = snocCurveTo ph c1 c2 c3+     updA tip PEN_UP           = PEN_DOWN tip (curve1 c1 c2 c2)+     updA _   (PEN_DOWN v0 ph) = PEN_DOWN v0 (snocCurveTo ph c1 c2 c3)+++-- | Helper - change the active_path to PEN_UP. +-- +-- This will implicitly log any partly drawn path.+--+penUp :: InterpretUnit u => PathTerm -> BuildStF u+penUp term = +    (\s pt pa upd -> s { active_path = PEN_UP+                       , pen_trace   = pt `mappend` fn upd pa })+      <*> pen_trace <*> active_path <*> pen_dc_modifier+  where+    fn _   PEN_UP           = mempty+    fn upd (PEN_DOWN v0 pa) = subPathDraw upd v0 pa term+++-- | Move the current tip.+--+-- This is an implicit PEN_UP if the active pen is DOWN.+-- +moveTip :: (Floating u, InterpretUnit u) +        => Vec2 u -> BuildStF u+moveTip v1 = +    (\s pa v0 cp -> let s1 = case pa of PEN_UP -> s; _ -> penUp SUBPATH_OPEN s+                    in s1 { cumulative_tip  = v0 ^+^ v1+                          , cumulative_path = snocLineTo cp v1 })+      <*> active_path <*> cumulative_tip <*> cumulative_path+++-- | Cycle the current active path.+--+cycleAP :: (Floating u, InterpretUnit u) +        => DrawStyle -> BuildStF u+cycleAP sty = +    (\s pa vtip cp -> case pa of+                        PEN_UP -> s+                        PEN_DOWN v0 _ -> let s1 = penUp (SUBPATH_CLOSED sty) s+                                             mv = v0 ^-^ vtip+                                         in s1 { cumulative_tip  = v0 +                                               , cumulative_path = snocLineTo cp mv })+      <*> active_path <*> cumulative_tip <*> cumulative_path+    +    ++-- | Change the drawing props of the current pen.+--+-- This is an implicit PEN_UP if the active pen is DOWN.+-- +changePen :: InterpretUnit u => DrawingContextF -> BuildStF u+changePen upd = +    (\s pa df -> let s1 = case pa of PEN_UP -> s; _ -> penUp SUBPATH_OPEN s+                 in s1 { pen_dc_modifier  = (upd . df) })+      <*> active_path <*> pen_dc_modifier++++insertGf :: Num u => LocGraphic u -> BuildStF u+insertGf gf = +    (\s ins v1 -> let g1 = moveStart v1 gf+                  in s { ins_trace = ins `mappend` g1 })+      <*> ins_trace <*> cumulative_tip+               +++appendVamp :: (Floating u, InterpretUnit u) +           => Vamp u -> BuildStF u+appendVamp (Vamp { vamp_path = vph, vamp_term = term, vamp_move = mv }) =+    next . penUp SUBPATH_OPEN+  where+    next = (\s v1 cp trc df -> let p1 = subPathDraw df v1 vph term+                               in s { cumulative_tip  = v1 ^+^ mv+                                    , cumulative_path = snocLineTo cp mv+                                    , pen_trace       = trc `mappend` p1 })+            <*> cumulative_tip <*> cumulative_path +            <*> pen_trace      <*> pen_dc_modifier+                                 +++subPathDraw :: InterpretUnit u +            => DrawingContextF -> Vec2 u -> RelPath u -> PathTerm +            -> LocGraphic u+subPathDraw upd v0 subp term = promoteLoc $ \pt -> +    zapQuery (toPrimPath (displace v0 pt) subp) >>= \pp -> localize upd (drawF pp)+  where+    drawF = case term of+              SUBPATH_OPEN -> dcOpenPath+              SUBPATH_CLOSED sty -> dcClosedPath sty++++++--------------------------------------------------------------------------------+-- LocTraceM instances++-- Note - path building does not support forking (LocForkTraceM). ++-- moveBy becomes a pen up++instance (Floating u, InterpretUnit u) => +    LocTraceM (PathSpec u) where+  insertl a = PathSpec $ \s0 -> ((), insertGf a s0)+  location  = PathSpec $ \s0 -> (cumulative_tip s0, s0)+  moveBy v  = PathSpec $ \s0 -> ((), moveTip v s0)+++++instance (Monad m, Floating u, InterpretUnit u) => +    LocTraceM (PathSpecT u m) where+  insertl a = PathSpecT $ \s0 -> return ((), insertGf a s0)+  location  = PathSpecT $ \s0 -> return (cumulative_tip s0, s0)+  moveBy v  = PathSpecT $ \s0 -> return ((), moveTip v s0)++++--------------------------------------------------------------------------------+-- +++-- | @updatePen@ will draw any in-progress path as an open-stroked+-- line before changing the pen properties.+--+class Monad m => PathOpM m where+  line         :: u ~ MonUnit (m ()) => Vec2 u -> m ()+  curve        :: u ~ MonUnit (m ()) => Vec2 u -> Vec2 u -> Vec2 u -> m ()+  updatePen    :: DrawingContextF -> m ()+  cycleSubPath :: DrawStyle -> m ()+  vamp         :: u ~ MonUnit (m ()) => Vamp u -> m ()++++instance (Floating u, Ord u, Tolerance u, InterpretUnit u) => +    PathOpM (PathSpec u) where+  line v1           = PathSpec $ \s0 -> ((), extendPath v1 s0)+  curve v1 v2 v3    = PathSpec $ \s0 -> ((), extendPathC v1 v2 v3 s0)+  updatePen upd     = PathSpec $ \s0 -> ((), changePen upd s0)+  cycleSubPath sty  = PathSpec $ \s0 -> ((), cycleAP sty s0)+  vamp vp           = PathSpec $ \s0 -> ((), appendVamp vp s0)++++instance (Monad m, Floating u, Ord u, Tolerance u, InterpretUnit u) => +    PathOpM (PathSpecT u m) where+  line v1           = PathSpecT $ \s0 -> return ((), extendPath v1 s0)+  curve v1 v2 v3    = PathSpecT $ \s0 -> return ((), extendPathC v1 v2 v3 s0)+  updatePen upd     = PathSpecT $ \s0 -> return ((), changePen upd s0)+  cycleSubPath sty  = PathSpecT $ \s0 -> return ((), cycleAP sty s0)+  vamp vp           = PathSpecT $ \s0 -> return ((), appendVamp vp s0)++++--------------------------------------------------------------------------------+-- operations++++{-++setIncline :: Radian -> PathSpec u ()+setIncline ang = sets_ upd+  where+    upd = (\s -> s { current_incline = ang })++-}++--------------------------------------------------------------------------------+-- Derived operators+++++pen_colour :: PathOpM m+           => RGBi -> m ()+pen_colour rgb = updatePen (stroke_colour rgb)++pen_width  :: PathOpM m +           => Double -> m ()+pen_width d = updatePen (set_line_width d)+++lines :: (PathOpM m, u ~ MonUnit (m ())) => [Vec2 u] -> m ()+lines = mapM_ line+++--+-- Note - these names are not consistent with Displacement in +-- Wumpus-Basic.+--++hline :: (PathOpM m, Num u, u ~ MonUnit (m ())) => u -> m ()+hline dx = line (hvec dx)++vline :: (PathOpM m, Num u, u ~ MonUnit (m ())) => u -> m ()+vline dy = line (vvec dy)+++aline :: (PathOpM m, Floating u, u ~ MonUnit (m ())) => Radian -> u -> m ()+aline ang d = line (avec ang d)

@@ -1,520 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths.Base.RelBuilder--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Build relative paths monadically.------ \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths.Base.RelBuilder-  ( --    RelBuild-  , runRelBuild-  , execRelBuild-  , evalRelBuild-  , execPivot---  , tip -  , line-  , curve-  , move--  , insert-  , vamp-  , cycle--  , setIncline-  , pivot--  -- * 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 qualified Wumpus.Drawing.Paths.Base.AbsPath as A-import Wumpus.Drawing.Paths.Base.BuildCommon-import Wumpus.Drawing.Paths.Base.RelPath-import qualified Wumpus.Drawing.Paths.Base.RelPath as R---import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core---import Data.VectorSpace                         -- package: vector-space--import Control.Applicative-import Data.Monoid-import Prelude hiding ( null, log, cycle )---data St u = St -      { cumulative_disp   :: Vec2 u-      , cumulative_path   :: RelPath u-      , current_incline   :: Radian-      , active_path       :: (Vec2 u, RelPath u)-      , pen_dc_modifier   :: DrawingContextF-      , pivot_position    :: Vec2 u-      }--type instance DUnit (St u) = u--type Log u  = BuildLog (LocGraphic u)---- --- Don\'t want to write pen trace along with the insert commands --- as some renderings (fill) should ignore the the pen trace.----- | Evaluation is two States - a vector for cummulative --- displacement and a cummulative path - plus one Writer - a trace --- of TikZ-like @insert@ commands.----data RelBuild u a = RelBuild { getRelBuild :: St u -> (a, St u, Log u) }--type instance DUnit (RelBuild u a) = u-------------------------------------------------------------------------------------- instances----instance Functor (RelBuild u) where-  fmap f mf = RelBuild $ \s0 -> let (a, s1, w) = getRelBuild mf s0-                             in (f a, s1, w)---instance Applicative (RelBuild u) where-  pure a    = RelBuild $ \s0 -> (a, s0, mempty)-  mf <*> ma = RelBuild $ \s0 -> -                let (f,s1,w1) = getRelBuild mf s0-                    (a,s2,w2) = getRelBuild ma s1-                in (f a, s2, w1 `mappend` w2)--instance Monad (RelBuild u) where-  return a  = RelBuild $ \s0 -> (a, s0, mempty)-  ma >>= k  = RelBuild $ \s0 -> -                let (a,s1,w1) = getRelBuild ma s0-                    (b,s2,w2) = (getRelBuild . k) a s1-                in (b, s2, w1 `mappend` w2)----zeroSt :: Num u => St u-zeroSt = St { cumulative_disp   = V2 0 0 -            , cumulative_path   = mempty-            , current_incline   = 0-            , active_path       = (V2 0 0, mempty)-            , pen_dc_modifier   = id-            , pivot_position    = V2 0 0-            }---runBuildMonad :: (Floating u, InterpretUnit u)-              => RelBuild u a -> (a, St u, LocGraphic u)-runBuildMonad mf = post $ getRelBuild mf zeroSt-  where-    post (a,st,log) = (a, st, pen `oplus` ins)-      where-        (v1,sub_last) = active_path st-        cf            = pen_dc_modifier st-        log_last      = logSubPath PATH_OPEN cf v1 sub_last-        log2          = log `mappend` log_last-        (pen,ins)     = extractTrace emptyLocGraphic log2----- | Note - runAbsBuild drops the monadic answer and returns the--- constructed path and a trace of the inserts and sub-paths.----runRelBuild :: (Floating u, InterpretUnit u)-            => RelBuild u a -> (RelPath u, LocGraphic u)-runRelBuild mf = post $ runBuildMonad mf-  where-    post (_,st,gf) = (cumulative_path st,gf)----- | Run an 'RelBuild' - return the LocGraphic formed by the pen --- trace and the insert trace, /forget/ the outline of the path.--- -execRelBuild :: (Floating u, InterpretUnit u)-             => RelBuild u a -> LocGraphic u-execRelBuild mf = snd $ runRelBuild mf------ | Run an 'RelBuild' - return the outline of the path, /forget/--- the LocGraphic formed by the pen trace and the insert trace.--- -evalRelBuild :: (Floating u, InterpretUnit u)-             => RelBuild u a -> RelPath u-evalRelBuild mf = fst $ runRelBuild mf---execPivot :: (Floating u, InterpretUnit u)-             => RelBuild u a -> LocGraphic u-execPivot mf = post $ runBuildMonad mf-  where-    post (_,st,gf) = let v1 = pivot_position st-                     in moveStart (displaceVec $ vreverse v1) gf-----logSubPath :: InterpretUnit u -           => PathEnd -> DrawingContextF -> Vec2 u -> RelPath u -> Log u -logSubPath spe upd v1 subp -    | R.null subp  = mempty-    | otherwise    = pen1 gf-  where-    drawF = if spe == PATH_OPEN then openStroke else closedStroke-    gf    = promoteR1 $ \pt -> -              toPrimPath (displaceVec v1 pt) subp >>= \pp -> -              localize upd (drawF pp)---tellSubClosed :: InterpretUnit u -              => DrawingContextF -> Vec2 u -> RelPath u -> RelBuild u ()-tellSubClosed upd v1 subp = -    RelBuild $ \s0 -> ((), s0, logSubPath PATH_CLOSED upd v1 subp)--tellSubOpen :: InterpretUnit u -            => DrawingContextF -> Vec2 u -> RelPath u -> RelBuild u ()-tellSubOpen upd v1 subp = -    RelBuild $ \s0 -> ((), s0, logSubPath PATH_OPEN upd v1 subp)---tellInsert :: LocGraphic u -> RelBuild u ()-tellInsert g1 = -    RelBuild $ \s0 -> ((),s0, insert1 g1)---sets_ :: (St u -> St u) -> RelBuild u ()-sets_ f = RelBuild $ \s0  -> ((), f s0, mempty)---gets :: (St u -> a) -> RelBuild u a-gets f = RelBuild $ \s0 -> (f s0, s0, mempty)--------------------------------------------------------------------------------------- operations--tip :: RelBuild u (Vec2 u)-tip = gets cumulative_disp------ | Helper - extend the path.----extendPath :: Num u -           => (Vec2 u -> RelPath u -> RelPath u) -> Vec2 u -> RelBuild u ()-extendPath fn v1 = sets_ upd-  where-    upd = (\s v0 i j -> s { cumulative_disp  = v0 ^+^ v1-                          , cumulative_path  = fn v0 i-                          , active_path      = bimapR (fn v0) j })-           <*> cumulative_disp <*> cumulative_path <*> active_path------- Note - is the @r@ prefix of @rlineto@ redundant considering--- RelBuild can only support relative operations anyway.------ @lineto@ or probably better just @line@ would be shorter and--- the derivatives @hline@, @vline@ would inherit an obvious --- naming scheme.------line :: Floating u => Vec2 u -> RelBuild u ()-line v1 = extendPath (\_ acc -> snocLineTo acc v1) v1------curve :: Floating u => Vec2 u -> Vec2 u -> Vec2 u -> RelBuild u ()-curve v1 v2 v3 = extendPath (\_ acc -> snocCurveTo acc v1 v2 v3) v3------- | 'rmoveto' is a pen up.----move :: (Floating u, InterpretUnit u) => Vec2 u -> RelBuild u ()-move v1 = -    gets active_path            >>= \(v0,ans) -> -    gets pen_dc_modifier        >>= \cf -> -    tellSubOpen cf v0 ans       >>  sets_ upd -  where-    upd   = (\s v0 i -> s { cumulative_disp = v0 ^+^ v1-                          , cumulative_path = snocLineTo i v1-                          , active_path     = (v0 ^+^ v1, mempty) })-              <*> cumulative_disp <*> cumulative_path------insert :: Num u => LocGraphic u -> RelBuild u ()-insert gf = gets cumulative_disp >>= \v -> -            tellInsert (moveStart (displaceVec v) gf)---penCtxUpdate :: (Floating u, InterpretUnit u) -             => DrawingContextF -> RelBuild u ()-penCtxUpdate cf = move (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 -> RelBuild u ()-vamp (Vamp vnext vstart upd relp path_end) = -    gets cumulative_disp        >>= \v0 -> -    gets pen_dc_modifier        >>= \cf ->-    move vnext                  >> drawF (upd . cf) (v0 ^+^ vstart) relp-  where-    drawF       = if path_end == PATH_OPEN then tellSubOpen else tellSubClosed- --cycle :: (Floating u, InterpretUnit u) => RelBuild u ()-cycle = -    gets cumulative_disp  >>= \v1 -> -    gets pen_dc_modifier  >>= \cf ->-    gets active_path      >>= \(start,acc) -> -    tellSubClosed cf start (snocLineTo acc start) >> -    sets_ (\s -> s { active_path = (v1, mempty)})---setIncline :: Radian -> RelBuild u ()-setIncline ang = sets_ upd-  where-    upd = (\s -> s { current_incline = ang })---pivot :: RelBuild u ()-pivot = sets_ upd-  where-    upd = (\s i -> s { pivot_position = i }) <*> cumulative_disp-------------------------------------------------------------------------------------- Derived operators---pen_colour :: (Floating u, InterpretUnit u) -           => RGBi -> RelBuild u ()-pen_colour rgb = penCtxUpdate (stroke_colour rgb)--pen_width  :: (Floating u, InterpretUnit u) -           => Double -> RelBuild u ()-pen_width d = penCtxUpdate (set_line_width d)----hline :: Floating u => u -> RelBuild u ()-hline dx = line (hvec dx)--vline :: Floating u => u -> RelBuild u ()-vline dy = line (vvec dy)--aline :: Floating u => Radian -> u -> RelBuild u ()-aline ang u = line (avec ang u)--hmove :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-hmove dx = move (hvec dx)--vmove :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-vmove dy = move (vvec dy)---amove :: (Floating u, InterpretUnit u) => Radian -> u -> RelBuild u ()-amove ang u = move (avec ang u)---line_up :: Floating u => u -> RelBuild u ()-line_up u = line (vvec u)--line_down :: Floating u => u -> RelBuild u ()-line_down u = line (vvec $ negate u)--line_left :: Floating u => u -> RelBuild u ()-line_left u = line (hvec $ negate u)- -line_right :: Floating u => u -> RelBuild u ()-line_right u = line (hvec u)---- | Diagonal lines --line_up_left :: Floating u => u -> RelBuild u ()-line_up_left u = line (vec (-u) u)--line_up_right :: Floating u => u -> RelBuild u ()-line_up_right u = line (vec u u)--line_down_left :: Floating u => u -> RelBuild u ()-line_down_left u = line (vec (-u) (-u))--line_down_right :: Floating u => u -> RelBuild u ()-line_down_right u = line (vec u (-u))----- Cardinal lines--line_north :: Floating u => u -> RelBuild u ()-line_north = vline---line_south :: Floating u => u -> RelBuild u ()-line_south =  vline . negate--line_east :: Floating u => u -> RelBuild u ()-line_east = hline--line_west :: Floating u => u -> RelBuild u ()-line_west = hline . negate---line_northeast ::  Floating u => u -> RelBuild u ()-line_northeast = line . avec (0.25 * pi)--line_northwest ::  Floating u => u -> RelBuild u ()-line_northwest = line . avec (0.75 * pi)--line_southeast ::  Floating u => u -> RelBuild u ()-line_southeast = line . avec (1.75 * pi)--line_southwest ::  Floating u => u -> RelBuild u ()-line_southwest = line . avec (1.25 * pi)-----move_up :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_up u = move (vvec u)--move_down :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_down u = move (vvec $ negate u)--move_left :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_left u = move (hvec $ negate u)- -move_right :: (Floating u, InterpretUnit u)  => u -> RelBuild u ()-move_right u = move (hvec u)------ | Diagonal moves --move_up_left :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_up_left u = move (vec (-u) u)--move_up_right :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_up_right u = move (vec u u)--move_down_left :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_down_left u = move (vec (-u) (-u))--move_down_right :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_down_right u = move (vec u (-u))----- Cardinal moves--move_north :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_north = vmove---move_south :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_south =  vmove . negate--move_east :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_east = hmove--move_west :: (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_west = hmove . negate---move_northeast ::  (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_northeast = move . avec (0.25 * pi)--move_northwest ::  (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_northwest = move . avec (0.75 * pi)--move_southeast ::  (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_southeast = move . avec (1.75 * pi)--move_southwest ::  (Floating u, InterpretUnit u) => u -> RelBuild u ()-move_southwest = move . avec (1.25 * pi)-

@@ -41,7 +41,7 @@    -- * Queries   , null-+  , length    -- * Concat   , append@@ -57,8 +57,10 @@    , toPrimPath   , toAbsPath-  , strokeRelPath +  , openRelPath+  , closedRelPath+   ) where  @@ -72,12 +74,15 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace +import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++ import qualified Data.Foldable          as F import Data.Monoid import qualified Data.Traversable       as T-import Prelude hiding ( null )+import Prelude hiding ( null, length )   @@ -88,7 +93,9 @@ -- Note this type is more limited than AbsPath, it does not -- support /introspective/ operations like @length@ or anchors. ---newtype RelPath u = RelPath { getRelPath :: JoinList (RelPathSeg u) }+data RelPath u = RelPath +      { rel_path_len    :: u+      , rel_path_segs   :: JoinList (RelPathSeg u) }   deriving (Eq,Show)  type instance DUnit (RelPath u) = u@@ -98,8 +105,16 @@  -- No annotations... -- -data RelPathSeg u = RelLineSeg  (Vec2 u)-                  | RelCurveSeg (Vec2 u) (Vec2 u) (Vec2 u)+data RelPathSeg u = RelLineSeg  +                      { rel_line_len    :: u +                      , rel_line_to     :: Vec2 u+                      }+                  | RelCurveSeg +                      { rel_curve_len   :: u+                      , rel_curve_cp1   :: Vec2 u+                      , rel_curve_cp2   :: Vec2 u+                      , rel_curve_cp3   :: Vec2 u+                      }   deriving (Eq,Show)  @@ -110,17 +125,17 @@ --------------------------------------------------------------------------------  instance Functor RelPath where-  fmap f = RelPath . fmap (fmap f) . getRelPath+  fmap f (RelPath len xs) = RelPath (f len) (fmap (fmap f) xs)  instance Functor RelPathSeg where-  fmap f (RelLineSeg v1)        = -      RelLineSeg (fmap f v1)+  fmap f (RelLineSeg len v1)        = +      RelLineSeg (f len) (fmap f v1) -  fmap f (RelCurveSeg v1 v2 v3) = -      RelCurveSeg (fmap f v1) (fmap f v2) (fmap f v3)+  fmap f (RelCurveSeg len v1 v2 v3) = +      RelCurveSeg (f len) (fmap f v1) (fmap f v2) (fmap f v3)  -instance Monoid (RelPath u) where+instance Num u => Monoid (RelPath u) where   mempty  = empty   mappend = append @@ -129,25 +144,61 @@ -- Construction  +-- | Helper - construct a straight line segment.+-- +lineSegment :: Floating u => Vec2 u -> (u, RelPathSeg u)+lineSegment v1 = +    (len, RelLineSeg { rel_line_len = len, rel_line_to = v1 })+  where+    len = vlength v1+++-- | Helper - construct a curve segment.+-- +curveSegment :: (Floating u, Ord u, Tolerance u) +             => Vec2 u -> Vec2 u -> Vec2 u -> (u, RelPathSeg u)+curveSegment v1 v2 v3 = (len, cseg)+  where+    p0    = zeroPt+    p1    = p0 .+^ v1+    p2    = p1 .+^ v2+    p3    = p2 .+^ v3+    +    len   = bezierLength (BezierCurve p0 p1 p2 p3)+    cseg  = RelCurveSeg { rel_curve_len = len+                        , rel_curve_cp1 = v1+                        , rel_curve_cp2 = v2+                        , rel_curve_cp3 = v3+                        }    ++++ -- | An empty relative path is acceptible to Wumpus because  -- it is always drawn as a LocGraphic. ---empty :: RelPath u -empty = RelPath mempty+empty :: Num u => RelPath u +empty = RelPath { rel_path_len = 0, rel_path_segs = mempty }  -- | Create a relative path from a single straight line. ---line1 :: Vec2 u -> RelPath u-line1 = RelPath . JL.one . RelLineSeg+line1 :: Floating u => Vec2 u -> RelPath u+line1 v = RelPath len (JL.one $ RelLineSeg len v)+  where+    len = vlength v+      -- | Create a relative path from a single Bezier curve. ---curve1 :: Vec2 u -> Vec2 u -> Vec2 u -> RelPath u-curve1 v1 v2 v3 = RelPath $ JL.one $ RelCurveSeg v1 v2 v3+curve1 :: Floating u +       => Vec2 u -> Vec2 u -> Vec2 u -> RelPath u+curve1 v1 v2 v3 = RelPath len (JL.one $ RelCurveSeg len v1 v2 v3)+  where+    len = vlength $ v1 ^+^ v2 ^+^ v3  -vertexPath :: [Vec2 u] -> RelPath u+vertexPath :: Floating u => [Vec2 u] -> RelPath u vertexPath [] = empty vertexPath (x:xs) = go (line1 x) xs   where@@ -156,7 +207,7 @@   -curvedPath :: [Vec2 u] -> RelPath u+curvedPath :: Floating u => [Vec2 u] -> RelPath u curvedPath xs = case xs of      (v1:v2:v3:vs) -> go (curve1 v1 v2 v3) vs     _             -> empty@@ -173,8 +224,18 @@ -- Queries  null :: RelPath u -> Bool-null = JL.null . getRelPath+null = JL.null . rel_path_segs +-- | Length of the Path.+--+-- Length is the length of the path as it is drawn, it is not a +-- count of the number or path segments.+--+-- Length is cached so this operation is cheap - though this puts +-- a tax on the build operations. +-- +length :: RelPath u -> u+length = rel_path_len   --------------------------------------------------------------------------------@@ -184,23 +245,35 @@   -append :: RelPath u -> RelPath u -> RelPath u-append (RelPath se0) (RelPath se1) = RelPath $ se0 `join` se1+append :: Num u => RelPath u -> RelPath u -> RelPath u+append (RelPath la ssa) (RelPath lb ssb) = RelPath (la + lb)  $ ssa `join` ssb  -consLineTo :: Vec2 u -> RelPath u -> RelPath u -consLineTo v1 (RelPath se) = RelPath $ JL.cons (RelLineSeg v1) se+consLineTo :: Floating u +           => Vec2 u -> RelPath u -> RelPath u +consLineTo v1 (RelPath len se) = RelPath (len + vl) $ JL.cons s se+  where+    (vl,s) = lineSegment v1  -snocLineTo :: RelPath u -> Vec2 u -> RelPath u-snocLineTo (RelPath se) v1 = RelPath $ JL.snoc se (RelLineSeg v1)+snocLineTo :: Floating u +           => RelPath u -> Vec2 u -> RelPath u+snocLineTo (RelPath len se) v1 = RelPath (len + vl) $ JL.snoc se s+  where+    (vl,s) = lineSegment v1    -consCurveTo :: Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -> RelPath u -consCurveTo v1 v2 v3 (RelPath se) = RelPath $ JL.cons (RelCurveSeg v1 v2 v3) se+consCurveTo :: (Floating u, Ord u, Tolerance u) +            => Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -> RelPath u +consCurveTo v1 v2 v3 (RelPath len se) = RelPath (len + cl) $ JL.cons s se+  where+    (cl,s) = curveSegment v1 v2 v3 -snocCurveTo :: RelPath u -> Vec2 u -> Vec2 u -> Vec2 u -> RelPath u-snocCurveTo (RelPath se) v1 v2 v3 = RelPath $ JL.snoc se (RelCurveSeg v1 v2 v3)+snocCurveTo :: (Floating u, Ord u, Tolerance u) +            => RelPath u -> Vec2 u -> Vec2 u -> Vec2 u -> RelPath u+snocCurveTo (RelPath len se) v1 v2 v3 = RelPath (len + cl) $ JL.snoc se s+  where+    (cl,s) = curveSegment v1 v2 v3   @@ -209,45 +282,46 @@ -------------------------------------------------------------------------------- -- Conversion -fromPathAlgVertices :: Num u => PathAlg u -> (Vec2 u, RelPath u)+fromPathAlgVertices :: Floating u => PathAlg u -> (Vec2 u, RelPath u) fromPathAlgVertices = bimap fn vertexPath . runPathAlgVec   where     fn = maybe (V2 0 0) id -fromPathAlgCurves :: Num u => PathAlg u -> (Vec2 u, RelPath u)+fromPathAlgCurves :: Floating u => PathAlg u -> (Vec2 u, RelPath u) fromPathAlgCurves = bimap fn curvedPath . runPathAlgVec   where     fn = maybe (V2 0 0) id  -toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query PrimPath-toPrimPath start (RelPath segs) = +toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query u PrimPath+toPrimPath start (RelPath _ segs) =      uconvertCtxF start       >>= \dstart ->      T.mapM uconvertCtxF segs >>= \dsegs  ->     return $ relPrimPath dstart $ F.foldr fn [] dsegs   where-    fn (RelLineSeg v1)        ac = relLineTo v1 : ac-    fn (RelCurveSeg v1 v2 v3) ac = relCurveTo v1 v2 v3 : ac+    fn (RelLineSeg _ v1)        ac = relLineTo v1 : ac+    fn (RelCurveSeg _ v1 v2 v3) ac = relCurveTo v1 v2 v3 : ac  + toAbsPath :: (Floating u, Ord u, Tolerance u)            => Point2 u -> RelPath u -> AbsPath u-toAbsPath start (RelPath segs) = step1 start $ viewl segs+toAbsPath start (RelPath _ segs) = step1 start $ viewl segs   where     step1 p0 EmptyL                           = Abs.empty p0 -    step1 p0 (RelLineSeg v1 :< se)            = +    step1 p0 (RelLineSeg _ v1 :< se)            =          let (pth,end) = aline p0 v1 in step2 end pth (viewl se) -    step1 p0 (RelCurveSeg v1 v2 v3 :< se)     = +    step1 p0 (RelCurveSeg _ v1 v2 v3 :< se)     =          let (pth,end) = acurve p0 v1 v2 v3 in step2 end pth (viewl se)      step2 _  acc EmptyL                       = acc-    step2 p0 acc (RelLineSeg v1 :< se)        = +    step2 p0 acc (RelLineSeg _ v1 :< se)        =          let (s1,end) = aline p0 v1          in step2 end (acc `Abs.append` s1) (viewl se) -    step2 p0 acc (RelCurveSeg v1 v2 v3 :< se) = +    step2 p0 acc (RelCurveSeg _ v1 v2 v3 :< se) =          let (s1,end) = acurve p0 v1 v2 v3          in step2 end (acc `Abs.append` s1) (viewl se) @@ -262,8 +336,14 @@   -strokeRelPath :: InterpretUnit u => RelPath u -> LocGraphic u-strokeRelPath rp = -    promoteR1 $ \start -> toPrimPath start rp >>= openStroke+openRelPath :: InterpretUnit u +            => RelPath u -> LocImage u (RelPath u)+openRelPath rp = replaceAns rp $ +    promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcOpenPath ++closedRelPath :: InterpretUnit u +              => DrawStyle -> RelPath u -> LocImage u (RelPath u)+closedRelPath sty rp = replaceAns rp $ +    promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcClosedPath sty 

@@ -17,11 +17,11 @@ module Wumpus.Drawing.Paths.Relative   (  -    module Wumpus.Drawing.Paths.Base.RelBuilder+    module Wumpus.Drawing.Paths.Base.PathBuilder   , module Wumpus.Drawing.Paths.Base.RelPath    ) where -import Wumpus.Drawing.Paths.Base.RelBuilder+import Wumpus.Drawing.Paths.Base.PathBuilder import Wumpus.Drawing.Paths.Base.RelPath 

@@ -10,7 +10,7 @@ -- Stability   :  highly unstable -- Portability :  GHC ----- Shim import module for the Absolute Path modules.+-- Library of vamps (currently small). -- --  --------------------------------------------------------------------------------@@ -18,22 +18,17 @@ module Wumpus.Drawing.Paths.Vamps   (  -    -- * Re-exported types-    Vamp(..)-  , PathEnd(..)--  , circleVamp+    squareWE    ) where -import Wumpus.Drawing.Paths.Base.BuildCommon+import Wumpus.Drawing.Paths.Base.PathBuilder import Wumpus.Drawing.Paths.Base.RelPath -import Wumpus.Basic.Geometry                    -- package: wumpus-basic+import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core -import Data.VectorSpace                         -- package: vector-space   -- TODO - library of useful / illustrative vamps (circle, square etc.)@@ -41,16 +36,11 @@   -circleVamp :: (Fractional u, Floating u) => Vec2 u -> Vamp u-circleVamp v0 = Vamp { vamp_move_span   = v0-                     , vamp_move_start  = half_v0 ^+^ v1-                     , vamp_dc_update   = id-                     , vamp_deco_path   = path-                     , vamp_path_end    = PATH_CLOSED-                     }+squareWE :: (Fractional u, Floating u) => u -> Vamp u+squareWE diam = makeVamp (hvec diam) rpath (SUBPATH_CLOSED STROKE)   where-    radius      = 0.5 * vlength v0-    half_v0     = 0.5 *^ v0-    (v1,path)   = fromPathAlgCurves $ circlePathAlg radius+    hdiam = 0.5 * diam+    rpath = vertexPath [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ] -    -- Note - circlePathAlg starts from east++-- Drawing a cirle is probably best done with 90deg arcs.

@@ -82,21 +82,16 @@       , shape_decoration  :: LocThetaGraphic u       } +type instance DUnit (Shape t u) = u  type DShape t = Shape t Double  ---- Design note - shapes look like they should be constrained to --- InterpretUnit rather than CtxSize, this allows direct affine --- transformations.---- --------------------------------------------------------------------------------  shapeMap :: (t u -> t' u) -> Shape t u -> Shape t' u-shapeMap f = (\s sf -> s { shape_ans_fun = promoteR2 $ \pt ang -> -                                           fmap f $ apply2R2 sf pt ang }) +shapeMap f = (\s sf -> s { shape_ans_fun = qpromoteLocTheta $ \pt ang -> +                                           fmap f $ qapplyLocTheta sf pt ang })                  <*> shape_ans_fun  @@ -116,14 +111,14 @@           => LocThetaQuery u (t u) -> LocThetaQuery u (AbsPath u) -> Shape t u makeShape f g = Shape { shape_ans_fun    = f                       , shape_path_fun   = g-                      , shape_decoration = emptyLocThetaGraphic+                      , shape_decoration = emptyLocThetaImage                       }     strokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-strokedShape = shapeToLoc closedStroke+strokedShape = shapeToLoc (dcClosedPath STROKE)   -- | Note - this is simplistic double stroking - draw a background @@ -136,59 +131,59 @@ -- Probably Wumpus should calculate two paths instead. -- dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-dblStrokedShape sh = decorateR1 back fore +dblStrokedShape sh = decorate back fore    where-    img  = shapeToLoc closedStroke sh+    img  = shapeToLoc (dcClosedPath STROKE) sh     back = getLineWidth >>= \lw ->            localize (set_line_width $ lw * 3.0) img-    fore = pushR1 ignoreAns $ localize (stroke_colour white) img+    fore = ignoreAns $ localize (stroke_colour white) img    filledShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-filledShape = shapeToLoc filledPath+filledShape = shapeToLoc (dcClosedPath FILL)   borderedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-borderedShape = shapeToLoc borderedPath+borderedShape = shapeToLoc (dcClosedPath FILL_STROKE)   shapeToLoc :: InterpretUnit u            => (PrimPath -> Graphic u) -> Shape t u -> LocImage u (t u)-shapeToLoc drawF sh = promoteR1 $ \pt -> -    apply2R2 (shape_ans_fun sh)  pt 0 >>= \a -> -    apply2R2 (shape_path_fun sh) pt 0 >>= \spath -> +shapeToLoc drawF sh = promoteLoc $ \pt -> +    zapLocThetaQuery (shape_ans_fun sh)  pt 0 >>= \a -> +    zapLocThetaQuery (shape_path_fun sh) pt 0 >>= \spath ->      let g2 = atIncline (shape_decoration sh) pt 0 -    in intoImage (pure a) (decorateR0 g2 $ toPrimPath spath >>= drawF)+    in replaceAns a (decorate g2 $ zapQuery (toPrimPath spath) >>= drawF)    rstrokedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)-rstrokedShape = shapeToLocTheta closedStroke+rstrokedShape = shapeToLocTheta (dcClosedPath STROKE)   rfilledShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)-rfilledShape = shapeToLocTheta filledPath+rfilledShape = shapeToLocTheta (dcClosedPath FILL)   rborderedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)-rborderedShape = shapeToLocTheta borderedPath+rborderedShape = shapeToLocTheta (dcClosedPath FILL_STROKE)   shapeToLocTheta :: InterpretUnit u                 => (PrimPath -> Graphic u) -> Shape t u -> LocThetaImage u (t u)-shapeToLocTheta drawF sh = promoteR2 $ \pt theta -> -    apply2R2 (shape_ans_fun sh)  pt theta >>= \a -> -    apply2R2 (shape_path_fun sh) pt theta >>= \spath -> +shapeToLocTheta drawF sh = promoteLocTheta $ \pt theta -> +    zapLocThetaQuery (shape_ans_fun  sh) pt theta >>= \a -> +    zapLocThetaQuery (shape_path_fun sh) pt theta >>= \spath ->      let g2 = atIncline (shape_decoration sh) pt theta-    in intoImage (pure a) (decorateR0 g2 $ toPrimPath spath >>= drawF)+    in replaceAns a $ decorate g2 (zapQuery (toPrimPath spath) >>= drawF)    -- | Draw the shape path with round corners. --  roundCornerShapePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)-                     => u -> [Point2 u] -> Query (AbsPath u)+                     => u -> [Point2 u] -> Query u (AbsPath u) roundCornerShapePath sz xs =      if sz `tEQ` 0 then return (vertexPath xs) else return (roundTrail  sz xs) @@ -203,8 +198,8 @@ --  updatePathAngle :: (Radian -> Radian) -> Shape t u -> Shape t u updatePathAngle f = -    (\s i -> s { shape_path_fun = promoteR2 $ \pt ang -> -                                  apply2R2 i pt (mvTheta ang) })+    (\s fi -> s { shape_path_fun = qpromoteLocTheta $ \pt ang -> +                                   qapplyLocTheta fi pt (mvTheta ang) })       <*> shape_path_fun   where     mvTheta = circularModulo . f 

@@ -120,7 +120,7 @@   mkCircle :: InterpretUnit u => u -> LocThetaQuery u (Circle u)-mkCircle radius = promoteR2 $ \ctr theta -> +mkCircle radius = qpromoteLocTheta $ \ctr theta ->      pure $ Circle { circ_ctm    = makeShapeCTM ctr theta                   , circ_radius = radius                    }@@ -130,7 +130,7 @@ -- mkCirclePath :: (Floating u, Ord u, InterpretUnit u, Tolerance u)              => u -> LocThetaQuery u (AbsPath u)-mkCirclePath radius = promoteR2 $ \ctr _ -> +mkCirclePath radius = qpromoteLocTheta $ \ctr _ ->     pure $ curvePath $ bezierCircle radius ctr   

@@ -145,7 +145,7 @@   mkDiamond :: InterpretUnit u => u -> u -> LocThetaQuery u (Diamond u)-mkDiamond hw hh = promoteR2 $ \ctr theta -> +mkDiamond hw hh = qpromoteLocTheta $ \ctr theta ->      pure $ Diamond { dia_ctm = makeShapeCTM ctr theta                    , dia_hw  = hw                    , dia_hh  = hh @@ -154,9 +154,9 @@  mkDiamondPath :: (Real u, Floating u, InterpretUnit u, Tolerance u)               => u -> u -> u -> LocThetaQuery u (AbsPath u)-mkDiamondPath rnd hw hh = promoteR2 $ \ctr theta ->-    let ps = map (rotateAbout theta ctr) $ diamondCoordPath hw hh ctr-    in roundCornerShapePath rnd ps+mkDiamondPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> +    let ps = runPathAlgPoint ctr $ diamondPathAlg hw hh+    in roundCornerShapePath rnd $ map (rotateAbout theta ctr) ps   

@@ -139,7 +139,7 @@   mkEllipse :: InterpretUnit u => u -> u -> LocThetaQuery u (Ellipse u)-mkEllipse rx ry = promoteR2 $ \ctr theta -> +mkEllipse rx ry = qpromoteLocTheta $ \ctr theta ->      pure $ Ellipse { ell_ctm = makeShapeCTM ctr theta                    , ell_rx  = rx                    , ell_ry  = ry @@ -148,7 +148,7 @@  mkEllipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)                => u -> u -> LocThetaQuery u (AbsPath u)-mkEllipsePath rx ry = promoteR2 $ \pt theta -> +mkEllipsePath rx ry = qpromoteLocTheta $ \pt theta ->      let xs = map (rotateAbout theta pt) $ bezierEllipse rx ry pt     in return $ curvePath xs 

@@ -30,13 +30,12 @@ import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic-import Wumpus.Basic.Geometry.Intersection-import Wumpus.Basic.Geometry.Paths+import Wumpus.Basic.Geometry                    -- package: wumpus-basic import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core +import Data.VectorSpace                         -- package: vector-space  import Control.Applicative @@ -53,34 +52,17 @@       , pll_base_width  :: !u       , pll_height      :: !u       , pll_base_l_ang  :: Radian-      , pll_syn_props   :: SyntheticProps u       }  type instance DUnit (Parallelogram u) = u --- | Note (center) is a line dropped from the center of the--- paralleogram.--- --- > base_minor is the (center) to left corner.--- > base_major is the (center) to right corner.----data SyntheticProps u = SyntheticProps-      { pll_base_minor  :: u-      , pll_base_major  :: u-      } -type instance DUnit (SyntheticProps u) = u-- type DParallelogram = Parallelogram Double   instance Functor Parallelogram where-  fmap f (Parallelogram ctm bw h lang props) = -      Parallelogram (fmap f ctm) (f bw) (f h) lang (fmap f props)--instance Functor SyntheticProps where-  fmap f (SyntheticProps bmin bmaj) = SyntheticProps (f bmin) (f bmaj)+  fmap f (Parallelogram ctm bw h lang) = +      Parallelogram (fmap f ctm) (f bw) (f h) lang   @@ -112,32 +94,43 @@ --                           * base_major -> Vec ) * parallelogram -> Point @ -- runDisplaceCenter :: (Real u, Floating u)-                  => (u -> u -> u -> u -> Vec2 u) -> Parallelogram u -> Anchor u+                  => (u -> u -> Radian -> Vec2 u) -> Parallelogram u -> Anchor u runDisplaceCenter fn (Parallelogram { pll_ctm        = ctm                                     , pll_base_width = bw-                                    , pll_height     = h  -                                    , pll_syn_props  = syn }) = -    projectFromCtr (fn (0.5 * bw) (0.5 * h) -                       (pll_base_minor syn) (pll_base_major syn)) ctm+                                    , pll_height     = h +                                    , pll_base_l_ang = lang }) =+    projectFromCtr (fn (0.5 * bw) (0.5 * h) lang) ctm    instance (Real u, Floating u) =>      CenterAnchor (Parallelogram u) where-  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0+  center = runDisplaceCenter $ \_ _ _ -> V2 0 0 ++-- | WARNING - WRONG...+ -- top anchors swap the base minor and major... --+ instance (Real u, Floating u) =>      TopCornerAnchor (Parallelogram u) where-  topLeftCorner  = runDisplaceCenter $ \_ hh _ bmaj -> V2 (-bmaj) hh-  topRightCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 bmin    hh+  topLeftCorner  = runDisplaceCenter $ \hw hh lang -> +      let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang hypo +  topRightCorner = runDisplaceCenter $ \hw hh lang ->+      let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang hypo+ instance (Real u, Floating u) =>      BottomCornerAnchor (Parallelogram u) where-  bottomLeftCorner  = runDisplaceCenter $ \_ hh bmin _ -> V2 (-bmin) (-hh)-  bottomRightCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 bmaj    (-hh)+  bottomLeftCorner  = runDisplaceCenter $ \hw hh lang ->+      let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang (-hypo) +  bottomRightCorner = runDisplaceCenter $ \hw hh lang -> +      let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang (-hypo)+++ instance (Real u, Floating u) =>      SideMidpointAnchor (Parallelogram u) where   sideMidpoint n a = step (n `mod` 4) @@ -151,10 +144,10 @@  instance (Real u, Floating u) =>      CardinalAnchor (Parallelogram u) where-  north = runDisplaceCenter $ \_  hh _ _ -> V2 0 hh-  south = runDisplaceCenter $ \_  hh _ _ -> V2 0 (-hh)-  east  = runDisplaceCenter $ \hw _  _ _ -> V2 hw 0-  west  = runDisplaceCenter $ \hw _  _ _ -> V2 (-hw) 0+  north = runDisplaceCenter $ \_  hh _ -> V2 0 hh+  south = runDisplaceCenter $ \_  hh _ -> V2 0 (-hh)+  east  = runDisplaceCenter $ \hw _  _ -> V2 hw 0+  west  = runDisplaceCenter $ \hw _  _ -> V2 (-hw) 0   instance (Real u, Floating u, InterpretUnit u, Tolerance u) => @@ -171,17 +164,23 @@    radialAnchor = pllRadialAnchor  --- TODO - update this to a quadrant function...+-- | Note - it is not worth changing this to a quadrantAlg. --+-- There are pathological parallelograms that the current +-- QuadrantAlg code cannot handle, and a better abstraction is+-- needed (rather than better implementation of QuadrantAlg).+-- pllRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u)                  => Radian -> Parallelogram u -> Anchor u-pllRadialAnchor theta (Parallelogram { pll_ctm       = ctm-                                     , pll_height    = h-                                     , pll_syn_props = syn }) =+pllRadialAnchor theta (Parallelogram { pll_ctm         = ctm+                                     , pll_base_width  = bw+                                     , pll_height      = h+                                     , pll_base_l_ang  = lang }) =     post $ findIntersect zeroPt theta $ polygonLineSegments ps   where -    ps   = pllPoints (pll_base_minor syn) (pll_base_major syn) h-    post = \ans -> case ans of +    ps    = runVertices4 zeroPt $ parallelogramVertices bw h lang++    post  = \ans -> case ans of                      Nothing       -> projectFromCtr (V2 0 0) ctm                     Just (P2 x y) -> projectFromCtr (V2 x y) ctm     @@ -196,10 +195,7 @@ parallelogram :: (Real u, Floating u, InterpretUnit u, Tolerance u)                => u -> u -> Radian -> Shape Parallelogram u parallelogram bw h lang =-    let props = synthesizeProps bw h lang -    in makeShape (mkParallelogram bw h lang props) -                 (mkParallelogramPath 0 (pll_base_minor props) -                                        (pll_base_major props) h)+    makeShape (mkParallelogram bw h lang) (mkParallelogramPath 0 bw h lang)   -- | 'zparallelogram'  : @ base_width * height -> Parallelogram @@@ -216,64 +212,23 @@   mkParallelogram :: (Real u, Fractional u, InterpretUnit u, Tolerance u) -                => u -> u -> Radian -> SyntheticProps u -                -> LocThetaQuery u (Parallelogram u)-mkParallelogram bw h lang props = promoteR2 $ \ctr theta -> +                => u -> u -> Radian -> LocThetaQuery u (Parallelogram u)+mkParallelogram bw h lang = qpromoteLocTheta $ \ctr theta ->      pure $ Parallelogram { pll_ctm          = makeShapeCTM ctr theta                          , pll_base_width   = bw                          , pll_height       = h                          , pll_base_l_ang   = lang-                         , pll_syn_props    = props                          } --- Note - expects ang value 0 < ang < 180, though does not check...--- -synthesizeProps :: Fractional u => u -> u -> Radian -> SyntheticProps u-synthesizeProps bw h lang -    | lang == 0.5*pi = let hw = 0.5 * bw in SyntheticProps hw hw-    | lang >  0.5*pi = less_ninety-    | otherwise      = grtr_ninety-  where-    less_ninety = let extw            = h / (fromRadian $ tan lang)-                      half_rect_width = 0.5 * (bw + extw)-                  in SyntheticProps half_rect_width (half_rect_width - extw) -    grtr_ninety = let extw            = h / (fromRadian $ tan (pi-lang))-                      half_rect_width = 0.5 * (bw + extw)-                  in SyntheticProps (half_rect_width - extw) half_rect_width -                        -- mkParallelogramPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) -                    => u -> u -> u -> u -> LocThetaQuery u (AbsPath u)-mkParallelogramPath rnd bw_minor bw_major h = promoteR2 $ \ctr theta -> -    let xs = pllPath bw_minor bw_major h ctr+                    => u -> u -> u -> Radian -> LocThetaQuery u (AbsPath u)+mkParallelogramPath rnd bw h lang = qpromoteLocTheta $ \ctr theta -> +    let xs = runVertices4 ctr  $ parallelogramVertices bw h lang     in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs                           ---pllPath :: (Real u, Floating u) -       => u -> u -> u -> LocCoordPath u-pllPath bw_minor bw_major h (P2 x y) = [ bl, br, tr, tl ]-  where-    hh = 0.5 * h-    bl = P2 (x - bw_minor) (y - hh)-    br = P2 (x + bw_major) (y - hh)-    tl = P2 (x - bw_major) (y + hh)     -- topleft subtracts major-    tr = P2 (x + bw_minor) (y + hh)     -- topright adds minor---pllPoints :: (Real u, Floating u) -          => u -> u -> u -> [Point2 u]-pllPoints bw_minor bw_major h = [ bl, br, tr, tl ]-  where-    hh = 0.5 * h     -    bl = P2 (-bw_minor) (-hh) -    br = P2   bw_major  (-hh)-    tl = P2 (-bw_major) hh-    tr = P2   bw_minor  hh   

@@ -30,8 +30,7 @@ import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Paths              -- package: wumpus-basic-import Wumpus.Basic.Geometry.Quadrant+import Wumpus.Basic.Geometry                    -- package: wumpus-basic import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core@@ -153,7 +152,7 @@   mkRectangle :: InterpretUnit u => u -> u -> LocThetaQuery u (Rectangle u)-mkRectangle hw hh = promoteR2 $ \ctr theta -> +mkRectangle hw hh = qpromoteLocTheta $ \ctr theta ->      pure $ Rectangle { rect_ctm    = makeShapeCTM ctr theta                      , rect_hw     = hw                      , rect_hh     = hh@@ -162,9 +161,8 @@  mkRectPath :: (Real u, Floating u, InterpretUnit u, Tolerance u)             => u -> u -> u -> LocThetaQuery u (AbsPath u)-mkRectPath rnd hw hh = promoteR2 $ \ctr theta -> -    let btm_left = displace (-hw) (-hh) ctr-        xs       = rectangleCoordPath (2*hw) (2*hh) btm_left+mkRectPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> +    let xs       = runVertices4 ctr $ rectangleVertices hw hh     in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs      

@@ -46,15 +46,15 @@ data Semicircle u = Semicircle        { sc_ctm          :: ShapeCTM u       , sc_radius       :: !u -      , sc_syn_props    :: SyntheticProps u       }  type instance DUnit (Semicircle u) = u --- | rect_width is the width of the (greater) enclosing rectangle.-data SyntheticProps u = SyntheticProps-      { sc_ctr_minor  :: u-      , sc_ctr_major  :: u+-- | Height minor and major.+--+data SyntheticProps u = SP+      { sc_hminor  :: u+      , sc_hmajor  :: u       }  type instance DUnit (SyntheticProps u) = u@@ -64,12 +64,26 @@   instance Functor Semicircle where-  fmap f (Semicircle ctm r props) = Semicircle (fmap f ctm) (f r) (fmap f props)+  fmap f (Semicircle ctm r) = Semicircle (fmap f ctm) (f r) -instance Functor SyntheticProps where-  fmap f (SyntheticProps cmin cmaj) = SyntheticProps (f cmin) (f cmaj)  +-- | Use the formula:+--+-- >   4r+-- >  ---+-- >  3pi+--+-- to get the yminor.+--+synthesizeProps :: Floating u => u -> SyntheticProps u+synthesizeProps radius = +    SP { sc_hminor = hminor, sc_hmajor = hmajor  }+  where+    hminor = (4 * radius) / (3 * pi)+    hmajor = radius - hminor++ -------------------------------------------------------------------------------- -- Affine trans @@ -100,10 +114,12 @@ runDisplaceCenter :: (Real u, Floating u)                    => (u -> u -> u -> Vec2 u) -> Semicircle u -> Anchor u runDisplaceCenter fn (Semicircle { sc_ctm       = ctm-                                 , sc_radius    = radius-                                 , sc_syn_props = syn    }) = -    projectFromCtr (fn radius (sc_ctr_minor syn) (sc_ctr_major syn)) ctm-+                                 , sc_radius    = radius }) = +    projectFromCtr (fn radius hminor hmajor) ctm+  where+    props  = synthesizeProps radius  +    hminor = sc_hminor props+    hmajor = sc_hmajor props  instance (Real u, Floating u) =>      CenterAnchor (Semicircle u) where@@ -151,22 +167,28 @@  -- helpers +-- | Semicircle does not fit into a QuadrantAlg easily.+--+-- So all the work has to be done here.+-- scRadialVec :: (Real u, Floating u, Ord u, Tolerance u)             => Radian -> u -> u -> u -> Vec2 u-scRadialVec theta radius hminor _ = go theta+scRadialVec theta radius hminor _ = go (circularModulo theta)   where     (lang,rang)                     = baselineRange radius hminor     (bctr, br, _, bl)               = constructionPoints radius hminor-    plane                           = makePlane zeroPt theta+    plane                           = inclinedLine zeroPt theta     base_line                       = LineSegment bl br     left_curve                      = mkCurve radius half_pi bctr     right_curve                     = mkCurve radius 0 bctr     post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)-    go a | lang <= a && a <= rang   = post $ interLinesegLine base_line plane -         | half_pi <= a && a < lang = post $ interCurveLine left_curve plane-         | otherwise                = post $ interCurveLine right_curve plane+    go a +      | lang    <= a && a <= rang   = post $ interLinesegLine base_line plane +      | half_pi <= a && a <  lang   = post $ interCurveLine left_curve plane+      | otherwise                   = post $ interCurveLine right_curve plane  + mkCurve :: Floating u => u -> Radian -> Point2 u -> BezierCurve u mkCurve radius theta ctr = BezierCurve p0 p1 p2 p3   where@@ -186,7 +208,7 @@     bctr  = P2 0 (-hminor)     br    = bctr .+^ hvec radius     apx   = bctr .+^ vvec radius-    bl    = bctr .-^ hvec radius+    bl    = bctr .+^ hvec (-radius)   @@ -212,26 +234,16 @@            => u -> Shape Semicircle u semicircle radius =      let props = synthesizeProps radius-    in makeShape (mkSemicircle radius props) -                 (mkSemicirclePath radius (sc_ctr_minor props))+    in makeShape (mkSemicircle radius) +                 (mkSemicirclePath radius (sc_hminor props))            -synthesizeProps :: Floating u => u -> SyntheticProps u-synthesizeProps radius = -    SyntheticProps { sc_ctr_minor  = cminor-                   , sc_ctr_major  = cmajor-                   }-  where-    cminor = (4 * radius) / (3 * pi)-    cmajor = radius - cminor - mkSemicircle :: InterpretUnit u-             => u -> SyntheticProps u -> LocThetaQuery u (Semicircle u)-mkSemicircle radius props = promoteR2 $ \ctr theta -> -    pure $ Semicircle { sc_ctm = makeShapeCTM ctr theta+             => u -> LocThetaQuery u (Semicircle u)+mkSemicircle radius = qpromoteLocTheta $ \ctr theta -> +    pure $ Semicircle { sc_ctm    = makeShapeCTM ctr theta                       , sc_radius = radius-                      , sc_syn_props = props                        }  @@ -241,7 +253,7 @@ -- mkSemicirclePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)                   => u -> u -> LocThetaQuery u (AbsPath u)-mkSemicirclePath radius cminor = promoteR2 $ \pt theta ->-    let ctr = displacePerpendicular (-cminor) theta pt+mkSemicirclePath radius cminor = qpromoteLocTheta $ \pt theta ->+    let ctr = dispPerpendicular (-cminor) theta pt     in pure $ curvePath $ bezierArcPoints pi radius theta ctr  

@@ -46,15 +46,14 @@       { se_ctm          :: ShapeCTM u       , se_rx           :: !u        , se_ry           :: !u-      , se_syn_props    :: SyntheticProps u       }  type instance DUnit (Semiellipse u) = u --- | rect_width is the width of the (greater) enclosing rectangle.-data SyntheticProps u = SyntheticProps-      { se_ry_minor  :: u-      , se_ry_major  :: u++data SyntheticProps u = SP+      { se_hminor  :: u+      , se_hmajor  :: u       }  type instance DUnit (SyntheticProps u) = u@@ -62,12 +61,18 @@ type DSemiellipse = Semiellipse Double  instance Functor Semiellipse where-  fmap f (Semiellipse ctm rx ry props) = -    Semiellipse (fmap f ctm) (f rx) (f ry) (fmap f props)+  fmap f (Semiellipse ctm rx ry) = Semiellipse (fmap f ctm) (f rx) (f ry) -instance Functor SyntheticProps where-  fmap f (SyntheticProps rymin rymaj) = SyntheticProps (f rymin) (f rymaj) ++synthesizeProps :: Floating u => u -> SyntheticProps u+synthesizeProps ry = +    SP { se_hminor = ry_minor, se_hmajor = ry_major }+  where+    ry_minor = (4 * ry) / (3 * pi)+    ry_major = ry - ry_minor++ -------------------------------------------------------------------------------- -- Affine trans @@ -101,9 +106,12 @@                   => (u -> u -> u -> u -> Vec2 u) -> Semiellipse u -> Anchor u runDisplaceCenter fn (Semiellipse { se_ctm       = ctm                                   , se_rx        = rx-                                  , se_ry        = ry-                                  , se_syn_props = syn    }) = -    projectFromCtr (fn rx ry (se_ry_minor syn) (se_ry_major syn)) ctm+                                  , se_ry        = ry  }) = +    projectFromCtr (fn rx ry hminor hmajor) ctm+  where+    props  = synthesizeProps ry  +    hminor = se_hminor props+    hmajor = se_hmajor props   @@ -149,7 +157,7 @@   where     (lang,rang)                     = baselineRange rx hminor     (bctr, br, _, bl)               = constructionPoints rx ry hminor-    plane                           = makePlane zeroPt theta+    plane                           = inclinedLine zeroPt theta     base_line                       = LineSegment bl br     (right_curve,left_curve)        = bezierSemiellipse rx ry bctr     post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)@@ -200,34 +208,24 @@             => u -> u -> Shape Semiellipse u semiellipse rx ry =      let props = synthesizeProps ry-    in makeShape (mkSemiellipse rx ry props) -                 (mkSemiellipsePath rx ry (se_ry_minor props))+    in makeShape (mkSemiellipse rx ry) +                 (mkSemiellipsePath rx ry (se_hminor props))             -synthesizeProps :: Floating u => u -> SyntheticProps u-synthesizeProps ry = -    SyntheticProps { se_ry_minor  = ry_minor-                   , se_ry_major  = ry_major-                   }-  where-    ry_minor = (4 * ry) / (3 * pi)-    ry_major = ry - ry_minor --mkSemiellipse :: u -> u -> SyntheticProps u -> LocThetaQuery u (Semiellipse u)-mkSemiellipse rx ry props = promoteR2 $ \ctr theta -> +mkSemiellipse :: u -> u -> LocThetaQuery u (Semiellipse u)+mkSemiellipse rx ry = qpromoteLocTheta $ \ctr theta ->      pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta                        , se_rx = rx                        , se_ry = ry-                       , se_syn_props = props                         }   mkSemiellipsePath :: (Real u, Floating u, Tolerance u)                    => u -> u -> u -> LocThetaQuery u (AbsPath u)-mkSemiellipsePath rx ry cminor = promoteR2 $ \pt theta ->-    let ctr = displacePerpendicular (-cminor) theta pt+mkSemiellipsePath rx ry hminor = qpromoteLocTheta $ \pt theta ->+    let ctr = dispPerpendicular (-hminor) theta pt         xs  = bezierSemiellipsePoints rx ry ctr     in return $ curvePath $ map (rotateAbout theta ctr) xs