wumpus-drawing 0.6.0 → 0.7.0

raw patch · 54 files changed

+2707/−2436 lines, 54 filesdep ~wumpus-basicdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic, wumpus-core

API changes (from Hackage documentation)

Files

• demo/ArrowCircuit.hs +21/−3
• demo/Arrowheads.hs +11/−6
• demo/Automata.hs +18/−12
• demo/ClipPic.hs +16/−14
• demo/ColourCharts.hs +3/−3
• demo/Connectors.hs +37/−31
• demo/DotPic.hs +14/−11
• demo/FeatureModel.hs +10/−3
• demo/FontPic.hs +9/−6
• demo/LeftRightText.hs +12/−12
• demo/PetriNet.hs +34/−12
• demo/SampleShapes.hs +2/−2
• demo/SingleChar.hs +1/−1
• demo/SingleLine.hs +2/−2
• demo/Symbols.hs +53/−197
• src/Wumpus/Drawing/Basis/DrawingPrimitives.hs +30/−32
• src/Wumpus/Drawing/Basis/Symbols.hs +165/−0
• src/Wumpus/Drawing/Connectors.hs +4/−2
• src/Wumpus/Drawing/Connectors/Arrowheads.hs +33/−56
• src/Wumpus/Drawing/Connectors/Base.hs +16/−41
• src/Wumpus/Drawing/Connectors/BoxConnectors.hs +57/−11
• src/Wumpus/Drawing/Connectors/ConnectorPaths.hs +224/−78
• src/Wumpus/Drawing/Connectors/ConnectorProps.hs +148/−0
• src/Wumpus/Drawing/Dots/AnchorDots.hs +13/−12
• src/Wumpus/Drawing/Dots/SimpleDots.hs +36/−30
• src/Wumpus/Drawing/Extras/Axes.hs +30/−4
• src/Wumpus/Drawing/Extras/Clip.hs +10/−5
• src/Wumpus/Drawing/Extras/Grids.hs +6/−6
• src/Wumpus/Drawing/Extras/Loop.hs +3/−3
• src/Wumpus/Drawing/Paths.hs +30/−0
• src/Wumpus/Drawing/Paths/Absolute.hs +0/−28
• src/Wumpus/Drawing/Paths/Base.hs +967/−0
• src/Wumpus/Drawing/Paths/Base/AbsPath.hs +0/−852
• src/Wumpus/Drawing/Paths/Base/PathBuilder.hs +0/−465
• src/Wumpus/Drawing/Paths/Base/RelPath.hs +0/−363
• src/Wumpus/Drawing/Paths/PathBuilder.hs +470/−0
• src/Wumpus/Drawing/Paths/Relative.hs +0/−27
• src/Wumpus/Drawing/Paths/Vamps.hs +8/−7
• src/Wumpus/Drawing/Shapes/Base.hs +10/−9
• src/Wumpus/Drawing/Shapes/Circle.hs +1/−1
• src/Wumpus/Drawing/Shapes/Diamond.hs +3/−4
• src/Wumpus/Drawing/Shapes/Ellipse.hs +1/−1
• src/Wumpus/Drawing/Shapes/Parallelogram.hs +1/−1
• src/Wumpus/Drawing/Shapes/Rectangle.hs +1/−1
• src/Wumpus/Drawing/Shapes/Semicircle.hs +1/−1
• src/Wumpus/Drawing/Shapes/Semiellipse.hs +1/−1
• src/Wumpus/Drawing/Shapes/Trapezium.hs +1/−1
• src/Wumpus/Drawing/Shapes/Triangle.hs +1/−1
• src/Wumpus/Drawing/Text/Base/DocTextZero.hs +81/−60
• src/Wumpus/Drawing/Text/Base/Label.hs +1/−1
• src/Wumpus/Drawing/Text/DirectionZero.hs +6/−6
• src/Wumpus/Drawing/Text/DocSymbols.hs +78/−0
• src/Wumpus/Drawing/VersionNumber.hs +2/−2
• wumpus-drawing.cabal +25/−9

@@ -11,6 +11,7 @@ module ArrowCircuit where  import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs@@ -78,7 +79,7 @@     -- Note - need a variant of /bar/ that draws UDLR only.  connWith :: ( Real u, Floating u, InterpretUnit u ) -         => Connector u -> Anchor u -> Anchor u -> TraceDrawing u ()+         => ConnectorPathQuery u -> Anchor u -> Anchor u -> TraceDrawing u () connWith con a0 a1 = localize double_point_size $      drawc a0 a1 (rightArrow tri45 con) @@ -87,13 +88,13 @@          , Real u, Floating u, InterpretUnit u)       => t u -> String -> TraceDrawing u () atext ancr ss = -    draw $ textline ss CENTER `at` (center ancr)+    draw $ textline CENTER ss `at` (center ancr)   ptext :: (Floating u, InterpretUnit u)        => Point2 u -> String -> TraceDrawing u () ptext pt ss = localize (font_attr times_italic 14) $ -    draw $ textline ss CENTER `at` pt+    draw $ textline CENTER ss `at` pt   -- Note - return type is a LocImage not a shape...@@ -104,3 +105,20 @@     -- This should have round corners but they are currently     -- disabled pending a re-think.      {- localize (round_corner_factor r) $ -} ++++-- Cf. Parsec\'s Token module...++connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u+connline = C.connline default_connector_props++connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +         => ConnectorPathQuery u+connabar = C.connabar default_connector_props+++connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) +           => ConnectorPathQuery u+connaright = C.connaright default_connector_props+

@@ -4,6 +4,7 @@  import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -76,9 +77,9 @@  tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double () tableGraphic tips = -    drawl start $ runChain_ (mapM makeArrowDrawing tips) chn_alg +    drawl start $ runTableColumnwise 18 (180,24) +                $ sequenceChain $ map arrowGraphic tips   where-    chn_alg = tableDown 18 (180,24)     start   = P2 0 480   @@ -89,13 +90,17 @@  -- Note - /null/ chain action needs a better type synonym name. ---makeArrowDrawing :: (String, ArrowTip) -> Chain Double (UNil Double)-makeArrowDrawing (name, utip) = cnext (aconn `mappend` lbl)+arrowGraphic :: (String, ArrowTip) -> LocGraphic Double+arrowGraphic (name, utip) = aconn `mappend` lbl   where     aconn = ignoreAns $ promoteLoc $ \pt ->-              connect pt (displace (hvec 60) pt) (uniformArrow utip connline)+              connect (uniformArrow utip connline) pt (displace (hvec 60) pt)      lbl   = ignoreAns $ promoteLoc $ \pt -> -              textline name WW `at` (displace (hvec 66) pt)+              textline WW name `at` (displace (hvec 66) pt)  +-- Cf. Parsec\'s Token module...++connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u+connline = C.connline default_connector_props

@@ -4,8 +4,9 @@ module Automata where  import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Extras.Loop-import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs@@ -48,13 +49,13 @@      s0     <- evalQuery $ left_of q0 -    draw $ label_midway_of SE (textline "0") $ straightconn q0 q1-    draw $ label_midway_of SS (textline "0") $ arrloop (center q1) (north q1) -    draw $ label_midway_of SW (textline "1") $ straightconn q1 q3-    draw $ label_midway_of NE (textline "1") $ straightconn q0 q2-    draw $ label_midway_of NW (textline "0") $ straightconn q2 q3-    draw $ label_midway_of NN (textline "1") $ arrloop (center q2) (south q2) -    draw $ label_atstart_of EE (textline "start") $ astraightconn s0 (west q0) +    draw $ label_midway_of SE (textline `flip` "0") $ straightconn q0 q1+    draw $ label_midway_of SS (textline `flip` "0") $ arrloop (center q1) (north q1) +    draw $ label_midway_of SW (textline `flip` "1") $ straightconn q1 q3+    draw $ label_midway_of NE (textline `flip` "1") $ straightconn q0 q2+    draw $ label_midway_of NW (textline `flip` "0") $ straightconn q2 q3+    draw $ label_midway_of NN (textline `flip` "1") $ arrloop (center q2) (south q2) +    draw $ label_atstart_of EE (textline `flip` "start") $ astraightconn s0 (west q0)       return () @@ -68,13 +69,13 @@ state :: String -> DLocImage DCircle state ss =      localize (set_font times_italic) $ -        label_center_of (textline ss) $ strokedShape $ circle 20+        label_center_of (textline `flip` ss) $ strokedShape $ circle 20   stopstate :: String -> DLocImage DCircle  stopstate ss =      localize (set_font times_italic) $ -        label_center_of (textline ss) $ dblStrokedShape $ circle 20+        label_center_of (textline `flip` ss) $ dblStrokedShape $ circle 20   @@ -86,12 +87,12 @@              => a -> b -> Image u (AbsPath u) straightconn a b =     let (p0,p1) = radialConnectorPoints a b-    in connect p0 p1 (rightArrow tri45 connline)+    in connect (rightArrow tri45 connline) p0 p1   astraightconn :: ( Real u, Floating u, InterpretUnit u)               => Anchor u -> Anchor u -> Image u (AbsPath u)-astraightconn p0 p1 = connect p0 p1 (rightArrow tri45 connline)+astraightconn p0 p1 = connect (rightArrow tri45 connline) p0 p1   -- Note - there is a problem with @rightArrow@ as @loop@@@ -107,6 +108,11 @@     zradius = vlength v1     zincl   = vdirection v1 ++-- Cf. Parsec\'s Token module...++connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u+connline = C.connline default_connector_props   

@@ -14,7 +14,7 @@  import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Extras.Clip-import Wumpus.Drawing.Paths.Relative+import Wumpus.Drawing.Paths import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic@@ -44,20 +44,23 @@  clip_pic :: CtxPicture clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do-    drawl (P2   0 320) $ (drawClosedPath FILL =<< zapLocQ (extrPathSpec path01))+    drawl (P2   0 320) $ runPathSpec_ CFILL path01     drawl (P2 112 320) $ localize (fill_colour powder_blue) $ -                         (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path02))-    drawl (P2 384 416) $ (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path03))-    drawl (P2 328 512) $ (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path04))+                           runPathSpec_ CFILL path02+    drawl (P2 384 416) $ runPathSpec_ CFILL path03+    drawl (P2 328 512) $ runPathSpec_ CFILL path04     drawl (P2   0   0) $ clip1     drawl (P2 112   0) $ clip2     drawl (P2 384  96) $ clip3     drawl (P2 328 192) $ clip4  +-- PathSpec is overkill here...+-- extrPathSpec :: InterpretUnit u -             => PathSpec u a -> LocQuery u (RelPath u)-extrPathSpec spec = fmap post $ stripGenPathSpec spec () (PATH_CLOSED STROKE)+             => PathSpec u a -> LocQuery u (AbsPath u)+extrPathSpec spec = qpromoteLoc $ \pt ->+    fmap post $ qapplyLoc (stripGenPathSpec () CSTROKE spec) pt   where     post (_,_,c) = c @@ -65,8 +68,8 @@ background rgb = promoteLoc $ \_ ->      ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288   where-    ihh = runChain (mapM cnext $ replicate 112 iheartHaskell) -                   (tableDown 18 (86,16)) +    ihh = runTableColumnwise 18 (86,16) $ mapM chain1 $ replicate 112 iheartHaskell+                     -- | This is one for Wumpus-Basic - the set of combinators to  -- shift between Images and Queries needs sorting out@@ -75,12 +78,11 @@ zapLocQ :: InterpretUnit u => LocQuery u a-> LocImage u a zapLocQ ma = promoteLoc $ \pt ->     askDC >>= \ctx ->-   let a = runLocQuery ma ctx pt-   in return a+   let a = runLocQuery ctx pt ma in return a  clip1 :: LocGraphic Double clip1 = zapLocQ (extrPathSpec path01) >>= \a -> -        ignoreAns $ locClip a (background black)+        locClip a (background black)    clip2 :: LocGraphic Double clip2 = zapLocQ (extrPathSpec path02) >>= \a -> @@ -108,14 +110,14 @@  -- zeroPt path01 :: UPathSpec Double-path01 =  do +path01 = do      hpenline 80      penline (vec 112 160)      penline (vec (-112) 160)     hpenline (-80)     penline (vec 112 (-160))     penline (vec (-112) (-160))-    ureturn +    ureturn   -- (P2 112 0)

@@ -43,9 +43,9 @@ makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs  tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double ()-tableGraphic row_count xs = draw $ (runChain (mapM cnext gs) chn) `at` pt+tableGraphic row_count xs = draw $ (runChain chn (mapM chain1 gs)) `at` pt   where-    chn  = tableDown row_count (152,11)+    chn  = tableColumnwiseScm row_count (152,11)     pt   = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt      gs   = map (uncurry colourSample) xs    @@ -53,7 +53,7 @@ colourSample :: String -> RGBi -> LocGraphic Double colourSample name rgb = localize (fill_colour rgb) $      promoteLoc $ \pt ->  -      mappend (blRectangle FILL_STROKE 15 10 `at` pt)+      mappend (blRectangle DRAW_FILL_STROKE 15 10 `at` pt)               (dcTextlabel name `at` displace (vec 20 2) pt)          

@@ -4,6 +4,7 @@  import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -34,39 +35,44 @@ makeCtx = set_font helvetica . metricsContext 11  conn_pic :: CtxPicture -conn_pic = drawTracing $ localize (dest_arm_len (0.75::Em))-                       $ tableGraphic conntable+conn_pic = drawTracing $ tableGraphic conntable -conntable :: [(String, Connector Double)]++conntable :: [(String, ConnectorPathQuery Double)] conntable = -    [ ("connline",      connline)-    , ("connarc",       connarc)-    , ("connhdiagh",    connhdiagh)-    , ("connvdiagv",    connvdiagv)-    , ("conndiagh",     conndiagh)-    , ("conndiagv",     conndiagv)-    , ("connhdiag",     connhdiag)-    , ("connvdiag",     connvdiag)-    , ("connabar",      connabar)-    , ("connbbar",      connbbar)-    , ("connaright",    connaright)-    , ("connbright",    connbright)-    , ("connhrr",       connhrr)-    , ("connrrh",       connrrh)-    , ("connvrr",       connvrr)-    , ("connrrv",       connrrv)-    , ("connaloop",     connaloop)-    , ("connbloop",     connbloop)-    , ("connhbezier",   connhbezier)-    , ("connvbezier",   connvbezier)+    [ ("connline",      C.connline props)+    , ("connarc",       C.connarc props)+    , ("connhdiagh",    C.connhdiagh props)+    , ("connvdiagv",    C.connvdiagv props)+    , ("conndiagh",     C.conndiagh props)+    , ("conndiagv",     C.conndiagv props)+    , ("connhdiag",     C.connhdiag props)+    , ("connvdiag",     C.connvdiag props)+    , ("connabar",      C.connabar props)+    , ("connbbar",      C.connbbar props)+    , ("connaright",    C.connaright props)+    , ("connbright",    C.connbright props)+    , ("connhrr",       C.connhrr  props)+    , ("connrrh",       C.connrrh props)+    , ("connvrr",       C.connvrr props)+    , ("connrrv",       C.connrrv props)+    , ("connaloop",     C.connaloop props)+    , ("connbloop",     C.connbloop props)+    , ("connhbezier",   C.connhbezier props)+    , ("connvbezier",   C.connvbezier props)     ]+  where+    props = default_connector_props { conn_dst_arm   = 2+                                    , conn_src_space = 0.5+                                    , conn_dst_space = 0.5 }  -tableGraphic :: [(String, Connector Double)] -> TraceDrawing Double ()++tableGraphic :: [(String, ConnectorPathQuery Double)] -> TraceDrawing Double () tableGraphic conns = -    draw $ runChain (mapM (cnext .  makeConnDrawing) conns) chn_alg `at` start+    drawl start $ ignoreAns $ runTableColumnwise 8 (180,64)+                $ mapM (chain1 .  makeConnDrawing) conns   where-    chn_alg   = tableDown 8 (180,64) -    start     = P2 0 520 +    start = P2 0 520     std_ctx :: DrawingContext@@ -74,15 +80,15 @@   -makeConnDrawing :: (String, Connector Double) -> DLocGraphic +makeConnDrawing :: (String, ConnectorPathQuery Double) -> DLocGraphic  makeConnDrawing (ss,conn) =      promoteLoc $ \p0 -> fn p0 (displace (vec 60 40) p0)    where     fn p0 p1   = mconcat [disk p0, disk p1, dcon p0 p1, lbl p1] -    disk pt    = localize (fill_colour red) $ dcDisk FILL 2 `at` pt-    dcon p0 p1 = ignoreAns $ connect p0 p1 (uniformArrow curveTip conn)+    disk pt    = localize (fill_colour red) $ dcDisk DRAW_FILL 2 `at` pt+    dcon p0 p1 = ignoreAns $ connect (uniformArrow curveTip conn) p0 p1 -    lbl  pt    = ignoreAns $ textline ss WW `at` (displace (hvec 10) pt)+    lbl  pt    = ignoreAns $ textline WW ss `at` (displace (hvec 10) pt)  

@@ -4,7 +4,7 @@  import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.AnchorDots-import Wumpus.Drawing.Paths.Relative+import Wumpus.Drawing.Paths import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -38,6 +38,9 @@ dot_pic = drawTracing $ tableGraphic dottable  +-- Note - dots should probably have lower_case_with_underscore +-- names.+ dottable :: [(String, DotLocImage Double)] dottable =        [ ("smallDisk",     smallDisk)@@ -45,8 +48,8 @@     , ("smallCirc",     smallCirc)     , ("largeCirc",     largeCirc)     , ("dotNone",       dotNone)-    , ("dotHLine",      dotHLine)-    , ("dotVLine",      dotVLine)+    , ("dotHBar",       dotHBar)+    , ("dotVBar",       dotVBar)     , ("dotX",          dotX)     , ("dotPlus",       dotPlus)     , ("dotCross",      dotCross)@@ -69,10 +72,10 @@  tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double () tableGraphic imgs = -    draw $ runChain_ (mapM (cnext . makeDotDrawing) imgs) chn_alg `at` pt+    drawl pt $ runTableColumnwise row_count (180,36) +             $ mapM (chain1 . makeDotDrawing) imgs   where     row_count   = 18-    chn_alg     = tableDown row_count (180,36)     pt          = displace (vvec $ fromIntegral $ 36 * row_count) zeroPt   @@ -82,17 +85,17 @@ makeDotDrawing (name,df) =      drawing `mappend` moveStart (vec 86 14) lbl   where-    drawing     = runPathSpec_ path_spec PATH_OPEN+    drawing     = runPathSpec_ OSTROKE path_spec -    path_spec   = localize path_style $ -                    insertl dot >> -                    mapM (\v -> penline v >> insertl dot) steps >>-                    ureturn+    path_spec   = updatePen path_style >>+                  insertl dot >> +                  mapM (\v -> penline v >> insertl dot) steps >>+                  ureturn                                                                   lbl         = ignoreAns $ promoteLoc $ \pt -> -                    textline name WW `at` pt+                    textline WW name `at` pt      steps       = [V2 25 15, V2 25 (-15), V2 25 15]     dot         = ignoreAns df

@@ -5,7 +5,8 @@ module FeatureModel where  import Wumpus.Drawing.Connectors-import Wumpus.Drawing.Paths.Absolute+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs@@ -74,7 +75,7 @@         => u -> String -> Point2 u -> TraceDrawing u (Box u) makeBox w ss pt = do      a <- drawi $ (strokedShape $ rectangle w 20) `at` pt-    drawl (center a) $ textline ss CENTER+    drawl (center a) $ textline CENTER ss     return a  box :: (Real u, Floating u, InterpretUnit u, Tolerance u) @@ -92,7 +93,7 @@    lw <- getLineWidth    let p0 = south b0    let p1 = projectAnchor north (realToFrac lw) b1-   drawi $ connect p0 p1 (rightArrow arrh connline)+   drawi $ connect (rightArrow arrh connline) p0 p1  infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` @@ -112,3 +113,9 @@ coptional_ :: ( Real u, Floating u, InterpretUnit u )             => Box u -> Box u -> TraceDrawing u () coptional_ p0 p1 = connWith odiskTip p0 p1 >> return ()+++-- Cf. Parsec\'s Token module...++connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u+connline = C.connline default_connector_props

@@ -55,15 +55,18 @@ positions :: [Int] positions = [0, 12, 27, 49, 78, 122]  --- Note - this chain might be worth putting in a library...+-- Note - this chain has grown a bit crufty as the implementation +-- of chains has changed...+-- pointChain :: (Int -> DLocGraphic) -> DLocGraphic-pointChain fn = runChain_ (mapM (cnext . fn) point_sizes) chn_alg+pointChain fn = runChain_ chn_alg $ mapM (chain1 . fn) point_sizes   where     chn_alg = ChainScheme start step     start   = \pt -> (pt,point_sizes) -    step _ (pt,[])     = (pt, (displace (vvec 50) pt, []))-    step _ (pt,(y:ys)) = (pt, (displace (vvec $ fromIntegral $ 2 + y)  pt, ys))+    step _ (pt,[])     = let pnext = displace (vvec 50) pt in (pnext, (pnext, []))+    step _ (pt,(y:ys)) = let pnext = displace (vvec $ fromIntegral $ 2 + y) pt+                         in (pnext, (pnext, ys))  fontGraphic :: RGBi -> FontDef -> DLocGraphic  fontGraphic rgb ft = ignoreAns $ pointChain mkGF@@ -77,9 +80,9 @@  fontDrawing :: [(RGBi,FontDef)] -> CtxPicture fontDrawing xs = drawTracing $  -    draw $ runChain_  (mapM (cnext . uncurry fontGraphic) xs) chn_alg `at` start+    drawl start $ runChain_ chn_alg $ mapM (chain1 . uncurry fontGraphic) xs   where-    chn_alg   = tableDown 4 (1,180)+    chn_alg   = tableColumnwiseScm 4 (2,180)     start     = P2 0 (4*180)  

@@ -80,59 +80,59 @@ -- single line -- ne_oneline :: BoundedLocGraphic Double-ne_oneline = textline "north east" NE+ne_oneline = textline NE "north east"   -- single line -- se_oneline :: BoundedLocGraphic Double-se_oneline = textline "south east" SE+se_oneline = textline SE "south east"  -- single line -- ss_oneline :: BoundedLocGraphic Double-ss_oneline = textline "south" SS+ss_oneline = textline SS "south"  -- single line -- sw_oneline :: BoundedLocGraphic Double-sw_oneline = textline "south west" SW+sw_oneline = textline SW "south west"    -- single line rot -- ssr_single :: BoundedLocGraphic Double-ssr_single = rtextline (0.25*pi) "south rot45"  SS+ssr_single = rtextline (0.25*pi) SS "south rot45"  -- single line rot -- swr_single :: BoundedLocGraphic Double-swr_single = rtextline (0.25*pi)  "south west rot45" SW+swr_single = rtextline (0.25*pi) SW "south west rot45"  -- single line rot -- ner_single :: BoundedLocGraphic Double-ner_single = rtextline (0.25*pi)  "north east rot45" NE+ner_single = rtextline (0.25*pi) NE "north east rot45"   cc_oneline :: BoundedLocGraphic Double-cc_oneline = textline "Center-center..." CENTER+cc_oneline = textline CENTER "Center-center..."   blank_text :: BoundedLocGraphic Double-blank_text = textline "" BLC+blank_text = textline BLC ""   left_text :: BoundedLocGraphic Double-left_text = multilineText VALIGN_LEFT dummy_text CENTER+left_text = multilineText VALIGN_LEFT CENTER dummy_text   right_text :: BoundedLocGraphic Double-right_text = multilineText VALIGN_RIGHT dummy_text CENTER+right_text = multilineText VALIGN_RIGHT CENTER dummy_text  center_text :: BoundedLocGraphic Double-center_text = multilineText VALIGN_CENTER dummy_text CENTER+center_text = multilineText VALIGN_CENTER CENTER dummy_text  dummy_text :: String  dummy_text = unlines $ [ "The quick brown"

@@ -9,6 +9,7 @@  import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs@@ -104,35 +105,56 @@   connectorC :: ConnectorGraphic Double-connectorC = -    ignoreAns $ localize (uniform_arm_len  (30::Double)) -              $ rightArrow tri45 connbbar+connectorC = ignoreAns $ rightArrow tri45 connbbar  connectorC' :: ConnectorGraphic Double-connectorC' = -    ignoreAns $ localize (uniform_arm_len  (30::Double)) -                      $ rightArrow tri45 connabar+connectorC' = ignoreAns $ rightArrow tri45 connabar  connectorD :: ConnectorGraphic Double connectorD = ignoreAns $ rightArrow tri45 connarc  connectorD' :: ConnectorGraphic Double-connectorD' = -    ignoreAns $ localize (conn_arc_angle $ negate $ pi / 12) -                      $ rightArrow tri45 connarc+connectorD' = ignoreAns $ rightArrow tri45 connarc   lblParensParens :: DLocGraphic lblParensParens = -    ignoreAns $ localize (set_font helvetica) $ textline "(),()" CENTER+    ignoreAns $ localize (set_font helvetica) $ textline CENTER "(),()"  lblParensParensParens :: DLocGraphic lblParensParensParens = -    ignoreAns $ localize (set_font helvetica) $ textline "(),(),()" CENTER+    ignoreAns $ localize (set_font helvetica) $ textline CENTER "(),(),()"    lblBold :: String -> DLocGraphic lblBold ss = -    ignoreAns $ localize (set_font helvetica_bold) $ textline ss CENTER+    ignoreAns $ localize (set_font helvetica_bold) $ textline CENTER ss +++-- Cf. Parsec\'s Token module...++conn_props :: ConnectorProps+conn_props = (default_connector_props { conn_src_arm = 2+                                      , conn_dst_arm = 2 +                                      , conn_arc_ang =  negate $ pi / 12 })++connline :: (Real u, Floating u, InterpretUnit u, Tolerance u) +         => ConnectorPathQuery u+connline = C.connline conn_props+++connabar :: (Real u, Floating u, InterpretUnit u, Tolerance u) +         => ConnectorPathQuery u+connabar = C.connabar conn_props+++connbbar :: (Real u, Floating u, InterpretUnit u, Tolerance u) +         => ConnectorPathQuery u+connbbar = C.connbbar conn_props+++connarc :: (Real u, Floating u, InterpretUnit u, Tolerance u) +        => ConnectorPathQuery u+connarc = C.connarc conn_props

@@ -156,7 +156,7 @@   where     shape   = strokedShape $ setDecoration textF sh     textF   = promoteLocTheta $ \pt _ -> -                ignoreAns (multilineText VALIGN_CENTER name CENTER) `at` pt+                ignoreAns (multilineText VALIGN_CENTER CENTER name) `at` pt      deg10   = d2r (10::Double)     deg110  = d2r (110::Double)@@ -177,7 +177,7 @@   where     (rpos,fn)     = go cpos     msg           = ignoreAns $ moveStart (fn 10) $ -                       multilineText VALIGN_CENTER ss rpos+                       multilineText VALIGN_CENTER rpos ss       go NORTH      = (SS, go_north)     go NORTH_EAST = (SW, go_north_east)

@@ -61,7 +61,7 @@     draw $ redPlus `at` P2 200 0    where-    fn addr obj = illustrateBoundedLocGraphic $ runPosObjectBBox obj addr+    fn addr obj = illustrateBoundedLocGraphic $ runPosObjectBBox addr obj   redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u

@@ -53,9 +53,9 @@       testDraw :: RectAddress -> LocGraphic Double-testDraw rpos = dcDisk FILL 2 `mappend` (ignoreAns ans)+testDraw rpos = dcDisk DRAW_FILL 2 `mappend` (ignoreAns ans)   where-    ans = textline "Qwerty" rpos+    ans = textline rpos "Qwerty"   

@@ -2,220 +2,76 @@  module Symbols where +import Wumpus.Drawing.Basis.DrawingPrimitives+import Wumpus.Drawing.Basis.Symbols+import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs  import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Basic.System.FontLoader -import Prelude hiding ( pi, product )+import Wumpus.Core                              -- package: wumpus-core  import System.Directory + main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx symbols+main = simpleFontLoader main1 >> return ()++main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Left times_roman ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) symb_pic     writeEPS "./out/symbols.eps" pic1-    writeSVG "./out/symbols.svg" pic1+    writeSVG "./out/symbols.svg" pic1 +           +makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font times_roman . metricsContext 14 -std_ctx :: DrawingContext-std_ctx = set_font times_roman $ standardContext 12+symb_pic :: CtxPicture +symb_pic = drawTracing $ tableGraphic symbtable  --- Because the font changes, we draw the all the symbols in one--- run and all the labels in a second run. This helps Wumpus-Core --- generate better PostScript as there are less changes to the --- /graphics state/.----symbols :: CtxPicture-symbols = udrawTracing (0::Double) $ do-    localize (set_font symbol) $ fontDelta $ draw $-               runChain_ (mapM sdraw all_letters) chn_alg  `at` start-    fontDelta $ draw $ runChain (mapM ldraw all_letters) chn_alg  `at` start-  where-    chn_alg         = tableDown 30 (100,20) -    start           = P2 0 (30*20)-    sdraw (s,_)     = cnext $ dcTextlabel s-    ldraw (_,name)  = cnext $ moveStart (hvec 16) (dcTextlabel name)+symbtable :: [(String, LocGraphic Double)]+symbtable = +    [ ("ocircle",               ocircle 8) +    , ("ochar",                 ochar $ CharLiteral 'a')+    , ("ochar - bad",           ochar $ CharLiteral 'g')+    , ("ocharDescender",        ocharDescender $ CharLiteral 'g')+    , ("ocharUpright",          ocharUpright $ CharLiteral '8')+    , ("ocharUpright - bad",    ocharUpright $ CharLiteral 'a')+    , ("ocurrency",             ocurrency 8)+    , ("left_slice",            left_slice 14)+    , ("right_slice",           right_slice 14)+    , ("left_triangle",         left_triangle 14)+    , ("right_triangle",        right_triangle 14)+    , ("hbar",                  hbar 14)+    , ("vbar",                  vbar 14)+    , ("dbl_hbar",              dbl_hbar 14)+    , ("dbl_vbar",              dbl_vbar 14)+    ]  -all_letters :: [(String, String)]-all_letters = -    [ ("&Alpha;",               "Alpha") -    , ("&Beta;",                "Beta")-    , ("&Chi;",                 "Chi")-    , ("&Delta;",               "Delta")-    , ("&Epsilon;",             "Epsilon")-    , ("&Eta;",                 "Eta")-    , ("&Euro;",                "Euro")-    , ("&Gamma;",               "Gamma")-    , ("&Ifraktur;",            "Ifraktur")-    , ("&Iota;",                "Iota")-    , ("&Kappa;",               "Kappa")-    , ("&Lambda;",              "Lambda")-    , ("&Mu;",                  "Mu")-    , ("&Nu;",                  "Nu")-    , ("&Omega;",               "Omega")-    , ("&Omicron;",             "Omicron")-    , ("&Phi;",                 "Phi")-    , ("&Pi;",                  "Pi")-    , ("&Psi;",                 "Psi")-    , ("&Rfraktur;",            "Rfraktur")-    , ("&Rho;",                 "Rho")-    , ("&Sigma;",               "Sigma")-    , ("&Tau;",                 "Tau")-    , ("&Theta;",               "Theta")-    , ("&Upsilon;",             "Upsilon")-    , ("&Upsilon1;",            "Upsilon1")-    , ("&Xi;",                  "Xi")-    , ("&Zeta;",                "Zeta")-    , ("&aleph;",               "aleph")-    , ("&alpha;",               "alpha")-    , ("&ampersand;",           "ampersand")-    , ("&angle;",               "angle")-    , ("&angleleft;",           "angleleft")-    , ("&angleright;",          "angleright")-    , ("&approxequal;",         "approxequal")+tableGraphic :: [(String, LocGraphic Double)] -> TraceDrawing Double ()+tableGraphic symbs = +    drawl start $ ignoreAns $ runTableColumnwise 8 (180,24)+                $ mapM (chain1 .  makeSymbDrawing) symbs+  where+    start = P2 0 520  -    -- -    , ("&arrowboth;",           "arrowboth") -    , ("&arrowdblboth;",        "arrowdblboth")-    , ("&arrowdbldown;",        "arrowdbldown")-    , ("&arrowdblleft;",        "arrowdblleft")-    , ("&arrowdblright;",       "arrowdblright")-    , ("&arrowdblup;",          "arrowdblup")-    , ("&arrowdown;",           "arrowdown")-    , ("&arrowleft;",           "arrowleft")-    , ("&arrowright;",          "arrowright")-    , ("&arrowup;",             "arrowup")-    , ("&asteriskmath;",        "asteriskmath")-    , ("&bar;",                 "bar")-    , ("&beta;",                "beta")-    , ("&braceleft;",           "braceleft")-    , ("&braceright;",          "braceright")-    , ("&bracketleft;",         "bracketleft")-    , ("&bracketright;",        "bracketright")-    , ("&bullet;",              "bullet")-    , ("&carriagereturn;",      "carriagereturn")-    , ("&chi;",                 "chi")+ +std_ctx :: DrawingContext+std_ctx = fill_colour peru $ standardContext 18 -    ---    , ("&circlemultiply;",      "circlemultiply") -    , ("&circleplus;",          "circleplus")-    , ("&club;",                "club")-    , ("&colon;",               "colon")-    , ("&comma;",               "comma")-    , ("&congruent;",           "congruent")-    , ("&copyrightsans;",       "copyrightsans")-    , ("&copyrightserif;",      "copyrightserif")-    , ("&degree;",              "degree")-    , ("&delta;",               "delta")-    , ("&diamond;",             "diamond")-    , ("&divide;",              "divide")-    , ("&dotmath;",             "dotmath")-    , ("&eight;",               "eight")-    , ("&element;",             "element")-    , ("&ellipsis;",            "ellipsis")-    , ("&emptyset;",            "emptyset")-    , ("&epsilon;",             "epsilon")-    , ("&equal;",               "equal")-    , ("&equivalence;",         "equivalence")-    , ("&eta;",                 "eta")-    , ("&exclam;",              "exclam")-    , ("&existential;",         "existential")-    , ("&five;",                "five")-    , ("&florin;",              "florin")-    , ("&four;",                "four")-    , ("&fraction;",            "fraction")-    , ("&gamma;",               "gamma")-    , ("&gradient;",            "gradient")-    , ("&greater;",             "greater")-    , ("&greaterequal;",        "greaterequal")-    , ("&heart;",               "heart")-    , ("&infinity;",            "infinity")-    , ("&integral;",            "integral") -    -- -    , ("&intersection;",        "intersection")-    , ("&iota;",                "iota")-    , ("&kappa;",               "kappa")-    , ("&lambda;",              "lambda")-    , ("&less;",                "less")-    , ("&lessequal;",           "lessequal")-    , ("&logicaland;",          "logicaland")-    , ("&logicalnot;",          "logicalnot")-    , ("&logicalor;",           "logicalor")-    , ("&lozenge;",             "lozenge")-    , ("&minus;",               "minus")-    , ("&minute;",              "minute")-    , ("&mu;",                  "mu")-    , ("&multiply;",            "multiply")-    , ("&nine;",                "nine")-    , ("&notelement;",          "notelement")-    , ("&notequal;",            "notequal")-    , ("&notsubset;",           "notsubset")-    , ("&nu;",                  "nu")-    , ("&numbersign;",          "numbersign")-    , ("&omega;",               "omega")-    , ("&omega1;",              "omega1")-    , ("&omicron;",             "omicron")-    , ("&one;",                 "one")-    , ("&parenleft;",           "parenleft")-    , ("&parenright;",          "parenright") -    ---    , ("&partialdiff;",         "partialdiff")-    , ("&percent;",             "percent")-    , ("&period;",              "period")-    , ("&perpendicular;",       "perpendicular")-    , ("&phi;",                 "phi")-    , ("&phi1;",                "phi1")-    , ("&pi;",                  "pi")-    , ("&plus;",                "plus")-    , ("&plusminus;",           "plusminus")-    , ("&product;",             "product")-    , ("&propersubset;",        "propersubset")-    , ("&propersuperset;",      "propersuperset")-    , ("&proportional;",        "proportional")-    , ("&psi;",                 "psi")-    , ("&question;",            "question")-    , ("&radical;",             "radical")-    , ("&radicalex;",           "radicalex")-    , ("&reflexsubset;",        "reflexsubset")-    , ("&reflexsuperset;",      "reflexsuperset")-    , ("&registersans;",        "registersans")-    , ("&registerserif;",       "registerserif")-    , ("&rho;",                 "rho")-    -    -- -    , ("&second;",              "second")-    , ("&semicolon;",           "semicolon")-    , ("&seven;",               "seven")-    , ("&sigma;",               "sigma")-    , ("&sigma1;",              "sigma1")-    , ("&similar;",             "similar")-    , ("&six;",                 "six")-    , ("&slash;",               "slash")-    , ("&space;",               "space")-    , ("&spade;",               "spade")-    , ("&suchthat;",            "suchthat")-    , ("&summation;",           "summation")-    , ("&tau;",                 "tau")-    , ("&therefore;",           "therefore")-    , ("&theta;",               "theta")-    , ("&theta1;",              "theta1")-    , ("&three;",               "three")-    , ("&trademarksans;",       "trademarksans")-    , ("&trademarkserif;",      "trademarkserif")-    , ("&two;",                 "two")-    , ("&underscore;",          "underscore")-    , ("&union;",               "union")-    , ("&universal;",           "universal")-    , ("&upsilon;",             "upsilon")-    , ("&weierstrass;",         "weierstrass")-    , ("&xi;",                  "xi")-    , ("&zero;",                "zero")-    , ("&zeta;",                "zeta")-    ]+makeSymbDrawing :: (String, LocGraphic Double) -> DLocGraphic +makeSymbDrawing (ss,symb) = symb <> moveStart (hvec 20) lbl+  where+    lbl = ignoreAns $ textline WW ss+ 

@@ -18,6 +18,9 @@ -- -- This module is expected to be imported qualified - other modules -- (e.g. shapes and paths) are likely to export conflicting names.+-- +-- \*\* WARNING \*\* - much of this module is probably obsolete +-- (except wedge). -- -------------------------------------------------------------------------------- @@ -29,8 +32,8 @@    -- * Lines -  , hline-  , vline+  , horizontalLine+  , verticalLine   , pivotLine    , oStraightLines@@ -75,15 +78,16 @@ -------------------------------------------------------------------------------- -- Lines + -- | Draw a vertical line. -- -vline :: InterpretUnit u => u -> LocGraphic u -vline len = locStraightLine $ vvec len+verticalLine :: InterpretUnit u => u -> LocGraphic u +verticalLine len = locStraightLine $ vvec len  -- | Draw a horizontal line. -- -hline :: InterpretUnit u => u -> LocGraphic u -hline len = locStraightLine $ hvec len+horizontalLine :: InterpretUnit u => u -> LocGraphic u +horizontalLine len = locStraightLine $ hvec len   @@ -105,8 +109,8 @@  -- | Draw an closed path formed from straight line segments. ---cStraightLines :: InterpretUnit u => DrawStyle -> [Point2 u] -> Graphic u-cStraightLines sty ps = liftQuery (vertexPP ps) >>= dcClosedPath sty+cStraightLines :: InterpretUnit u => DrawMode -> [Point2 u] -> Graphic u+cStraightLines mode ps = liftQuery (vertexPP ps) >>= dcClosedPath mode   --------------------------------------------------------------------------------@@ -116,16 +120,16 @@  -- | Draw a rectangle, start point is bottom left. ---blRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u+blRectangle :: InterpretUnit u => DrawMode -> 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+             => DrawMode -> u -> u -> LocGraphic u+ctrRectangle mode w h = +    moveStart (vec (-hw) (-hh)) $ dcRectangle mode w h   where     hw = 0.5 * w     hh = 0.5 * h@@ -144,24 +148,18 @@     let ps = bezierArcPoints ang radius inclin pt     in liftQuery (curvePP ps) >>= dcOpenPath --- | wedge : radius * apex_angle+-- | wedge : mode * 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 _            = []-    +-- Wedge is drawn at the apex.+--+wedge :: (Real u, Floating u, InterpretUnit u) +       => DrawMode -> u -> Radian -> LocThetaGraphic u+wedge mode radius ang = promoteLocTheta $ \pt inclin -> +    let half_ang = 0.5 * ang +        line_in  = catline $ avec (inclin + half_ang)   radius+        line_out = catline $ avec (inclin - half_ang) (-radius)+        w_arc    = circularArcCW ang radius (inclin - half_pi)+        ct       = line_in `mappend` w_arc `mappend` line_out+    in supplyLoc pt $ drawCatTrail (closedMode mode) ct+        +

@@ -0,0 +1,165 @@+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.Symbols+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Symbols - many symbols expected to be re-defined as Dots or+-- character size PosObjects for DocText.+--+-- \*\* WARNING \*\* - naming conventention is to be determined...+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.Symbols+  (++    ocircle+  , ochar+  , ocharUpright+  , ocharDescender+  , ocurrency+  , left_slice+  , right_slice++  , left_triangle+  , right_triangle++  , empty_box++  , hbar+  , vbar+  , dbl_hbar+  , dbl_vbar++  )+  where++import Wumpus.Drawing.Basis.DrawingPrimitives++import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++-- import Data.AffineSpace                         -- package: vector-space++--+-- DESIGN NOTE +--+-- Should names follow the /function scheme/ (camelCase), or the+-- /data scheme/ (underscore_separators).+--+-- Objects here are functions as they take size param, but they+-- expected to be redefined elsewhere at fixed size and not used +-- in /user code/. +-- +-- Using camelCase here, then under_score in the DocText versions+-- adds double the function signatures to the Haddock docs.+--++++ocircle :: InterpretUnit u => u -> LocGraphic u+ocircle radius = dcDisk DRAW_STROKE radius++-- | Note this looks horrible for chars with descenders.+--+ochar :: (Fractional u, InterpretUnit u) +             => EscapedChar -> LocGraphic u+ochar esc = char1 <> circ1+  where+    char1 = runPosObject CENTER $ posEscChar esc+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> ocircle (0.85 * h)++ocharUpright :: (Fractional u, InterpretUnit u) +             => EscapedChar -> LocGraphic u+ocharUpright esc = char1 <> circ1+  where+    char1 = runPosObject CENTER $ posEscCharUpright esc+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> ocircle (0.85 * h)++ocharDescender :: (Fractional u, InterpretUnit u) +             => EscapedChar -> LocGraphic u+ocharDescender esc = char1 <> circ1+  where+    char1 = fmap abs descender >>= \dy -> +            moveStart (go_up dy) $ runPosObject CENTER $ posEscCharUpright esc+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> ocircle (0.85 * h)+++ocurrency :: (Floating u, InterpretUnit u) +          => u -> LocGraphic u +ocurrency ra = ocircle ra <> lne <> lnw <> lsw <> lse+  where+    ra3 = 0.33 * ra+    lne = moveStart (go_north_east ra) $ locStraightLine $ go_north_east ra3+    lnw = moveStart (go_north_west ra) $ locStraightLine $ go_north_west ra3+    lsw = moveStart (go_south_west ra) $ locStraightLine $ go_south_west ra3+    lse = moveStart (go_south_east ra) $ locStraightLine $ go_south_east ra3++left_slice :: (Real u, Floating u, InterpretUnit u) +          => u -> LocGraphic u+left_slice radius = moveStart (go_left $ 0.5 * radius) lwedge+  where+    lwedge = supplyIncline 0 $ wedge DRAW_STROKE radius quarter_pi+++right_slice :: (Real u, Floating u, InterpretUnit u) +          => u -> LocGraphic u+right_slice radius = moveStart (go_right $ 0.5 * radius) rwedge+  where+    rwedge = supplyIncline pi $ wedge DRAW_STROKE radius quarter_pi++left_triangle :: (Fractional u, InterpretUnit u) +              => u -> LocGraphic u+left_triangle w = +    drawPlacedTrail CSTROKE $ placeCatTrail (go_left $ 0.5 * w)+                            $ line_r <> vbase <> line_l+  where+    hh     = 0.40 * w+    line_r = catline $ vec w hh+    vbase  = catline $ go_down $ 2*hh+    line_l = catline $ vec (-w) hh++right_triangle :: (Fractional u, InterpretUnit u) +               => u -> LocGraphic u+right_triangle w = +    drawPlacedTrail CSTROKE $ placeCatTrail (go_right $ 0.5 * w)+                            $ line_l <> vbase <> line_r+  where+    hh     = 0.40 * w+    line_l = catline $ vec (-w) hh+    vbase  = catline $ go_down $ 2*hh+    line_r = catline $ vec w hh+++empty_box :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+empty_box w = drawPlacedTrail CSTROKE $ rectangleTrail w w++hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+hbar u = +    drawPlacedTrail OSTROKE $ placeCatTrail (go_left $ 0.5 * u) $ trail_right u++vbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+vbar u = +    drawPlacedTrail OSTROKE $ placeCatTrail (go_down $ 0.5 * u) $ trail_up u++dbl_hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+dbl_hbar u = line1 <> line2+  where+    line1 = moveStart (go_up $ 0.1 * u) $ hbar u+    line2 = moveStart (go_down $ 0.1 * u) $ hbar u+++dbl_vbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+dbl_vbar u = line1 <> line2+  where+    line1 = moveStart (go_left $ 0.1 * u) $ vbar u+    line2 = moveStart (go_right $ 0.1 * u) $ vbar u

@@ -11,6 +11,8 @@ -- Portability :  GHC -- -- Shim module for Connectors.+-- +-- \*\* WARNING \*\* - this is due to change... -- -------------------------------------------------------------------------------- @@ -19,11 +21,11 @@     module Wumpus.Drawing.Connectors.Arrowheads   , module Wumpus.Drawing.Connectors.Base   , module Wumpus.Drawing.Connectors.BoxConnectors-  , module Wumpus.Drawing.Connectors.ConnectorPaths+  , module Wumpus.Drawing.Connectors.ConnectorProps    ) where  import Wumpus.Drawing.Connectors.Arrowheads import Wumpus.Drawing.Connectors.Base import Wumpus.Drawing.Connectors.BoxConnectors-import Wumpus.Drawing.Connectors.ConnectorPaths+import Wumpus.Drawing.Connectors.ConnectorProps

@@ -61,7 +61,6 @@  import Wumpus.Drawing.Basis.DrawingPrimitives import Wumpus.Drawing.Connectors.Base-import Wumpus.Drawing.Paths.Absolute  import Wumpus.Basic.Kernel                      -- package: wumpus-basic @@ -86,13 +85,13 @@ filledTipPath :: PointGen -> LocThetaGraphic En filledTipPath gen =      localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta ->-      cStraightLines FILL $ map (pt .+^) $ gen theta+      cStraightLines DRAW_FILL $ map (pt .+^) $ gen theta   closedTipPath :: PointGen -> LocThetaGraphic En closedTipPath gen =      localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->-      cStraightLines STROKE $ map (pt .+^) $ gen theta+      cStraightLines DRAW_STROKE $ map (pt .+^) $ gen theta   openTipPath :: PointGen -> LocThetaGraphic En@@ -145,18 +144,8 @@   -ang90 :: Radian-ang90 = pi / 2 -ang60 :: Radian-ang60 = pi / 3 -ang45 :: Radian-ang45 = pi / 4---- filledTri :: Radian -> ArrowTip filledTri ang =      ArrowTip@@ -333,7 +322,7 @@     body :: Radian -> LocGraphic En     body theta = let v1 = avec theta (-0.5)                  in localize fill_use_stroke_colour $ -                      moveStart v1 (dcDisk FILL 0.5)+                      moveStart v1 (dcDisk DRAW_FILL 0.5)   odiskTip :: ArrowTip@@ -347,7 +336,7 @@     body :: Radian -> LocGraphic En     body theta = let v1 = avec theta (-0.5)                  in localize solid_stroke_tip $ -                      moveStart v1 (dcDisk STROKE 0.5)+                      moveStart v1 (dcDisk DRAW_STROKE 0.5)   -- | squareSpec:@@ -437,18 +426,31 @@       }  -curveTipPath :: Point2 En -> Radian -> AbsPath En-curveTipPath pt theta = -    curve1 a b c pt `append` curve1 pt z y x+curveTipTrail :: Radian -> PlacedTrail En+curveTipTrail theta = +    placeCatTrail dv $ vectrapCCW v1 <> vectrapCCW v2   where-    ow  = avec theta (-1)-    a   = pt .+^ ow ^+^ avec (theta + ang90) 0.5-    x   = pt .+^ ow ^+^ avec (theta - ang90) 0.5+    dv  = orthoVec (-1.0)   0.75  theta     -- back and up+    v1  = orthoVec   1.0  (-0.75) theta     -- fwd and down+    v2  = orthoVec (-1.0) (-0.75) theta     -- back and down -    (c,b) = trapezoidFromBasePoints 0.125 0.5 pt a-    (y,z) = trapezoidFromBasePoints 0.125 0.5 x pt +vectrapCW :: (Real u, Floating u) => Vec2 u -> CatTrail u+vectrapCW v1 = trapcurveCW w h ang45 ang+  where+    w   = vlength v1+    h   = w / 4+    ang = vdirection v1 ++vectrapCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u+vectrapCCW v1 = trapcurveCCW w h quarter_pi ang+  where+    w   = vlength v1+    h   = w / 4+    ang = vdirection v1++ curveTip :: ArrowTip curveTip =      ArrowTip@@ -459,20 +461,18 @@   where     body = promoteLocTheta $ \pt theta ->               localize (join_bevel . solid_stroke_tip) $ -               liftQuery (toPrimPath $ curveTipPath pt theta) >>= dcOpenPath+               supplyLoc pt $ drawPlacedTrail OSTROKE $ curveTipTrail theta   -curveTipRevPath :: Point2 En -> Radian -> AbsPath En-curveTipRevPath pt theta = -    curve1 a b c p2 `append` curve1 p2 z y x+curveTipRevTrail :: Radian -> PlacedTrail En+curveTipRevTrail theta = +    placeCatTrail dv $ vectrapCW v1 <> vectrapCW v2   where-    p2  = pt .+^ avec theta (-1)-    a   = pt .+^ avec (theta + ang90) 0.5-    x   = pt .+^ avec (theta - ang90) 0.5+    dv  = orthoVec   0.0    0.75  theta     -- just up+    v1  = orthoVec (-1.0) (-0.75) theta     -- back and down+    v2  = orthoVec   1.0  (-0.75) theta     -- fwd and down -    (b,c) = trapezoidFromBasePoints 0.125 0.5 a p2-    (z,y) = trapezoidFromBasePoints 0.125 0.5 p2 x   revcurveTip :: ArrowTip@@ -485,29 +485,6 @@   where     body = promoteLocTheta $ \pt theta ->               localize (join_bevel . solid_stroke_tip) $ -               liftQuery (toPrimPath $ curveTipRevPath pt theta) >>= dcOpenPath+               supplyLoc pt $ drawPlacedTrail OSTROKE $ curveTipRevTrail theta  -    --- | 'trapezoidFromBasePoints' : --- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @------ Control points form an isosceles trapezoid.------ The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@.--- -trapezoidFromBasePoints :: (Real u, Floating u) -                        => u -> u -> Point2 u -> Point2 u -                        -> (Point2 u, Point2 u) -trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2)-  where-    base_vec  = pvec p1 p2-    base_len  = vlength base_vec-    theta     = vdirection base_vec-    half_ulen = 0.5 * ratio_to_base * base_len-    base_mid  = 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

@@ -17,8 +17,9 @@ module Wumpus.Drawing.Connectors.Base   (  -    Connector     +    ConnectorPathQuery+   , ArrowTip(..)   , ArrowConnector @@ -29,25 +30,23 @@    , rightArrowPath -  -  , buildConn-   ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths  import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space- import Data.Monoid +++ -- | The type of Connectors - a query from start and end point to  -- a Path. ---type Connector u = ConnectorQuery u (AbsPath u)+type ConnectorPathQuery u = ConnectorQuery u (AbsPath u)  -- | Arrowhead /algorithm/ - the components of an arrowhead. -- @@ -67,7 +66,8 @@   -runArrowTip :: InterpretUnit u => ArrowTip -> Query u (u, u, LocThetaGraphic u)+runArrowTip :: InterpretUnit u +            => ArrowTip -> Query u (u, u, LocThetaGraphic u) runArrowTip (ArrowTip df len deco) =     getLineWidth             >>= \lw    ->     uconvertCtx1 (df lw)     >>= \uretd ->@@ -78,7 +78,7 @@ -- | Connector with an arrow tip at the end point (i.e right). -- rightArrow :: (Real u, Floating u, InterpretUnit u) -            => ArrowTip -> Connector u -> ArrowConnector u+           => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u rightArrow alg conn = promoteConn $ \p0 p1 ->     applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path ->      rightArrowPath alg full_path @@ -88,7 +88,7 @@ -- | Connector with an arrow tip at the start point (i.e left). -- leftArrow :: (Real u, Floating u, InterpretUnit u) -            => ArrowTip -> Connector u -> ArrowConnector u+            => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u leftArrow alg conn = promoteConn $ \p0 p1 ->     applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path ->      leftArrowPath alg full_path @@ -98,7 +98,7 @@ -- end points. -- leftRightArrow :: (Real u, Floating u, InterpretUnit u) -               => ArrowTip -> ArrowTip ->  Connector u -> ArrowConnector u+               => ArrowTip -> ArrowTip -> ConnectorPathQuery u -> ArrowConnector u leftRightArrow algl algr conn = promoteConn $ \p0 p1 ->     applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path ->      leftRightArrowPath algl algr full_path @@ -109,7 +109,7 @@ -- end points. -- uniformArrow :: (Real u, Floating u, InterpretUnit u) -               => ArrowTip ->  Connector u -> ArrowConnector u+               => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u uniformArrow alg conn = promoteConn $ \p0 p1 ->     applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path ->      leftRightArrowPath alg alg full_path @@ -134,7 +134,7 @@         mid_ang         = tipDirectionL len full_path         tip             = applyLocTheta deco (tipL full_path) mid_ang     in replaceAns full_path $ -         sdecorate tip $ drawOpenPath short_path+         sdecorate tip $ drawPath OSTROKE short_path   @@ -152,7 +152,7 @@         mid_ang         = tipDirectionR len full_path         tip             = applyLocTheta deco (tipR full_path) mid_ang     in replaceAns full_path $ -         sdecorate tip $ drawOpenPath short_path+         sdecorate tip $ drawPath OSTROKE short_path   @@ -173,7 +173,7 @@         tipl            = applyLocTheta decol (tipL full_path) mid_angl         tipr            = applyLocTheta decor (tipR full_path) mid_angr     in replaceAns full_path $ -         sdecorate (tipl `mappend` tipr) $ drawOpenPath short_path+         sdecorate (tipl `mappend` tipr) $ drawPath OSTROKE short_path             @@ -191,28 +191,3 @@      ---- | 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 @promoteConn@ for functions --- building connectors.----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 (dispPerpendicular off0 ang $ p0 .+^ avec ang sep0) -          (dispPerpendicular off1 ang $ p1 .-^ avec ang sep1)-   ------ CAUTION - buildConn projects the spacers along the (straight)--- connector line. This might not be what is wanted for jointed--- connectors.--- 

@@ -18,16 +18,20 @@   (      ConnectorBox   , connbox+  , conntube    ) where --- import Wumpus.Drawing.Paths.Absolute+-- import Wumpus.Drawing.Connectors.Base+import Wumpus.Drawing.Connectors.ConnectorProps  import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core  +import Data.Monoid+ -- NOTE - boxes (currently) seem to only support stroke otherwise -- they would obliterate what they connect. @@ -53,13 +57,55 @@ -- The rectangle will be inclined to the line. -- connbox :: (Real u, Floating u, InterpretUnit u) -        => ConnectorBox u-connbox = promoteConn $ \p0 p1 -> -    connectorSrcArm >>= \src_arm ->-    connectorDstArm >>= \dst_arm ->-    let ang = vdirection $ pvec p0 p1 -        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 liftQuery (vertexPP [ bl, br, tr, tl ]) >>= dcClosedPath STROKE+        => ConnectorProps -> ConnectorBox u+connbox props = promoteConn $ \p0 p1 -> +    connectorBoxHalfSize props >>= \sz ->+    applyLoc (drawPlacedTrail CSTROKE $ cfconnbox sz (pvec p0 p1)) p0+++conntube :: (Real u, Floating u, InterpretUnit u) +        => ConnectorProps -> ConnectorBox u+conntube props = promoteConn $ \p0 p1 -> +    connectorBoxHalfSize props >>= \sz ->+    applyLoc (drawPlacedTrail CSTROKE $ cfconntube sz (pvec p0 p1)) p0++++-- Box connectors aren\'t especially coordinate free.++-- | @v1@ is the /interior/ vector.+--+cfconnbox :: (Real u, Floating u) => u -> Vec2 u -> PlacedTrail u+cfconnbox du v1 = +    placeCatTrail (orthoVec (-du) (-du) ang) $ mconcat $+      [ trail_theta_right w ang+      , trail_theta_up h ang+      , trail_theta_left w ang+      , trail_theta_down h ang+      ]+  where+    ang = vdirection v1 +    w   = (2*du) + vlength v1+    h   = 2*du+    +++-- | @v1@ is the /interior/ vector.+--+cfconntube :: (Real u, Floating u) => u -> Vec2 u -> PlacedTrail u+cfconntube du v1 = +    placeCatTrail (orthoVec 0 (-du) ang) $ mconcat $+      [ trail_theta_right w ang+      , semicircleCCW vup+      , trail_theta_left w ang+      , semicircleCCW vdown+      ]+  where+    ang   = vdirection v1 +    w     = vlength v1+    vup   = avec (ang + half_pi) (2*du)+    vdown = avec (ang - half_pi) (2*du)++    ++

@@ -48,7 +48,8 @@   ) where  import Wumpus.Drawing.Connectors.Base-import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Connectors.ConnectorProps+import Wumpus.Drawing.Paths  import Wumpus.Basic.Geometry.Quadrant           -- package: wumpus-basic import Wumpus.Basic.Kernel hiding ( promoteConn )@@ -59,16 +60,155 @@   +type ProjectionQuery u = +      ConnectorProps -> Point2 u -> Point2 u -> Query u (Point2 u) +inlineSrc :: (Real u, Floating u, InterpretUnit u) +          => ProjectionQuery u+inlineSrc props p0 p1 = +    connectorSrcSpace props >>= \sep -> +    let ang = vdirection $ pvec p0 p1+    in return $ p0 .+^ avec ang sep +inlineDst :: (Real u, Floating u, InterpretUnit u) +          => ProjectionQuery u+inlineDst props p0 p1 = +    connectorDstSpace props >>= \sep -> +    let ang = vdirection $ pvec p0 p1+    in return $ p1 .-^ avec ang sep +-- | Like 'inlineSrc' but /expands/ rather than /contracts/.+-- +-- Use for loops.+--+extlineSrc :: (Real u, Floating u, InterpretUnit u) +          => ProjectionQuery u+extlineSrc props p0 p1 = +    connectorSrcSpace props >>= \sep -> +    let ang = vdirection $ pvec p0 p1+    in return $ p0 .-^ avec ang sep+++-- | Like 'inlineDst' but /expands/ rather than /contracts/.+-- +-- Use for loops.+--+extlineDst :: (Real u, Floating u, InterpretUnit u) +          => ProjectionQuery u+extlineDst props p0 p1 = +    connectorDstSpace props >>= \sep -> +    let ang = vdirection $ pvec p0 p1+    in return $ p1 .+^ avec ang sep++-- | Horizontal \"orthonormal\" version of 'inlineSrc'.+--+horizontalSrc :: (Real u, Floating u, InterpretUnit u) +              => ProjectionQuery u+horizontalSrc props p0 p1 = +    connectorSrcSpace props >>= \sep ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> return $ p0 .+^ go_right sep+      QUAD_SE -> return $ p0 .+^ go_right sep+      _       -> return $ p0 .+^ go_left sep        ++++-- | Horizontal \"orthonormal\" version of 'inlineDst'.+--+horizontalDst :: (Real u, Floating u, InterpretUnit u) +              => ProjectionQuery u+horizontalDst props p0 p1 = +    connectorDstSpace props >>= \sep ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> return $ p1 .+^ go_left sep+      QUAD_SE -> return $ p1 .+^ go_left sep  +      _       -> return $ p1 .+^ go_right sep++++-- | Vertical \"orthonormal\" version of 'inlineSrc'.+--+verticalSrc :: (Real u, Floating u, InterpretUnit u) +            => ProjectionQuery u+verticalSrc props p0 p1 =+    connectorSrcSpace props >>= \sep ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> return $ p0 .+^ go_up sep       +      QUAD_NW -> return $ p0 .+^ go_up sep+      _       -> return $ p0 .+^ go_down sep+++-- | Vertical \"orthonormal\" version of 'inlineDst'.+--+verticalDst :: (Real u, Floating u, InterpretUnit u) +            => ProjectionQuery u+verticalDst props p0 p1 =+    connectorDstSpace props >>= \sep ->+    case quadrant $ vdirection $ pvec p0 p1 of+      QUAD_NE -> return $ p1 .+^ go_down sep       +      QUAD_NW -> return $ p1 .+^ go_down sep+      _       -> return $ p1 .+^ go_up sep+++abovePerpSrc :: (Real u, Floating u, InterpretUnit u) +         => ProjectionQuery u+abovePerpSrc props p0 p1 = +    connectorSrcSpace props >>= \sep -> +    let ang = vdirection $ pvec p0 p1+    in return $ p0 .+^ avec (ang + half_pi) sep++abovePerpDst :: (Real u, Floating u, InterpretUnit u) +         => ProjectionQuery u+abovePerpDst props p0 p1 =+    connectorDstSpace props >>= \sep -> +    let ang = vdirection $ pvec p0 p1+    in return $ p1 .+^ avec (ang + half_pi) sep+++belowPerpSrc :: (Real u, Floating u, InterpretUnit u) +         => ProjectionQuery u+belowPerpSrc props p0 p1 =+    connectorSrcSpace props >>= \sep -> +    let ang = vdirection $ pvec p0 p1+    in return $ p0 .+^ avec (ang - half_pi) sep++belowPerpDst :: (Real u, Floating u, InterpretUnit u) +         => ProjectionQuery u+belowPerpDst props p0 p1 =+    connectorDstSpace props >>= \sep -> +    let ang = vdirection $ pvec p0 p1+    in return $ p1 .+^ avec (ang - half_pi) sep++++-- | Promote a function from source and dest points to a connector +-- function accounting for the separator values in the +-- DrawingContext.+--+buildConn :: (Real u, Floating u, InterpretUnit u) +          => ConnectorProps +          -> ProjectionQuery u -> ProjectionQuery u+          -> (Point2 u -> Point2 u -> Query u (AbsPath u))+          -> ConnectorPathQuery u+buildConn props qsrc qdst fn = qpromoteConn $ \p0 p1 -> +    qsrc props p0 p1 >>= \q0 -> qdst props p0 p1 >>= \q1 -> fn q0 q1+++++++ -- | Straight line connector. ---connline :: (Real u, Floating u, InterpretUnit u) => Connector u-connline = qpromoteConn $ \p0 p1 -> return $ line1 p0 p1+connline :: (Real u, Floating u, InterpretUnit u) +         => ConnectorProps -> ConnectorPathQuery u+connline props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +    return $ line1 p0 p1   + -- | Form an arc connector. --  -- If the conn_arc_angle in the Drawing context is positive the arc@@ -80,10 +220,10 @@ --  -- connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) -        => Connector u-connarc = qpromoteConn $ \p0 p1 -> -    connectorArcAngle >>= \arc_ang ->-    let v1      = pvec p0 p1+        => ConnectorProps -> ConnectorPathQuery u+connarc props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +    let arc_ang = conn_arc_ang props +        v1      = pvec p0 p1         hlen    = 0.5 * vlength v1         ang     = vdirection v1         cp0     = p0 .+^ avec (ang + arc_ang) hlen@@ -103,10 +243,9 @@ -- diagonal segment joins the arms.  --  connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => Connector u-connhdiagh = qpromoteConn $ \p0 p1 -> -    connectorSrcArm >>= \src_arm ->-    connectorDstArm >>= \dst_arm ->+           => ConnectorProps -> ConnectorPathQuery u+connhdiagh props = buildConn props horizontalSrc horizontalDst $ \p0 p1 -> +    connectorArms props >>= \(src_arm, dst_arm) ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> right p0 p1 src_arm dst_arm       QUAD_SE -> right p0 p1 src_arm dst_arm@@ -132,10 +271,9 @@ -- diagonal segment joins the arms.  --  connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => Connector u-connvdiagv = qpromoteConn $ \p0 p1 -> -    connectorSrcArm >>= \src_arm ->-    connectorDstArm >>= \dst_arm ->+           => ConnectorProps -> ConnectorPathQuery u+connvdiagv props = buildConn props verticalSrc verticalDst $ \p0 p1 -> +    connectorArms props >>= \(src_arm, dst_arm) ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> up   p0 p1 src_arm dst_arm       QUAD_NW -> up   p0 p1 src_arm dst_arm@@ -160,9 +298,9 @@ -- end point --  conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => Connector u-conndiagh = qpromoteConn $ \p0 p1 -> -    connectorDstArm >>= \dst_arm ->+          => ConnectorProps -> ConnectorPathQuery u+conndiagh props = buildConn props inlineSrc horizontalDst $ \p0 p1 -> +    connectorArms props >>= \(_,dst_arm) ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> right p0 p1 dst_arm       QUAD_SE -> right p0 p1 dst_arm@@ -185,9 +323,9 @@ -- point. --  conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => Connector u-conndiagv = qpromoteConn $ \p0 p1 -> -    connectorDstArm >>= \dst_arm ->+          => ConnectorProps -> ConnectorPathQuery u+conndiagv props = buildConn props inlineSrc verticalDst $ \p0 p1 -> +    connectorArms props >>= \(_,dst_arm) ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> up    p0 p1 dst_arm       QUAD_NW -> up    p0 p1 dst_arm@@ -210,9 +348,9 @@ -- end point. --  connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => Connector u-connhdiag = qpromoteConn $ \p0 p1 -> -    connectorSrcArm >>= \src_arm ->+          => ConnectorProps -> ConnectorPathQuery u+connhdiag props = buildConn props horizontalSrc inlineDst $ \p0 p1 -> +    connectorArms props  >>= \(src_arm,_) ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> right p0 p1 src_arm       QUAD_SE -> right p0 p1 src_arm@@ -235,9 +373,9 @@ -- end point. --  connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => Connector u-connvdiag = qpromoteConn $ \p0 p1 -> -    connectorSrcArm >>= \src_arm ->+          => ConnectorProps -> ConnectorPathQuery u+connvdiag props = buildConn props verticalSrc inlineDst $ \p0 p1 -> +    connectorArms props >>= \(src_arm,_) ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> up    p0 p1 src_arm       QUAD_NW -> up    p0 p1 src_arm@@ -248,6 +386,7 @@     down p0 p1 v1 = return $ vertexPath [ p0, p0 .-^ vvec v1, p1 ]  + -- DESIGN NOTE - should the concept of /above/ and /below/ use  -- quadrants? --@@ -262,10 +401,9 @@ -- The bar is drawn /above/ the points. -- connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) -         => Connector u-connabar = qpromoteConn $ \p0 p1 ->-    connectorSrcArm >>= \src_arm ->-    connectorDstArm >>= \dst_arm ->+         => ConnectorProps -> ConnectorPathQuery u+connabar props = buildConn props abovePerpSrc abovePerpDst $ \p0 p1 ->+    connectorArms props >>= \(src_arm,dst_arm) ->     let ang = vdirection $ pvec p0 p1     in return $ vertexPath [ p0, dispDirectionTheta UP src_arm ang p0                            , dispDirectionTheta UP dst_arm ang p1, p1 ]@@ -280,10 +418,9 @@ -- The bar is drawn /below/ the points. -- connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) -         => Connector u-connbbar = qpromoteConn $ \p0 p1 ->-    connectorSrcArm >>= \src_arm ->-    connectorDstArm >>= \dst_arm ->+         => ConnectorProps -> ConnectorPathQuery u+connbbar props = buildConn props belowPerpSrc belowPerpDst $ \p0 p1 ->+    connectorArms props >>= \(src_arm, dst_arm) ->     let ang = vdirection $ pvec p0 p1     in return $ vertexPath [ p0, dispDirectionTheta DOWN src_arm ang p0                            , dispDirectionTheta DOWN dst_arm ang p1, p1 ]@@ -299,9 +436,10 @@ -- The bar is drawn /above/ the points. -- connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) -           => Connector u-connaright = qpromoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->-    let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1]+           => ConnectorProps -> ConnectorPathQuery u+connaright props = +    buildConn props verticalSrc horizontalDst $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->+      let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1]   -- | Right angle connector.@@ -313,8 +451,9 @@ -- The bar is drawn /below/ the points. -- connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u) -           => Connector u-connbright = qpromoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) ->+           => ConnectorProps -> ConnectorPathQuery u+connbright props = +    buildConn props horizontalSrc verticalDst $ \ p0@(P2 _ y0) p1@(P2 x1 _) ->     let mid = P2 x1 y0 in return $ vertexPath [p0, mid, p1]  @@ -324,7 +463,7 @@ -- | Derive the direction aka. sign of an arm. -- directional :: (Num u, Ord u) => u -> u -> u -> u-directional src dst arm = if  src < dst then arm else negate arm+directional src dst arm = if src < dst then arm else negate arm                       @@ -340,10 +479,11 @@ -- horizontal distance.  -- connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) -        => Connector u-connhrr = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->-    fmap (directional x0 x1) connectorSrcArm >>= \ src_arm -> -    let a0 = p0 .+^ hvec src_arm+        => ConnectorProps -> ConnectorPathQuery u+connhrr props = +    buildConn props horizontalSrc horizontalDst $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+    connectorArms props >>= \(src_arm,_) -> +    let a0 = p0 .+^ hvec (directional x0 x1 src_arm)         a1 = a0 .+^ vvec (y1 - y0)     in return $ vertexPath [p0, a0, a1, p1] @@ -360,12 +500,13 @@ -- horizontal distance.  -- connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) -        => Connector u-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)-    in return $ vertexPath [p0, a0, a1, p1]+        => ConnectorProps -> ConnectorPathQuery u+connrrh props = +    buildConn props horizontalSrc horizontalDst $ \p0@(P2 x0 y0) p1@(P2 x1 y1) ->+      connectorArms props >>= \(_,dst_arm) -> +      let a1 = p1 .-^ hvec (directional x0 x1 dst_arm)+          a0 = a1 .-^ vvec (y1 - y0)+      in return $ vertexPath [p0, a0, a1, p1]   -- | Connector with two right angles...@@ -377,12 +518,13 @@ -- >  o   -- connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) -        => Connector u-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)-    in return $ vertexPath [p0, a0, a1, p1]+        => ConnectorProps -> ConnectorPathQuery u+connvrr props = +    buildConn props verticalSrc verticalDst $ \p0@(P2 x0 y0) p1@(P2 x1 y1) ->+      connectorArms props >>= \(src_arm,_) -> +      let a0 = p0 .+^ vvec (directional y0 y1 src_arm)+          a1 = a0 .+^ hvec (x1 - x0)+      in return $ vertexPath [p0, a0, a1, p1]   -- | Connector with two right angles...@@ -394,12 +536,13 @@ -- >  o   -- connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) -        => Connector u-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)-    in return $ vertexPath [p0, a0, a1, p1]+        => ConnectorProps -> ConnectorPathQuery u+connrrv props = +    buildConn props verticalSrc verticalDst $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) ->+      connectorArms props >>= \(_,dst_arm) -> +      let a1 = p1 .-^ vvec (directional y0 y1 dst_arm)+          a0 = a1 .-^ hvec (x1 - x0)+      in return $ vertexPath [p0, a0, a1, p1]   @@ -413,7 +556,7 @@ -- The loop is drawn /above/ the points. -- connaloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) -          => Connector u+          => ConnectorProps -> ConnectorPathQuery u connaloop = loopbody id  -- | Loop connector.@@ -425,17 +568,16 @@ -- The loop is drawn /above/ the points. -- connbloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) -          => Connector u+          => ConnectorProps -> ConnectorPathQuery u connbloop = loopbody negate  -- | Looping just differs on a negate... -- loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u)-         => (u -> u) -> Connector u-loopbody fn = qpromoteConn $ \p0 p1 ->-    connectorSrcArm   >>= \src_arm ->-    connectorDstArm   >>= \dst_arm ->-    connectorLoopSize >>= \loop_len ->+         => (u -> u) -> ConnectorProps -> ConnectorPathQuery u+loopbody fn props = buildConn props extlineSrc extlineDst $ \p0 p1 ->+    connectorArms props  >>= \(src_arm, dst_arm) ->+    connectorLoopSize props >>= \loop_len ->     let ang = vdirection $ pvec p0 p1          a0  = dispParallel (negate src_arm) ang p0         a1  = dispPerpendicular (fn loop_len) ang a0@@ -453,12 +595,14 @@ -- -- Note - the source and dest arm lengths are doubled, generally  -- this produces nicer curves.+-- +-- Warning - currently bezier connectors do not draw properly+-- with source or destination spacers. -- connhbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)-            => Connector u-connhbezier = qpromoteConn $ \p0 p1 -> -    fmap (2*) connectorSrcArm   >>= \src_arm ->-    fmap (2*) connectorDstArm   >>= \dst_arm ->+            => ConnectorProps -> ConnectorPathQuery u+connhbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +    fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,dst_arm) ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> right p0 p1 src_arm dst_arm       QUAD_SE -> right p0 p1 src_arm dst_arm@@ -481,11 +625,13 @@ -- Note - the source and dest arm lengths are doubled, generally  -- this produces nicer curves. --+-- Warning - currently bezier connectors do not draw properly+-- with source or destination spacers.+-- connvbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)-            => Connector u-connvbezier = qpromoteConn $ \p0 p1 -> -    fmap (2*) connectorSrcArm   >>= \src_arm ->-    fmap (2*) connectorDstArm   >>= \dst_arm ->+            => ConnectorProps -> ConnectorPathQuery u+connvbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +    fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,dst_arm) ->     case quadrant $ vdirection $ pvec p0 p1 of       QUAD_NE -> up   p0 p1 src_arm dst_arm       QUAD_NW -> up   p0 p1 src_arm dst_arm

@@ -0,0 +1,148 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.ConnectorProps+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Connectors...+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.ConnectorProps+  ( ++    -- * Data types+    ConnectorProps(..)+  , default_connector_props++  -- * Queries+  , connectorSrcSpace+  , connectorDstSpace+  , connectorArms+  , connectorLoopSize+  , connectorBoxHalfSize ++  ) where+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative++++-- | ConnectorProps control the drawing of connectors in +-- Wumpus-Drawing.+--+-- > conn_src_space     :: Em+-- > conn_dst_space     :: Em+--+-- Source and destination offsets - these offset the drawing of+-- the connector perpendicular to the direction of line formed +-- between the connector points (a positive offset is drawn above, +-- a negative offset below). The main use of offsets is to draw+-- parallel line connectors.+--+-- > conn_arc_ang       :: Radian +--+-- Control the /bend/ of an arc connector.+-- +-- > conn_src_arm       :: Em+-- > conn_dst_arm       :: Em +--+-- Control the /arm/ length of a jointed connector - arms are the +-- initial segments of the connector. +--+-- > conn_loop_size     :: Em+--+-- Control the /height/ of a loop connector. +--+-- > conn_box_halfsize  :: Em+-- +-- Control the size of a connector box. Connector boxes are +-- drawn with the exterior lines projected out from the connector+-- points a halfsize above and below.+-- +data ConnectorProps = ConnectorProps+      { conn_src_space       :: !Em+      , conn_dst_space       :: !Em+      , conn_arc_ang         :: !Radian+      , conn_src_arm         :: !Em+      , conn_dst_arm         :: !Em+      , conn_loop_size       :: !Em+      , conn_box_halfsize    :: !Em+      }+  deriving (Eq,Show)+++-- | Default connector properties.+--+-- > conn_src_sep:        0+-- > conn_dst_sep:        0+-- > conn_arc_ang:        pi / 12+-- > conn_src_arm:        1+-- > conn_dst_arm:        1+-- > conn_loop_size:      2 +-- > conn_box_half_size:  2+--+-- Arc angle is 15deg - quite shallow.+--+default_connector_props :: ConnectorProps+default_connector_props = +    ConnectorProps { conn_src_space    = 0+                   , conn_dst_space    = 0+                   , conn_arc_ang      = pi / 12+                   , conn_src_arm      = 1+                   , conn_dst_arm      = 1+                   , conn_loop_size    = 2 +                   , conn_box_halfsize = 1+                   }+++++--------------------------------------------------------------------------------+-- Queries+++connectorSrcSpace :: (DrawingCtxM m, InterpretUnit u) +                  => ConnectorProps -> m u+connectorSrcSpace props = +    (\sz -> uconvert1 sz $ conn_src_space props) <$> pointSize+++connectorDstSpace :: (DrawingCtxM m, InterpretUnit u) +                  => ConnectorProps -> m u+connectorDstSpace props = +    (\sz -> uconvert1 sz $ conn_dst_space props) <$> pointSize+++connectorArms :: (DrawingCtxM m, InterpretUnit u) +              => ConnectorProps -> m (u,u)+connectorArms props = +    (\sz -> ( uconvert1 sz $ conn_src_arm props+            , uconvert1 sz $ conn_dst_arm props) )+        <$> pointSize++++connectorLoopSize :: (DrawingCtxM m, InterpretUnit u) +                  => ConnectorProps -> m u+connectorLoopSize props = +    (\sz -> uconvert1 sz $ conn_loop_size props) <$> pointSize+++connectorBoxHalfSize :: (DrawingCtxM m, InterpretUnit u) +                  => ConnectorProps -> m u+connectorBoxHalfSize props = +    (\sz -> uconvert1 sz $ conn_box_halfsize props) <$> pointSize+

@@ -39,8 +39,8 @@   , dotNone   , dotChar   , dotText-  , dotHLine-  , dotVLine+  , dotHBar+  , dotVBar   , dotX   , dotPlus   , dotCross@@ -225,9 +225,9 @@             => 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+    let alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices uh+    in (\ps -> polygonAnchor ps pt) +         <$> qapplyLoc (placedTrailPoints alg) pt   where     fn3 (a,b,c) = [a,b,c] @@ -273,17 +273,17 @@  dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u  dotText ss = -    fmap bboxRectAnchor $ runPosObjectBBox (posText ss) CENTER+    fmap bboxRectAnchor $ runPosObjectBBox CENTER $ posText ss  -- Note - maybe Wumpus-Basic should have a @swapAns@ function?  -dotHLine :: (Floating u, InterpretUnit u) => DotLocImage u-dotHLine = intoLocImage (circleLDO 0.5) SD.dotHLine+dotHBar :: (Floating u, InterpretUnit u) => DotLocImage u+dotHBar = intoLocImage (circleLDO 0.5) SD.dotHBar  -dotVLine :: (Floating u, InterpretUnit u) => DotLocImage u-dotVLine = intoLocImage (circleLDO 0.5) SD.dotVLine+dotVBar :: (Floating u, InterpretUnit u) => DotLocImage u+dotVBar = intoLocImage (circleLDO 0.5) SD.dotVBar   dotX :: (Floating u, InterpretUnit u) => DotLocImage u@@ -320,7 +320,8 @@ dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u dotPentagon = intoLocImage (circleLDO 0.5) SD.dotPentagon -dotStar :: (Floating u, InterpretUnit u) => DotLocImage u+dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance u) +        => DotLocImage u dotStar = intoLocImage (circleLDO 0.5) SD.dotStar  @@ -346,5 +347,5 @@              => LocQuery u a -> LocImage u z -> LocImage u a intoLocImage ma gf = promoteLoc $ \pt ->                       askDC >>= \ctx -> -                     let ans = runLocQuery ma ctx pt+                     let ans = runLocQuery ctx pt ma                      in replaceAns ans $ applyLoc gf pt

@@ -46,8 +46,8 @@   , dotEscText  -  , dotHLine-  , dotVLine+  , dotHBar+  , dotVBar   , dotX   , dotPlus   , dotCross@@ -67,7 +67,7 @@    ) where -+import Wumpus.Drawing.Basis.Symbols  import Wumpus.Basic.Geometry                    -- package: wumpus-basic import Wumpus.Basic.Kernel        @@ -104,7 +104,11 @@   normalize sz a = (realToFrac  a) * 0.75 * fromIntegral sz   dinterp sz d   = (4/3) * (realToFrac d) / (fromIntegral sz) +instance Tolerance MarkSize where +  eq_tolerance     = 0.001+  length_tolerance = 0.01 + umark :: InterpretUnit u => LocGraphic MarkSize -> LocGraphic u umark = uconvF @@ -112,25 +116,25 @@ -- | Filled disk - radius 0.25 MarkSize. -- smallDisk :: InterpretUnit u => LocGraphic u-smallDisk = umark $ dcDisk FILL 0.25+smallDisk = umark $ dcDisk DRAW_FILL 0.25   -- | Filled disk - radius 1.0 MarkSize. -- largeDisk :: InterpretUnit u => LocGraphic u-largeDisk = umark $ dcDisk FILL 1+largeDisk = umark $ dcDisk DRAW_FILL 1   -- | Stroked disk (circle) - radius 0.25 MarkSize. -- smallCirc :: InterpretUnit u => LocGraphic u-smallCirc = umark $ dcDisk STROKE 0.25+smallCirc = umark $ ocircle 0.25   -- | Stroked disk (circle) - radius 1.0 MarkSize. -- largeCirc :: InterpretUnit u => LocGraphic u-largeCirc = umark $ dcDisk STROKE 1+largeCirc = umark $ ocircle 1   -- possibly:@@ -145,7 +149,7 @@   dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u-dotText ss = ignoreAns $ runPosObject (posText ss) CENTER+dotText ss = ignoreAns $ runPosObject CENTER $ posText ss  dotEscChar :: (Real u, Floating u, InterpretUnit u)             => EscapedChar -> LocGraphic u@@ -153,7 +157,7 @@  dotEscText :: (Real u, Floating u, InterpretUnit u)             => EscapedText -> LocGraphic u-dotEscText esc = ignoreAns $ runPosObject (posEscText esc) CENTER+dotEscText esc = ignoreAns $ runPosObject CENTER $ posEscText esc  -- TODO - need Upright versions of dots... @@ -165,12 +169,12 @@ axialLine v = moveStart (negateV (0.5 *^ v)) (locStraightLine v)  -dotHLine :: (Fractional u, InterpretUnit u) => LocGraphic u -dotHLine = umark $ axialLine (hvec 1)+dotHBar :: (Fractional u, InterpretUnit u) => LocGraphic u +dotHBar = umark $ hbar 1  -dotVLine :: (Fractional u, InterpretUnit u) => LocGraphic u -dotVLine = umark $ axialLine (vvec 1) +dotVBar :: (Fractional u, InterpretUnit u) => LocGraphic u +dotVBar = umark $ vbar 1    dotX :: (Fractional u, InterpretUnit u) => LocGraphic u@@ -179,7 +183,7 @@   dotPlus :: (Fractional u, InterpretUnit u) =>  LocGraphic u-dotPlus = dotVLine `mappend` dotHLine+dotPlus = dotVBar `mappend` dotHBar   dotCross :: (Floating u, InterpretUnit u) =>  LocGraphic u@@ -193,55 +197,57 @@   dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-dotDiamond = umark $ drawVertexPathAlg STROKE (diamondPathAlg 0.5 0.66)+dotDiamond = umark $ drawPlacedTrail CSTROKE (diamondTrail 0.5 0.66)  dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-dotFDiamond = umark $ drawVertexPathAlg FILL (diamondPathAlg 0.5 0.66)+dotFDiamond = umark $ drawPlacedTrail CFILL (diamondTrail 0.5 0.66)    dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-dotBDiamond = umark $ drawVertexPathAlg FILL_STROKE (diamondPathAlg 0.5 0.66)+dotBDiamond = umark $ drawPlacedTrail CFILL_STROKE (diamondTrail 0.5 0.66)   -- | Note disk is filled. -- dotDisk :: (Fractional u, InterpretUnit u) => LocGraphic u-dotDisk = umark $ dcDisk FILL 0.5+dotDisk = umark $ dcDisk DRAW_FILL 0.5    dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u-dotSquare = umark $ drawVertexPathAlg STROKE (rectanglePathAlg 1 1)+dotSquare = umark $ drawPlacedTrail CSTROKE (rectangleTrail 1 1)   dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u-dotCircle = umark $ dcDisk STROKE 0.5+dotCircle = umark $ ocircle 0.5   dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u-dotBCircle = umark $ dcDisk FILL_STROKE 0.5+dotBCircle = umark $ dcDisk DRAW_FILL_STROKE 0.5    dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u-dotPentagon = umark $ drawVertexPathAlg STROKE (polygonPathAlg 5 0.5)+dotPentagon = umark $ drawPlacedTrail CSTROKE (polygonTrail 5 0.5)    -dotStar :: (Floating u, InterpretUnit u) => LocGraphic u +dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance 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+starLines :: (Floating u, Ord u, InterpretUnit u, Tolerance u) +          => u -> LocGraphic u+starLines hh = promoteLoc $ \ctr ->+    let alg = polygonTrail 5 hh+    in liftQuery (qapplyLoc (placedTrailPoints alg) ctr) >>= \ps -> +       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 @@ -272,7 +278,7 @@   dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u-dotTriangle = umark $ drawVertexPathAlg STROKE alg +dotTriangle = umark $ drawPlacedTrail CSTROKE alg    where-    alg = pathIterateLocus $ fn3 $ equilateralTriangleVertices 1+    alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices 1     fn3 = \(a,b,c) -> [a,b,c]

@@ -18,10 +18,14 @@   (          orthontAxes+ +  , horizontalLabels+  , verticalLabels    ) where  import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C  import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Core                              -- package: wumpus-core@@ -35,14 +39,36 @@ -- orthontAxes :: (Real u, Floating u, InterpretUnit u)             => (Int,Int) -> (Int,Int) -> LocGraphic u-orthontAxes (xl,xr) (yl,yr) = -    promoteLoc $ \(P2 x y) -> +orthontAxes (xl,xr) (yl,yr) = promoteLoc $ \(P2 x y) ->      snapmove (1,1) >>= \(V2 uw uh) ->     let conn1 = rightArrow barb45 connline         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)+    in  localize cap_square $           ignoreAns (connect conn1 xPtl xPtr) +                              `mappend` ignoreAns (connect conn1 yPtl yPtr) +++horizontalLabels :: (Num a, Fractional u, InterpretUnit u) +                 => RectAddress -> [a] -> LocGraphic u +horizontalLabels addr ns = +    snapmove (1,1) >>= \(V2 uw _) -> ignoreAns (runChainH uw $ mapM mf ns)+  where+    mf n = chain1 $ runPosObject addr $ posTextUpright $ show n+++verticalLabels :: (Num a, Fractional u, InterpretUnit u) +               => RectAddress -> [a] -> LocGraphic u +verticalLabels addr ns = +    snapmove (1,1) >>= \(V2 _ uh) -> ignoreAns (runChainV uh $ mapM mf ns)+  where+    mf n = chain1 $ runPosObject addr $ posTextUpright $ show n++++-- Cf. Parsec\'s Token module...+--+connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u+connline = C.connline default_connector_props

@@ -16,6 +16,8 @@ -- Ideally, clipping would be defined in Wumpus-Basic, but clipping -- needs a higher level path object than Wumpus-Basic provides. -- +-- \*\* WARNING \*\* names need improving.+-- --------------------------------------------------------------------------------  module Wumpus.Drawing.Extras.Clip@@ -26,16 +28,19 @@   ) where  -import Wumpus.Drawing.Paths.Relative+import Wumpus.Drawing.Paths  import Wumpus.Basic.Kernel                      -- package: wumpus-basic   - -- | Clip a LocGraphic.+-- +-- \*\* WARNING \*\* - AbsPath (coordinate-specific) is the wrong +-- object to clip a LocGraphic (coordinate-free).  ---locClip :: InterpretUnit u => RelPath u -> LocGraphic u -> LocGraphic u-locClip rp gf = promoteLoc $ \pt -> -    liftQuery (toPrimPath pt rp) >>= \pp -> clipImage pp (gf `at` pt)+locClip :: InterpretUnit u => AbsPath u -> LocGraphic u -> LocGraphic u+locClip absp gf = promoteLoc $ \pt -> +    liftQuery (toPrimPath absp) >>= \pp -> clipImage pp (gf `at` pt)+ 

@@ -155,9 +155,9 @@     let props  = upd default_grid_props         width  = uw * fromIntegral nx         height = uh * fromIntegral ny-        intrr = gridInterior nx width uw ny height uh props+        intrr  = gridInterior nx width uw ny height uh props         rect   = localize (major_line_update props) $ -                   blRectangle STROKE width height+                   blRectangle DRAW_STROKE width height     in intrr `mappend` rect                   @@ -178,8 +178,8 @@                   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+    mnr  = localize (minor_line_update props) $ horizontalLine w+    mjr  = localize (major_line_update props) $ horizontalLine w   @@ -191,8 +191,8 @@                   in moveStart (hvec dx) $ minorMajor n subs (hvec dx) mnr mjr     | otherwise = moveStart (hvec uw) $ duplicate numv (hvec uw) mjr   where-    mnr  = localize (minor_line_update props) $ vline h-    mjr  = localize (major_line_update props) $ vline h+    mnr  = localize (minor_line_update props) $ verticalLine h+    mjr  = localize (major_line_update props) $ verticalLine h   

@@ -21,10 +21,10 @@   ) where  -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths -import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic-import Wumpus.Basic.Kernel+import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  

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

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

@@ -0,0 +1,967 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.Base+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Absolute path type - this should be more amenable for building +-- complex drawings than the PrimPath type in Wumpus-Core.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.Base+  ( ++  -- * Absolute path type+    AbsPath+  , DAbsPath+++  -- * Construction+  , emptyPath+  , line1+  , curve1+  , vertexPath+  , curvePath+  , controlCurve++  , vectorPath+  , vectorPathTheta++  , placedTrailPath+  , catTrailPath++  -- * Queries+  , null+  , length++  -- * Concat and extension+  , snocLine+  , snocLineTo+  , snocCurve+  , snocCurveTo+++  -- * Conversion+  , toPrimPath++  , drawPath+  , drawPath_++  -- * Shortening+  , shortenPath+  , shortenL+  , shortenR++  -- * Tips and direction+  , tipL+  , tipR+  , directionL+  , directionR+  , isBezierL+  , isBezierR+++  -- * Path anchors+  , midway+  , midway_+  , atstart+  , atstart_+  , atend+  , atend_+++  -- * Views+  , PathViewL(..)+  , DPathViewL+  , PathViewR(..)+  , DPathViewR+  , PathSegment(..)+  , DPathSegment+  , pathViewL+  , pathViewR++  , optimizeLines++  , roundExterior+  , roundInterior++  -- * Path division+  , pathdiv+++  ) where++++import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Kernel+import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl+                                   , ViewR(..), viewr, cons, snoc )+import qualified Wumpus.Basic.Utils.JoinList as JL++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Data.Monoid+import qualified Data.Traversable as T++import Prelude hiding ( null, length )++--+-- Design Note+-- +-- Wumpus has no relative path type. An AbsPath is expected to be +-- an /answer/ from some function like an anchor point or a +-- bounding box.+--+-- Wumpus didn\'t always work on this premise, some of the code +-- below may contradict this...+--++++++-- | Absolute path data type.+--+data AbsPath u = AbsPath +      { _abs_path_length   :: u +      , _abs_path_start    :: Point2 u+      , _abs_path_elements :: JoinList (AbsPathSeg u)+      , _abs_path_end      :: Point2 u+      }+  deriving (Eq,Show)++type instance DUnit (AbsPath u) = u+++type DAbsPath = AbsPath Double++-- Annotating each segment with length is \*\* good \*\*.+-- Makes it much more efficient to find the midway point.+--+-- But what do we do about the start point:+--+-- a) put it in the segment - too much info in the type, allows +-- consistency problems vis-a-vis gaps in the path.+--+-- b) leave it out - too little info in the type, allows +-- consistency problems with length.+--+-- Option (a) is probably most convenient espcially as the +-- constructors won\'t be exported.++-- Annotation is length...+-- +data AbsPathSeg u = AbsLineSeg  u (Vec2 u)+                  | AbsCurveSeg u (Vec2 u) (Vec2 u) (Vec2 u)+  deriving (Eq,Show)+++type instance DUnit (AbsPathSeg u) = u++-- +-- DESIGN NOTE+--+-- No monoid instance. AbsPaths dont support empty or even concat +-- naturally.+--+-- Concat is troublesome because AbsPaths are always located +-- within a frame.+--+-- They can support:+--+-- a. Concat with a join between the end of the first path and the+-- start of the second.+-- +-- b. Shape preserving concat - the second path is moved so it +-- continues from the end point of the first path.+--+-- It is conceptually simpler to think about extension (adding to +-- the path tip) rather than concatenation. +--++--------------------------------------------------------------------------------++instance Functor AbsPath where+  fmap f (AbsPath u sp ls ep) = +      AbsPath (f u) (fmap f sp) (fmap (fmap f) ls) (fmap f ep)++instance Functor AbsPathSeg where+  fmap f (AbsLineSeg u v1)        = +      AbsLineSeg (f u) (fmap f v1)++  fmap f (AbsCurveSeg u v1 v2 v3) = +      AbsCurveSeg (f u) (fmap f v1) (fmap f v2) (fmap f v3)++++--------------------------------------------------------------------------------+-- Translate++-- Translate is cheap on AbsPath++instance Num u => Translate (AbsPath u) where+  translate x y (AbsPath len sp se ep) = +      AbsPath len (translate x y sp) se (translate x y ep)++++--------------------------------------------------------------------------------+-- Construction++-- | Create the empty path.+-- +-- Note - an absolute path needs /locating/ and cannot be built +-- without a start point. Figuratively, the empty path is a path+-- from the start point to the end point.+--+-- Thus AbsPath operates as a semigroup but not a monoid.+--+emptyPath :: Floating u => Point2 u -> AbsPath u+emptyPath = zeroPath+++-- | Create an absolute path as a straight line between the +-- supplied points.+--+line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u +line1 p0 p1 = AbsPath len p0 (JL.one $ AbsLineSeg len v1) p1+  where+    v1  = pvec p0 p1+    len = vlength v1++-- | Create an absolute path from a single cubic Bezier curve.+--+curve1 :: (Floating u, Ord u, Tolerance u)+      => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u +curve1 p0 p1 p2 p3 = +    AbsPath len p0 (JL.one $ AbsCurveSeg len v1 v2 v3) p3+  where+    v1  = pvec p0 p1+    v2  = pvec p1 p2+    v3  = pvec p2 p3+    len = bezierLength (BezierCurve p0 p1 p2 p3)+++-- | 'vertexPath' throws a runtime error if the supplied list+-- is empty. +--+vertexPath :: (Floating u, Ord u, Tolerance u) +           => [Point2 u] -> AbsPath u+vertexPath []       = error "traceLinePoints - empty point list."+vertexPath [a]      = line1 a a+vertexPath (a:b:xs) = step (line1 a b) xs+  where+    step acc []     = acc+    step acc (y:ys) = step (snocLineTo acc y) ys++++-- | 'curvePath' consumes 4 points from the list on the +-- intial step (start, control1, control2, end) then steps +-- through the list taking 3 points at a time thereafter+-- (control1,control2, end). Leftover points are discarded.    +-- +-- 'curvePath' throws a runtime error if the supplied list+-- is has less than 4 elements (start, control1, control2, end). +--+curvePath :: (Floating u, Ord u, Tolerance u) +          => [Point2 u] -> AbsPath u+curvePath (a:b:c:d:xs) = step (curve1 a b c d) xs+  where+    step acc (x:y:z:zs) = step (snocCurveTo acc (x,y,z)) zs+    step acc _          = acc++curvePath _            = error "curvePath - less than 4 elems."++++-- NOTE - need a proper arc path builder.++++-- | This is not an arc...+-- +controlCurve :: (Floating u, Ord u, Tolerance u) +         => Point2 u -> Radian -> Radian -> Point2 u -> AbsPath u+controlCurve start cin cout end = +    curve1 start (start .+^ v1) (end .+^ v2) end+  where+    sz     = 0.375 * (vlength $ pvec start end)+    v1     = avec cin  sz+    v2     = avec cout sz++++++vectorPath :: (Floating u, Ord u, Tolerance u) +           => [Vec2 u] -> Point2 u -> AbsPath u+vectorPath vecs p0 = vertexPath $ p0 : step p0 vecs+  where+    step _ []       = []+    step pt (v1:vs) = let p1 = pt .+^ v1 in p1 : step p1 vs +++vectorPathTheta :: (Real u, Floating u, Tolerance u) +                => [Vec2 u] -> Radian -> Point2 u -> AbsPath u +vectorPathTheta vs ang = vectorPath $ map (rotate ang) vs+++placedTrailPath :: (Floating u, Ord u, Tolerance u) +                => Point2 u -> PlacedTrail u -> AbsPath u+placedTrailPath pt trl = +    let (v1,ss) = destrPlacedTrail trl in step (emptyPath $ pt .+^ v1) ss+  where+    step ac []                   = ac+    step ac (TLine v1:xs)        = step (ac `snocLine` v1) xs+    step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs+  +catTrailPath :: (Floating u, Ord u, Tolerance u) +             => Point2 u -> CatTrail u -> AbsPath u+catTrailPath pt trl = step (emptyPath pt) $ destrCatTrail trl+  where+    step ac []                   = ac+    step ac (TLine v1:xs)        = step (ac `snocLine` v1) xs+    step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs+  ++--------------------------------------------------------------------------------+-- Queries++-- | Is the path empty?+--+null :: AbsPath u -> Bool+null = JL.null . _abs_path_elements++-- | 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 :: Num u => AbsPath u -> u+length (AbsPath u _ _ _) = u+++--------------------------------------------------------------------------------+-- Extension++infixl 5 `snocLine`+++-- | Extend the path with a straight line segment from the +-- end-point defined by the supplied vector.+--+-- > infixl 5 `snocLine`+--+snocLine :: Floating u => AbsPath u -> Vec2 u -> AbsPath u+snocLine (AbsPath u sp se ep) v1 = +  let u1        = vlength v1 +      tail_line = AbsLineSeg u1 v1+  in AbsPath (u + u1) sp (JL.snoc se tail_line) (ep .+^ v1)++++infixl 5 `snocLineTo`+++-- | Extend the path with a straight line segment from the +-- end-point to the supplied point.+--+-- > infixl 5 `snocLineTo`+--+snocLineTo :: Floating u => AbsPath u -> Point2 u -> AbsPath u+snocLineTo (AbsPath u sp se1 ep) p1 = AbsPath (u + len) sp (snoc se1 s1) p1+  where+    s1@(AbsLineSeg len _) = lineSegment ep p1+++infixl 5 `snocCurve`++-- | Extend the path from the end-point with a Bezier curve +-- segment formed by the supplied points.+--+-- > infixl 5 `snocCurve`+-- +snocCurve :: (Floating u, Ord u, Tolerance u)+          => AbsPath u -> (Vec2 u, Vec2 u, Vec2 u) -> AbsPath u+snocCurve absp@(AbsPath _ _ _ ep) (v1,v2,v3) = snocCurveTo absp (p1,p2,p3)+  where+    p1 = ep .+^ v1+    p2 = p1 .+^ v2+    p3 = p2 .+^ v3+ ++infixl 5 `snocCurveTo`+++-- | Extend the path from the end-point with a Bezier curve +-- segment formed by the supplied points.+--+-- > infixl 5 `snocCurveTo`+-- +snocCurveTo :: (Floating u, Ord u, Tolerance u)+            => AbsPath u -> (Point2 u, Point2 u, Point2 u) -> AbsPath u+snocCurveTo (AbsPath u sp se1 ep) (p1,p2,p3) = +    AbsPath (u + len) sp (snoc se1 s1) p3+  where+    s1@(AbsCurveSeg len _ _ _) = curveSegment ep p1 p2 p3+ ++-------------------------------------------------------------------------------- ++++segmentLength :: AbsPathSeg u -> u+segmentLength (AbsLineSeg u _)       = u+segmentLength (AbsCurveSeg u _ _ _)  = u+++segmentVector :: Num u => AbsPathSeg u -> Vec2 u+segmentVector (AbsLineSeg  _ v1)       = v1+segmentVector (AbsCurveSeg _ v1 v2 v3) = v1 ^+^ v2 ^+^ v3++++-- | Helper - construct a line segment.+-- +lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u +lineSegment p0 p1 = lineSegmentV $ pvec p0 p1++-- | Helper - construct a line segment.+-- +lineSegmentV :: Floating u => Vec2 u -> AbsPathSeg u +lineSegmentV v1 = AbsLineSeg (vlength v1) v1+++-- | Helper - construct a curve segment.+-- +curveSegment :: (Floating u, Ord u, Tolerance u) +             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPathSeg u +curveSegment p0 p1 p2 p3 = AbsCurveSeg len v1 v2 v3+  where+    len = bezierLength (BezierCurve p0 p1 p2 p3)+    v1  = pvec p0 p1+    v2  = pvec p1 p2+    v3  = pvec p2 p3+++-- | Helper - construct the /empty/ but located path.+-- +zeroPath :: Floating u => Point2 u -> AbsPath u +zeroPath p0 = AbsPath 0 p0 JL.empty p0+   +++drawPath :: InterpretUnit u +         => PathMode -> AbsPath u -> Image u (AbsPath u)+drawPath mode rp = replaceAns rp $ +    liftQuery (toPrimPath rp) >>= dcPath mode+++drawPath_ :: InterpretUnit u +          => PathMode -> AbsPath u -> Graphic u+drawPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode+++-- | Turn a Path into an ordinary PrimPath.+--+-- Assumes path is properly formed - i.e. end point of one +-- segment is the same point as the start point of the next+-- segment.+--+toPrimPath :: InterpretUnit u => AbsPath u -> Query u PrimPath+toPrimPath (AbsPath _ start segs _) = +    uconvertCtxF start       >>= \dstart -> +    T.mapM uconvertCtxF segs >>= \dsegs  ->+    return $ step1 dstart dsegs+  where+    step1 p0 se | JL.null se          = emptyPrimPath p0+                | otherwise           = absPrimPath p0 $ step2 p0 (viewl se)++    step2 _  EmptyL                   = []+    step2 pt (e :< se)                = let (p1,s) = mkSeg pt e+                                        in s : step2 p1 (viewl se)+    +    mkSeg p0 (AbsLineSeg  _ v1)       = let p1 = p0 .+^ v1+                                        in (p1, absLineTo p1)+    mkSeg p0 (AbsCurveSeg _ v1 v2 v3) = let p1 = p0 .+^ v1+                                            p2 = p1 .+^ v2+                                            p3 = p2 .+^ v3+                                        in (p3, absCurveTo p1 p2 p3)+++++++-- | 'sortenPath' : @ left_dist * right_dist * path -> Path @+--+shortenPath :: (Real u , Floating u) +            => u  -> u -> AbsPath u -> AbsPath u+shortenPath l r = shortenL l .  shortenR r +++--------------------------------------------------------------------------------+-- shorten from the left...++-- | Note - shortening a line from the left by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the end point.+--+shortenL :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u+shortenL n path1@(AbsPath u startp segs ep) +    | n <  0                  = path1+    | n >= u                  = AbsPath 0 ep mempty ep +    | otherwise               = step n startp (viewl segs)+  where+    step _ _  EmptyL    = AbsPath 0 ep mempty ep +    step d sp (e :< se) = let z     = segmentLength e+                              snext = sp .+^ segmentVector e+                          in case compare d z of+                             GT -> step (d-z) snext (viewl se)+                             EQ -> makeLeftPath (u-n) snext se ep+                             LT -> let (spart,e1) = shortenSegL d sp e+                                   in AbsPath (u-n) spart (e1 `cons` se) ep+++makeLeftPath :: Floating u +             => u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u +             -> AbsPath u+makeLeftPath u sp se ep | JL.null se = line1 sp ep+                        | otherwise  = AbsPath u sp se ep++++shortenSegL :: (Real u, Floating u) +            => u -> Point2 u -> AbsPathSeg u -> (Point2 u, AbsPathSeg u)+shortenSegL n sp (AbsLineSeg  u v1)        = +    let v2  = shortenVec n v1 +        sp' = sp .+^ (v1 ^-^ v2)+    in (sp', AbsLineSeg  (u-n) v2)++shortenSegL n sp (AbsCurveSeg u v1 v2 v3)  = +    (q0, AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3))+  where+    (BezierCurve q0 q1 q2 q3) = let p1 = sp .+^ v1+                                    p2 = p1 .+^ v2+                                    p3 = p2 .+^ v3+                                in snd $ subdividet (n/u) +                                                    (BezierCurve sp p1 p2 p3)+     +++shortenVec :: (Real u, Floating u) => u -> Vec2 u -> Vec2 u+shortenVec n v0 = v0 ^-^ v+  where+    v  = avec (vdirection v0) n+++--------------------------------------------------------------------------------+-- shorten from the right ...+ +-- | Note - shortening a line from the right by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the start point.+--+shortenR :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u+shortenR n path1@(AbsPath u sp segs endpt) +    | n < 0                   = path1+    | n >= u                  = AbsPath 0 sp mempty sp +    | otherwise               = step n (viewr segs) endpt+  where+    step _ EmptyR    _  = AbsPath 0 sp mempty sp +    step d (se :> e) ep = let z   = segmentLength e +                              enext = ep .-^ segmentVector e+                          in case compare d z of+                              GT -> step (d-z) (viewr se) enext+                              EQ -> makeRightPath n sp se enext+                              LT -> let (e1,epart) = shortenSegR d e ep+                                    in AbsPath (u-n) sp (se `snoc` e1) epart+                         ++makeRightPath :: Floating u +              => u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u +              -> AbsPath u+makeRightPath u sp se ep | JL.null se = line1 sp ep+                         | otherwise  = AbsPath u sp se ep+++shortenSegR :: (Real u, Floating u) +            => u -> AbsPathSeg u -> Point2 u -> (AbsPathSeg u, Point2 u)+shortenSegR n (AbsLineSeg u v1)        ep = +    let v2  = shortenVec n v1 +        ep' = ep .-^ (v1 ^+^ v2)+    in (AbsLineSeg (u-n) v2, ep')++shortenSegR n (AbsCurveSeg u v1 v2 v3) ep = +    (AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3), q3)+  where+    (BezierCurve q0 q1 q2 q3) = let p2 = ep .-^ v3+                                    p1 = p2 .-^ v2+                                    p0 = p1 .-^ v1+                                in fst $ subdividet ((u-n)/u) +                                                    (BezierCurve p0 p1 p2 ep)+     +++++--------------------------------------------------------------------------------+-- tips ++tipL :: AbsPath u -> Point2 u+tipL (AbsPath _ sp _ _) = sp+++tipR :: AbsPath u -> Point2 u+tipR (AbsPath _ _ _ ep) = ep+++--------------------------------------------------------------------------------+-- line direction++-- | Direction of empty path is considered to be 0.+--+directionL :: (Real u, Floating u) => AbsPath u -> Radian+directionL (AbsPath _ _ se _)  = step $ viewl se+  where+    step (AbsLineSeg  _ v1 :< _)       = vdirection $ negateV v1+    step (AbsCurveSeg _ v1 _  _  :< _) = vdirection $ negateV v1+    step _                             = 0+++-- | Direction of empty path is considered to be 0.+--+directionR :: (Real u, Floating u) => AbsPath u -> Radian+directionR (AbsPath _ _ se _) = step $ viewr se+  where+    step (_ :> AbsLineSeg  _ v1)       = vdirection v1+    step (_ :> AbsCurveSeg _ _  _  v3) = vdirection v3+    step _                             = 0+ +-- | Is the left tip a Bezier curve?+--+isBezierL :: AbsPath u -> Bool+isBezierL (AbsPath _ _ se _) = step $ viewl se+  where+    step (AbsCurveSeg _ _ _ _ :< _) = True +    step _                          = False+++ +-- | Is the right tip a Bezier curve?+-- +isBezierR :: AbsPath u -> Bool+isBezierR (AbsPath _ _ se _) = step $ viewr se+  where+    step (_ :> AbsCurveSeg _ _ _ _) = True +    step _                          = False+++--------------------------------------------------------------------------------+++-- Return direction as well because the calculation is expensive...+--+midway :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)+midway pa@(AbsPath u sp _ _) +    | u == 0    = (sp,0)+    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1)++-- Just the midway point.+--+midway_ :: (Real u, Floating u) => AbsPath u -> Point2 u+midway_ = fst . midway+++atstart :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)+atstart pa@(AbsPath _ sp _ _) = (sp, directionL pa)++atstart_ :: AbsPath u -> Point2 u+atstart_ (AbsPath _ sp _ _) = sp+++atend :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)+atend pa@(AbsPath _ _ _ ep) = (ep, directionR pa)+ ++atend_ :: AbsPath u -> Point2 u+atend_ (AbsPath _ _ _ ep) = ep+++-- nearstart, nearend, verynear ...+++++--------------------------------------------------------------------------------+-- Path Views cf. Data.Sequence+++infixr 5 :<<+infixl 5 :>>++data PathViewL u = EmptyPathL+                 | PathSegment u :<< AbsPath u+  deriving (Eq,Show) ++type instance DUnit (PathViewL u) = u ++type DPathViewL = PathViewL Double++data PathViewR u = EmptyPathR+                 | AbsPath u :>> PathSegment u+  deriving (Eq,Show) ++type instance DUnit (PathViewR u) = u ++type DPathViewR = PathViewR Double++++-- | PathSegments are annotated with length.+--+--+data PathSegment u = LineSeg  u (Point2 u) (Point2 u)+                   | CurveSeg u (Point2 u) (Point2 u) (Point2 u) (Point2 u)+  deriving (Eq,Show) ++type instance DUnit (PathSegment u) = u +++type DPathSegment = PathSegment Double+++--------------------------------------------------------------------------------++instance Functor PathSegment where+  fmap f (LineSeg d p0 p1)        = LineSeg (f d) (fmap f p0) (fmap f p1)+  fmap f (CurveSeg d p0 p1 p2 p3) = +      CurveSeg (f d) (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3)++instance Functor PathViewL where+  fmap _ EmptyPathL   = EmptyPathL+  fmap f (a :<< as)   = fmap f a :<< fmap f as++instance Functor PathViewR where+  fmap _ EmptyPathR   = EmptyPathR+  fmap f (as :>> a)   = fmap f as :>> fmap f a++--------------------------------------------------------------------------------++++pathViewL :: Num u => AbsPath u -> PathViewL u+pathViewL (AbsPath len sp segs ep) = go (viewl segs)+  where+    go EmptyL                           = EmptyPathL+     +    go (AbsLineSeg d v1 :< se)        =+        let p1 = sp .+^ v1 in LineSeg d sp p1 :<< AbsPath (len - d) p1 se ep++    go (AbsCurveSeg d v1 v2 v3 :< se) =+        let p1 = sp .+^ v1+            p2 = p1 .+^ v2+            p3 = p2 .+^ v3+        in CurveSeg d sp p1 p2 p3 :<< AbsPath (len - d) p3 se ep+++pathViewR :: Num u => AbsPath u -> PathViewR u+pathViewR (AbsPath len sp segs ep) = go (viewr segs)+  where+    go EmptyR                           = EmptyPathR ++    go (se :> AbsLineSeg d v1)        = +       let p0 = ep .-^ v1 in AbsPath (len - d) sp se p0 :>> LineSeg d p0 ep++    go (se :> AbsCurveSeg d v1 v2 v3) =  +       let p2 = ep .-^ v3+           p1 = p2 .-^ v2+           p0 = p1 .-^ v1+       in AbsPath (len - d) sp se p0 :>> CurveSeg d p0 p1 p2 ep++++--------------------------------------------------------------------------------+++-- 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 _ v1 :< se)              = +        inner acc (vdirection v1) v1 (viewl se)++    outer acc (AbsCurveSeg u v1 v2 v3  :< se)      = +        outer (snocC acc u v1 v2 v3) (viewl se)++    outer acc EmptyL                               = acc++    inner acc d0 v0 (AbsLineSeg _ v1 :< se)        =+        let d1 = vdirection v1+        in if (d0 == vdirection v1) +          then inner acc d1 (v0 ^+^ v1) (viewl se)+          else inner (snocV acc v0) d1 v1 (viewl se)++    inner acc _  v0 (AbsCurveSeg u v1 v2 v3 :< se) = +        let acc1 = snocC (snocV acc v0) u v1 v2 v3+        in outer acc1 (viewl se)++    inner acc _  v0 EmptyL                         = snocV acc v0++    snocC (AbsPath u sp se ep) u1 v1 v2 v3         = +        let tail_curve = AbsCurveSeg u1 v1 v2 v3 +            vtotal     = v1 ^+^ v2 ^+^ v3 +        in AbsPath (u+u1) sp (JL.snoc se tail_curve) (ep .+^ vtotal)++    snocV (AbsPath u sp se ep) v1                  =+        let u1        = vlength v1+            tail_line = AbsLineSeg u1 v1+        in AbsPath (u+u1) sp (JL.snoc se tail_line) (ep .+^ v1)+++--------------------------------------------------------------------------------+-- Round corners+++segToCatTrail :: AbsPathSeg u -> CatTrail u+segToCatTrail (AbsLineSeg _ v1)        = catline v1+segToCatTrail (AbsCurveSeg _ v1 v2 v3) = catcurve v1 v2 v3++-- | Because lookahead of 2 makes the rounding algos easier we+-- decons to a list...+--+segmentListL :: AbsPath u -> (Point2 u, [AbsPathSeg u])+segmentListL (AbsPath _ sp se _) = (sp, JL.toList se)++-- | Round interior corners of a Path.+--+-- The path is treated as open - the start of the initial and end+-- of the final segments are not rounded. Only straight line to +-- straight line joins are rounded, joins to or from Beczier +-- curves are not rounded.+-- +-- Caution - all path segments are expected to be longer than+-- 2x the round corner length, though this is not checked..+--+roundInterior :: (Real u, Floating u,Tolerance u) +              => u -> AbsPath u -> AbsPath u+roundInterior du pth0 = catTrailPath pt ctrail+  where+    (pt,ss) = segmentListL pth0+    ctrail  = roundInteriorCat du ss+++roundInteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u+roundInteriorCat _  []     = mempty+roundInteriorCat du (z:zs) = step mempty z zs+  where+    step ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) = +      let (x,k) = roundAB du v1 v2 in step (ac `mappend` x) k xs++    step ac prev            (x:xs)             = +       let tprev = segToCatTrail prev in step (ac `mappend` tprev) x xs++    step ac prev            []                 = ac `mappend` segToCatTrail prev++roundAB :: (Real u, Floating u) +        => u -> Vec2 u -> Vec2 u -> (CatTrail u, AbsPathSeg u)+roundAB du v1 v2 = +    (catline v1' `mappend` tcurve, lineSegmentV v2')+  where+    v1'      = shortenVec du v1+    v2'      = shortenVec du v2++    tv1      = avec (vdirection v1) du+    tv2      = avec (vdirection v2) du+    base_vec = tv1 ^+^ tv2+    bw       = vlength base_vec+    h        = sqrt $ pow2 du - (pow2 $ 0.5 * bw)+    tcurve   = tricurve bw (-h) (vdirection base_vec)+    +    -- note the (-h) in tricurve is wrong, we need to account +    -- for CCW or CW properly...++pow2 :: Num a => a -> a+pow2 x = x ^ (2::Int)++-- Form corners inside a /triangle/ Bezier.+++-- | Round a \"closed\" path. +--+-- Caution - all path sgements are expected to be longer than+-- 2x the round corner length, though this is not checked..+--+roundExterior :: (Real u, Floating u, Tolerance u) +              => u -> AbsPath u -> AbsPath u+roundExterior du pth0 +   | isBezierR pth0 || isBezierL pth0 = roundInterior du pth0+   | otherwise                        = catTrailPath pt ctrail+  where+   (pt,ss) = segmentListL pth0+   ctrail  = roundExteriorCat du ss+++roundExteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u+roundExteriorCat _  []                        = mempty++roundExteriorCat _  (AbsCurveSeg _ _ _ _ : _) = +    error "runExteriorCat - unreachable."++roundExteriorCat du (z@(AbsLineSeg _ v0):zs)  = step0 z zs+  where+    step0 (AbsLineSeg _ v1) xs = +      let seg0 = lineSegmentV $ shortenVec du v1 in step1 mempty seg0 xs++    step0 _                 _  = error "roundExteriorCat - unreachable 1."+    +    step1 ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) = +      let (x,k) = roundAB du v1 v2 in step1 (ac `mappend` x) k xs++    step1 ac prev              (x:xs)             = +      let tprev = segToCatTrail prev in step1 (ac `mappend` tprev) x xs++    step1 ac (AbsLineSeg _ v1) []                 = +      let (t,_) = roundAB du v1 v0 in ac `mappend` t++    step1 _  _                 []                 = +      error "roundExteriorCat - unreachable 2."++--------------------------------------------------------------------------------+-- Path division+++-- | Divide a path returning intermediate points and direction+--+-- Args are initial-prefix, division size, trailing size.+-- +-- Generation is stopped if the remainder of the path is shorter+-- than the trailing size.+--+pathdiv :: (Real u, Floating u) +        => u -> u -> u -> AbsPath u -> [(Point2 u, Radian)]+pathdiv ana sz end = step . shortenL ana +  where+    step pth | length pth < end = []+             | otherwise         = atstart pth : step (shortenL sz pth)+                          

@@ -1,852 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths.Base.AbsPath--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Absolute path type - this should be more amenable for building --- complex drawings than the PrimPath type in Wumpus-Core.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths.Base.AbsPath-  ( --  -- * Absolute path type-    AbsPath-  , DAbsPath---  -- * Construction-  , empty-  , line1-  , curve1-  , vertexPath-  , curvePath-  , controlCurve--  -- * Queries-  , null-  , length--  -- * Concat and extension-  , append-  , consLineTo-  , snocLineTo-  , consCurveTo-  , snocCurveTo--  , pathconcat--  -- * Conversion-  , toPrimPath--  , drawOpenPath-  , drawOpenPath_-  , drawClosedPath-  , drawClosedPath_--  -- * Shortening-  , shortenPath-  , shortenL-  , shortenR--  -- * Tips and direction-  , tipL-  , tipR-  , directionL-  , directionR--  -- * Path anchors-  , midway-  , midway_-  , atstart-  , atstart_-  , atend-  , atend_--  -- * Views-  , PathViewL(..)-  , DPathViewL-  , PathViewR(..)-  , DPathViewR-  , PathSegment(..)-  , DPathSegment-  , pathViewL-  , pathViewR--  , optimizeLines--  , roundTrail-  , roundInterior--  ) where----import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic-import Wumpus.Basic.Kernel-import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl-                                   , ViewR(..), viewr, cons, snoc, join )-import qualified Wumpus.Basic.Utils.JoinList as JL--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace--import Data.List ( foldl' ) -import qualified Data.Traversable as T--import Prelude hiding ( null, length )------- | Absolute path data type.--data AbsPath u = AbsPath -      { _abs_path_length   :: u -      , _abs_path_start    :: Point2 u-      , _abs_path_elements :: JoinList (AbsPathSeg u)-      , _abs_path_end      :: Point2 u-      }-  deriving (Eq,Show)--type instance DUnit (AbsPath u) = u---type DAbsPath = AbsPath Double---- Annotating each segment with length is \*\* good \*\*.--- Makes it much more efficient to find the midway point.------ But what do we do about the start point:------ a) put it in the segment - too much info in the type, allows --- consistency problems vis-a-vis gaps in the path.------ b) leave it out - too little info in the type, allows --- consistency problems with length.------ Option (a) is probably most convenient espcially as the --- constructors won\'t be exported.---- Annotation is length...--- -data AbsPathSeg u = AbsLineSeg  -                        { _abs_line_length  :: u -                        , _abs_line_start   :: Point2 u-                        , _abs_line_end     :: Point2 u-                        }-                  | AbsCurveSeg -                        { _abs_curve_length :: u -                        , _abs_curve_start  :: Point2 u-                        , _abs_ctrl_pt_one  :: Point2 u-                        , _abs_ctrl_pt_two  :: Point2 u-                        , _abs_curve_end    :: Point2 u-                        }-  deriving (Eq,Show)---type instance DUnit (AbsPathSeg u) = u-------------------------------------------------------------------------------------instance Functor AbsPath where-  fmap f (AbsPath u sp ls ep) = -      AbsPath (f u) (fmap f sp) (fmap (fmap f) ls) (fmap f ep)--instance Functor AbsPathSeg where-  fmap f (AbsLineSeg u p0 p1)        = -      AbsLineSeg (f u) (fmap f p0) (fmap f p1)  --  fmap f (AbsCurveSeg u p0 p1 p2 p3) = -      AbsCurveSeg (f u) (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3)--------------------------------------------------------------------------------------- TODO - must organize the Path datatype modules so they provide--- Containers-like API functions when appropriate.--------------------------------------------------------------------------------------- Construction---- | Create the empty path.--- --- Note - an absolute path needs /locating/ and cannot be built --- without a start point. Figuratively, the empty path is a path--- from the start point to the start point.------ Thus AbsPath operates as a semigroup but not a monoid.----empty :: Floating u => Point2 u -> AbsPath u-empty = zeroPath----- | Create an absolute path as a straight line between the --- supplied points.----line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u -line1 p0 p1 = AbsPath v p0 (JL.one $ AbsLineSeg v p0 p1) p1-  where-    v = vlength $ pvec p0 p1 ---- | Create an absolute path from a single cubic Bezier curve.----curve1 :: (Floating u, Ord u, Tolerance u)-      => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u -curve1 p0 p1 p2 p3 = AbsPath v p0 (JL.one $ AbsCurveSeg v p0 p1 p2 p3) p3-  where-    v = bezierLength (BezierCurve p0 p1 p2 p3)----- | 'vertexPath' throws a runtime error if the supplied list--- is empty. ----vertexPath :: (Floating u, Ord u, Tolerance u) -           => [Point2 u] -> AbsPath u-vertexPath []       = error "traceLinePoints - empty point list."-vertexPath [a]      = line1 a a-vertexPath (a:b:xs) = step (line1 a b) b xs-  where-    step acc _ []     = acc-    step acc e (y:ys) = step (acc `append` line1 e y) y ys------ | 'curvePath' consumes 4 points from the list on the --- intial step (start, control1, control2, end) then steps --- through the list taking 3 points at a time thereafter--- (control1,control2, end). Leftover points are discarded.    --- --- 'curvePath' throws a runtime error if the supplied list--- is has less than 4 elements (start, control1, control2, end). ----curvePath :: (Floating u, Ord u, Tolerance u) -          => [Point2 u] -> AbsPath u-curvePath (a:b:c:d:xs) = step (curve1 a b c d) d xs-  where-    step acc p0 (x:y:z:zs) = step (acc `append` curve1 p0 x y z) z zs-    step acc _  _          = acc--curvePath _            = error "curvePath - less than 4 elems."------ NOTE - need a proper arc path builder.------ | This is not an arc...--- -controlCurve :: (Floating u, Ord u, Tolerance u) -         => Point2 u -> Radian -> Radian -> Point2 u -> AbsPath u-controlCurve start cin cout end = -    curve1 start (start .+^ v1) (end .+^ v2) end-  where-    sz     = 0.375 * (vlength $ pvec start end)-    v1     = avec cin  sz-    v2     = avec cout sz-------------------------------------------------------------------------------------- Queries---- | Is the path empty?----null :: AbsPath u -> Bool-null = JL.null . _abs_path_elements---- | 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 :: Num u => AbsPath u -> u-length (AbsPath u _ _ _) = u-------------------------------------------------------------------------------------- Concat--infixr 1 `append`---- | Append two AbsPaths. --- --- If the end of the first path and the start of the second path--- coalesce then the paths are joined directly, otherwise, a--- straight line segment is added to join the paths.--- --- Neither path is /moved/. Consider 'RelPath' if you need --- different concatenation.----append :: (Floating u, Ord u, Tolerance u) -       => AbsPath u -> AbsPath u -> AbsPath u-append (AbsPath len1 start1 se1 end1) (AbsPath len2 start2 se2 end2) -    | end1 == start2 = AbsPath (len1+len2) start1 (se1 `join` se2) end2 -    | otherwise      = AbsPath total_len start1 segs end2 -  where-    joint     = lineSegment end1 start2-    total_len = len1 + len2 + segmentLength joint-    segs      = se1 `join` (cons joint se2)----- | Prefix the path with a straight line segment from the --- supplied point.----consLineTo :: Floating u => Point2 u -> AbsPath u -> AbsPath u-consLineTo p0 (AbsPath len1 sp se1 ep) = AbsPath (v+len1) p0 (cons s1 se1) ep-  where-    s1@(AbsLineSeg v _ _) = lineSegment p0 sp  ----- | Suffix the path with a straight line segment to the --- supplied point.----snocLineTo :: Floating u => AbsPath u -> Point2 u -> AbsPath u-snocLineTo (AbsPath len1 sp se1 ep) p1 = AbsPath (len1+v) sp (snoc se1 s1) p1-  where-    s1@(AbsLineSeg v _ _) = lineSegment ep p1----- | Prefix the path with a Bezier curve segment formed by the --- supplied points.----consCurveTo :: (Floating u, Ord u, Tolerance u)-            => Point2 u -> Point2 u -> Point2 u -> AbsPath u -> AbsPath u-consCurveTo p0 p1 p2 (AbsPath len1 sp se1 ep) = -    AbsPath (v+len1) p0 (cons s1 se1) ep-  where-    s1@(AbsCurveSeg v _ _ _ _) = curveSegment p0 p1 p2 sp----- | Suffix the path with a Bezier curve segment formed by the --- supplied points.----snocCurveTo :: (Floating u, Ord u, Tolerance u)-            => AbsPath u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u-snocCurveTo (AbsPath len1 sp se1 ep) p1 p2 p3 = -    AbsPath (v+len1) sp (snoc se1 s1) p3-  where-    s1@(AbsCurveSeg v _ _ _ _) = curveSegment ep p1 p2 p3- -- ---- | Concat the list of paths onto the intial path.--- --- Because a true empty path cannot be constructed (i.e. the--- /empty/ path needs a start point even if it has no segments) - --- the list is in /destructor form/. Client code has to decide --- how to handle the empty list case, e.g.:------ > case paths of--- >  (x:xs) -> Just $ pathconcat x xs--- >  []     -> Nothing------ -pathconcat :: (Floating u, Ord u, Tolerance u) -           => AbsPath u -> [AbsPath u] -> AbsPath u-pathconcat p0 ps = foldl' append p0 ps--segmentLength :: AbsPathSeg u -> u-segmentLength (AbsLineSeg u _ _)       = u-segmentLength (AbsCurveSeg u _ _ _ _)  = u---segmentStart :: AbsPathSeg u -> Point2 u-segmentStart (AbsLineSeg  _ p0 _)      = p0-segmentStart (AbsCurveSeg _ p0 _ _ _)  = p0--segmentEnd :: AbsPathSeg u -> Point2 u-segmentEnd (AbsLineSeg  _ _ p1)        = p1-segmentEnd (AbsCurveSeg _ _ _ _ p3)    = p3------- | Helper - construct a curve segment.--- -lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u -lineSegment p0 p1 = AbsLineSeg v p0 p1-  where-    v = vlength $ pvec p0 p1----- | Helper - construct a curve segment.--- -curveSegment :: (Floating u, Ord u, Tolerance u) -             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPathSeg u -curveSegment p0 p1 p2 p3 = AbsCurveSeg v p0 p1 p2 p3-  where-    v = bezierLength (BezierCurve p0 p1 p2 p3)----- | Helper - construct the /empty/ but located path.--- -zeroPath :: Floating u => Point2 u -> AbsPath u -zeroPath p0 = AbsPath 0 p0 JL.empty p0-   ----drawOpenPath :: InterpretUnit u -             => AbsPath u -> Image u (AbsPath u)-drawOpenPath rp = replaceAns rp $-    liftQuery (toPrimPath rp) >>= dcOpenPath---drawOpenPath_ :: InterpretUnit u -              => AbsPath u -> Graphic u-drawOpenPath_ rp = liftQuery (toPrimPath rp) >>= dcOpenPath---drawClosedPath :: InterpretUnit u -               => DrawStyle -> AbsPath u -> Image u (AbsPath u)-drawClosedPath sty rp = replaceAns rp $ -    liftQuery (toPrimPath rp) >>= dcClosedPath sty---drawClosedPath_ :: InterpretUnit u -                => DrawStyle -> AbsPath u -> Graphic u-drawClosedPath_ sty rp = liftQuery (toPrimPath rp) >>= dcClosedPath sty----- | Turn a Path into an ordinary PrimPath.------ Assumes path is properly formed - i.e. end point of one --- segment is the same point as the start point of the next--- segment.----toPrimPath :: InterpretUnit u => AbsPath u -> Query u PrimPath-toPrimPath (AbsPath _ start segs _) = -    uconvertCtxF start       >>= \dstart -> -    T.mapM uconvertCtxF segs >>= \dsegs  ->-    return $ step1 dstart (viewl dsegs)-  where-    step1 p0 EmptyL                   = emptyPrimPath p0-    step1 _  (e :< se)                = let (p0,a) = seg1 e-                                            rest   = step2 (viewl se)-                                        in absPrimPath p0 (a:rest)--    step2 EmptyL                      = []-    step2 (e :< se)                   = seg2 e : step2 (viewl se)-    -    seg1 (AbsLineSeg  _ p0 p1)        = (p0, absLineTo p1)-    seg1 (AbsCurveSeg _ p0 p1 p2 p3)  = (p0, absCurveTo p1 p2 p3)-    -    seg2 (AbsLineSeg  _ _ p1)         = absLineTo  p1-    seg2 (AbsCurveSeg _ _ p1 p2 p3)   = absCurveTo p1 p2 p3--------- | 'sortenPath' : @ left_dist * right_dist * path -> Path @----shortenPath :: (Real u , Floating u) -            => u  -> u -> AbsPath u -> AbsPath u-shortenPath l r = shortenL l .  shortenR r -------------------------------------------------------------------------------------- shorten from the left...---- | Note - shortening a line from the left by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the end point.----shortenL :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u-shortenL n (AbsPath u _ segs ep) -    | n >= u                  = line1 ep ep-    | otherwise               = step n (viewl segs)-  where-    step _ EmptyL     = line1 ep ep      -- should be unreachable-    step d (e :< se)  = let z  = segmentLength e in-                        case compare d z of-                          GT -> step (d-z) (viewl se)-                          EQ -> makeLeftPath (u-n) se ep-                          LT -> let e1 = shortenSegL d e-                                    sp = segmentStart e1-                                in AbsPath (u-n) sp (e1 `cons` se) ep---makeLeftPath :: Floating u -             => u -> JoinList (AbsPathSeg u) -> Point2 u -> AbsPath u-makeLeftPath u se ep = -    case viewl se of-      EmptyL   -> line1 ep ep-      (e :< _) -> AbsPath u (segmentStart e) se ep---shortenSegL :: (Real u, Floating u) -            => u -> AbsPathSeg u -> AbsPathSeg u-shortenSegL n (AbsLineSeg  u p0 p1)        = -    AbsLineSeg  (u-n) (shortenLineL n p0 p1) p1--shortenSegL n (AbsCurveSeg u p0 p1 p2 p3)  = -    AbsCurveSeg (u-n) q0 q1 q2 q3-  where-    (BezierCurve q0 q1 q2 q3) = snd $ subdividet (n/u) -                                                 (BezierCurve p0 p1 p2 p3)-     ---shortenLineL :: (Real u, Floating u) -             => u -> Point2 u -> Point2 u -> Point2 u-shortenLineL n p0 p1 = p0 .+^ v-  where-    v0 = p1 .-. p0-    v  = avec (vdirection v0) n--------------------------------------------------------------------------------------- shorten from the right ...- --- | Note - shortening a line from the right by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the start point.----shortenR :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u-shortenR n (AbsPath u sp segs _) -    | n >= u                  = line1 sp sp-    | otherwise               = step n (viewr segs)-  where-    step _ EmptyR     = line1 sp sp      -- should be unreachable-    step d (se :> e)  = let z = segmentLength e in-                        case compare d z of-                          GT -> step (d-z) (viewr se)-                          EQ -> makeRightPath n sp se-                          LT -> let e1 = shortenSegR d e-                                    ep = segmentEnd e1-                                in AbsPath (u-n) sp (se `snoc` e1) ep-                         --makeRightPath :: Floating u -              => u -> Point2 u -> JoinList (AbsPathSeg u) -> AbsPath u-makeRightPath u sp se = -    case viewr se of-      EmptyR   -> line1 sp sp-      (_ :> e) -> AbsPath u sp se (segmentEnd e)----shortenSegR :: (Real u, Floating u) -            => u -> AbsPathSeg u -> AbsPathSeg u-shortenSegR n (AbsLineSeg  u p0 p1)        = -    AbsLineSeg  (u-n) p0 (shortenLineR n p0 p1) --shortenSegR n (AbsCurveSeg u p0 p1 p2 p3)  = AbsCurveSeg (u-n) q0 q1 q2 q3-  where-    (BezierCurve q0 q1 q2 q3) = fst $ subdividet ((u-n)/u) -                                                 (BezierCurve p0 p1 p2 p3)-     ---shortenLineR :: (Real u, Floating u) -             => u -> Point2 u -> Point2 u -> Point2 u-shortenLineR n p0 p1 = p1 .+^ v-  where-    v0 = p0 .-. p1-    v  = avec (vdirection v0) n--------------------------------------------------------------------------------------- tips --tipL :: AbsPath u -> Point2 u-tipL (AbsPath _ sp _ _) = sp---tipR :: AbsPath u -> Point2 u-tipR (AbsPath _ _ _ ep) = ep-------------------------------------------------------------------------------------- line direction---- | Direction of empty path is considered to be 0.----directionL :: (Real u, Floating u) => AbsPath u -> Radian-directionL (AbsPath _ _ se _)  = step $ viewl se-  where-    step (AbsLineSeg  _ p0 p1 :< _)      = lineDirection p1 p0  -- 1-to-0-    step (AbsCurveSeg _ p0 p1 _ _ :< _)  = lineDirection p1 p0-    step _                               = 0       -- should be unreachable----- | Direction of empty path is considered to be 0.----directionR :: (Real u, Floating u) => AbsPath u -> Radian-directionR (AbsPath _ _ se _) = step $ viewr se-  where-    step (_ :> AbsLineSeg  _ p0 p1)      = lineDirection p0 p1-    step (_ :> AbsCurveSeg _ _  _ p2 p3) = lineDirection p2 p3-    step _                               = 0       -- should be unreachable             - ----------------------------------------------------------------------------------------- Return direction as well because the calculation is expensive...----midway :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)-midway pa@(AbsPath u sp _ _) -    | u == 0    = (sp,0)-    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1)---- Just the midway point.----midway_ :: (Real u, Floating u) => AbsPath u -> Point2 u-midway_ = fst . midway---atstart :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)-atstart pa@(AbsPath _ sp _ _) = (sp, directionL pa)--atstart_ :: AbsPath u -> Point2 u-atstart_ (AbsPath _ sp _ _) = sp---atend :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)-atend pa@(AbsPath _ _ _ ep) = (ep, directionR pa)- --atend_ :: AbsPath u -> Point2 u-atend_ (AbsPath _ _ _ ep) = ep----- nearstart, nearend, verynear ...-------------------------------------------------------------------------------------infixr 5 :<<-infixl 5 :>>--data PathViewL u = PathOneL (PathSegment u)-                 | PathSegment u :<< AbsPath u-  deriving (Eq,Show) --type DPathViewL = PathViewL Double--data PathViewR u = PathOneR (PathSegment u)-                 | AbsPath u :>> PathSegment u-  deriving (Eq,Show) --type DPathViewR = PathViewR Double---data PathSegment u = LineSeg  (Point2 u) (Point2 u)-                   | CurveSeg (Point2 u) (Point2 u) (Point2 u) (Point2 u)-  deriving (Eq,Show) --type DPathSegment = PathSegment Double-------------------------------------------------------------------------------------instance Functor PathSegment where-  fmap f (LineSeg p0 p1)        = LineSeg (fmap f p0) (fmap f p1)-  fmap f (CurveSeg p0 p1 p2 p3) = -      CurveSeg (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3)--instance Functor PathViewL where-  fmap f (PathOneL a) = PathOneL (fmap f a)-  fmap f (a :<< as)   = fmap f a :<< fmap f as--instance Functor PathViewR where-  fmap f (PathOneR a) = PathOneR (fmap f a)-  fmap f (as :>> a)   = fmap f as :>> fmap f a--------------------------------------------------------------------------------------pathViewL :: Num u => AbsPath u -> PathViewL u-pathViewL (AbsPath u _ segs ep) = go (viewl segs)-  where-    go EmptyL           = error "pathViewL - (not) unreachable."-     -    go (AbsLineSeg v p0 p1 :< se)-        | JL.null se    = PathOneL (LineSeg p0 p1)-        | otherwise     = LineSeg p0 p1 :<< AbsPath (u-v) p1 se ep--    go (AbsCurveSeg v p0 p1 p2 p3 :< se) -        | JL.null se    = PathOneL (CurveSeg p0 p1 p2 p3)-        | otherwise     = CurveSeg p0 p1 p2 p3 :<< AbsPath (u-v) p3 se ep---pathViewR :: Num u => AbsPath u -> PathViewR u-pathViewR (AbsPath u _ segs ep) = go (viewr segs)-  where-    go EmptyR                   = error "pathViewR - (not) unreachable."--    go (se :> AbsLineSeg v p0 p1) -        | JL.null se    = PathOneR (LineSeg p0 p1)-        | otherwise     = AbsPath (u-v) p1 se ep :>> LineSeg p0 p1--    go (se :> AbsCurveSeg v p0 p1 p2 p3) -        | JL.null se    = PathOneR (CurveSeg p0 p1 p2 p3)-        | otherwise     = AbsPath (u-v) p3 se ep :>> CurveSeg p0 p1 p2 p3----------------------------------------------------------------------------------------- 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---- NOTE - round corners are probably better suited to construction --- rather than transformation.--- --- The code below is pencilled in to change.--------- | The length of the control-point vector wants to be slighly --- longer than half of /d/ (d - being the distance between the --- /truncated/ points and the corner).----cornerCurve :: (Real u, Floating u, Tolerance u) -            => Point2 u -> Point2 u -> Point2 u -> AbsPath u-cornerCurve p1 p2 p3 = curve1 p1 cp1 cp2 p3-  where-    len1 = 0.6 *  (vlength $ pvec p1 p2)-    len2 = 0.6 *  (vlength $ pvec p3 p2)-    cp1  = p1 .+^ (avec (lineAngle p1 p2) len1)-    cp2  = p3 .+^ (avec (lineAngle p3 p2) len2)----- | 'roundTrail' : @ rounding_distance * [point] -> Path @------ Build a path from the list of vertices, all the interior --- corners are rounded by the rounding distance \*and\* final --- round corner is created \"incorporating\" the start point (as --- the start point becomes a rounded corner the actual path will --- not intersect it). --- --- It is expected that this function will be used to create round --- cornered shapes.--- --- 'roundTrail' throws a runtime error if the input list is empty. --- If the list has one element /the null path/ is built, if the --- list has two elements a straight line is built.----roundTrail :: (Real u, Floating u, Tolerance u) -           => u -> [Point2 u] -> AbsPath u -roundTrail _ []             = error "roundTrail - empty list."-roundTrail _ [a]            = zeroPath a-roundTrail _ [a,b]          = line1 a b-roundTrail u (start:b:c:xs) = step (lineCurveTrail u start b c) (b:c:xs)-  where-    step acc (m:n:o:ps)     = step (acc `append` lineCurveTrail u m n o) (n:o:ps)-    step acc [n,o]          = acc `append` lineCurveTrail u n o start-                                  `append` lineCurveTrail u o start b -    step acc _              = acc------ | Two parts - line and corner curve...------ Note - the starting point is moved, this function is for --- closed, rounded paths.----lineCurveTrail :: (Real u, Floating u, Tolerance u) -               => u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u-lineCurveTrail u a b c = line1 p1 p2 `append` cornerCurve p2 b p3-  where-    p1 = a .+^ (avec (vdirection $ pvec a b) u)-    p2 = b .+^ (avec (vdirection $ pvec b a) u)-    p3 = b .+^ (avec (vdirection $ pvec b c) u)----- | 'roundInterior' : @ rounding_distance * [point] -> Path @------ Build a path from the list of vertices, all the interior --- corners are rounded by the rounding distance. Unlike --- 'roundTrail' there is no /loop around/ to the start point,--- and start path will begin exactly on the start point and end --- exactly on the end point. --- --- 'roundInterior' throws a runtime error if the input list is --- empty. If the list has one element /the null path/ is built, --- if the list has two elements a straight line is built.----roundInterior :: (Real u, Floating u, Tolerance u) -              => u -> [Point2 u] -> AbsPath u -roundInterior _ []             = error "roundEveryInterior - empty list."-roundInterior _ [a]            = zeroPath a-roundInterior _ [a,b]          = line1 a b-roundInterior u (start:b:c:xs) = let (path1,p1) = lineCurveInter1 u start b c-                                 in step path1 (p1:c:xs)-  where-    step acc (m:n:o:ps)     = let (seg2,p1) = lineCurveInter1 u m n o-                              in step (acc `append` seg2) (p1:o:ps)-    step acc [n,o]          = acc `append` line1 n o-    step acc _              = acc------ | Two parts - line and corner curve...------ Note - draws a straight line from the starting point - this is --- the first step of an interior (non-closed) rounded path----lineCurveInter1 :: (Real u, Floating u, Tolerance u) -                => u -> Point2 u -> Point2 u -> Point2 u -                -> (AbsPath u, Point2 u)-lineCurveInter1 u a b c = -    (line1 a p2 `append` cornerCurve p2 b p3, p3)-  where-    p2 = b .+^ (avec (vdirection $ pvec b a) u)-    p3 = b .+^ (avec (vdirection $ pvec b c) u)- 

@@ -1,465 +0,0 @@-{-# 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-  ( ---    GenPathSpec-  , PathSpec-  , Vamp(..)-  , PathTerm(..)--  , runGenPathSpec-  , execGenPathSpec-  , evalGenPathSpec-  , stripGenPathSpec--  , runPathSpec-  , runPathSpec_--  , runPivot---  , penline-  , pencurve- -  -  , breakPath-  , hpenline-  , vpenline-  , apenline--  , penlines-  , pathmoves--  , vamp-  , cycleSubPath-  , localPen- -  ) where--import Wumpus.Drawing.Paths.Base.RelPath---import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core---import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace--import Control.Applicative-import Control.Monad-import Data.Monoid-import Prelude hiding ( null, cycle, lines )---newtype GenPathSpec st u a = GenPathSpec-          { getGenPathSpec :: DrawingContext -> DPoint2 -> PathSt st-                           -> (a, DPoint2, PathSt st, PathW) }--type instance DUnit   (GenPathSpec st u a) = u-type instance UState  (GenPathSpec st u)   = st--type PathSpec u a = GenPathSpec () u a---data PathSt st = PathSt-      { st_active_pen :: ActivePen-      , st_user_state :: st-      }----- | Note - this formulation doesn\'t support monoidal append.--- --- Information gets lost for this one (we really would want to --- draw the left-hand-side):------ > PEN_DOWN _ _ `mappend` PEN_UP------ So it has to be part of the state not the writer.--- -data ActivePen = PEN_UP -               | PEN_DOWN { ap_start_point  :: Point2 Double-                          , ap_rel_path     :: RelPath Double -                          }---zeroActivePath :: DPoint2 -> ActivePen-zeroActivePath pt = PEN_DOWN pt mempty---data PathW = PathW -      { w_rel_path :: RelPath Double-      , w_trace    :: CatPrim-      }---instance Monoid PathW where-  mempty = PathW mempty mempty-  PathW a0 b0 `mappend` PathW a1 b1 = PathW (a0 `mappend` a1) (b0 `mappend` b1)----data PathTerm = PATH_OPEN | PATH_CLOSED DrawStyle-  deriving (Eq,Show)---data Vamp u = Vamp-       { vamp_move :: Vec2 u-       , vamp_conn :: ConnectorGraphic u-       }--type instance DUnit (Vamp u) = u-------------------------------------------------------------------------------------- Instances----- Functor--instance Functor (GenPathSpec st u) where-  fmap f ma = GenPathSpec $ \ctx pt s -> -                let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s -                in (f a,p1,s1,w1)----- Applicative--instance Applicative (GenPathSpec st u) where-  pure a    = GenPathSpec $ \_   pt s -> (a, pt, s, mempty)-  mf <*> ma = GenPathSpec $ \ctx pt s -> -                let (f,p1,s1,w1) = getGenPathSpec mf ctx pt s-                    (a,p2,s2,w2) = getGenPathSpec ma ctx p1 s1-                in (f a, p2, s2, w1 `mappend` w2)----- Monad--instance Monad (GenPathSpec st u) where-  return a  = GenPathSpec $ \_   pt s -> (a, pt, s, mempty)-  ma >>= k  = GenPathSpec $ \ctx pt s -> -                let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s-                    (b,p2,s2,w2) = (getGenPathSpec . k) a ctx p1 s1-                in (b, p2, s2, w1 `mappend` w2)---instance Monoid a => Monoid (GenPathSpec st u a) where-  mempty           = GenPathSpec $ \_   pt s -> (mempty, pt, s, mempty)-  ma `mappend` mb  = GenPathSpec $ \ctx pt s -> -                       let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s-                           (b,p2,s2,w2) = getGenPathSpec mb ctx p1 s1-                       in (a `mappend` b, p2, s2, w1 `mappend` w2)---- DrawingCtxM--instance DrawingCtxM (GenPathSpec st u) where-  askDC           = GenPathSpec $ \ctx pt s -> (ctx, pt, s, mempty)-  asksDC f        = GenPathSpec $ \ctx pt s -> (f ctx, pt, s, mempty)-  localize upd ma = GenPathSpec $ \ctx pt s -> -                      getGenPathSpec ma (upd ctx) pt s----- UserStateM --instance UserStateM (GenPathSpec st u) where-  getState        = GenPathSpec $ \_ pt s -> -                      (st_user_state s, pt, s, mempty)-  setState ust    = GenPathSpec $ \_ pt s -> -                      ((), pt, s {st_user_state = ust} , mempty)-  updateState upd = GenPathSpec $ \_ pt s -> -                      let ust = st_user_state s-                      in ((), pt, s {st_user_state =  upd ust}, mempty)------ LocationM--instance InterpretUnit u => LocationM (GenPathSpec st u) where-  location = locationImpl----- CursorM --instance InterpretUnit u => CursorM (GenPathSpec st u) where-  moveby   = movebyImpl----- InsertlM--instance InterpretUnit u => InsertlM (GenPathSpec st u) where-  insertl  = insertlImpl--           ------------------------------------------------------------------------------------ Run functions--runGenPathSpec :: InterpretUnit u -               => GenPathSpec st u a -> st -> PathTerm -               -> LocImage u (a, st, RelPath u)-runGenPathSpec ma st term = promoteLoc $ \pt -> -    askDC >>= \ctx ->-    let dpt       = normalizeF (dc_font_size ctx) pt-        st_zero   = PathSt (zeroActivePath dpt) st-        (a,_,s,w) = getGenPathSpec ma ctx dpt st_zero-        upath     = dinterpF (dc_font_size ctx) $ w_rel_path w-        (_,wcp)   = runImage (drawActivePen term $ st_active_pen s) ctx-        wfinal    = w_trace w `mappend` wcp-    in replaceAns (a, st_user_state s, upath) $ primGraphic wfinal----- Note - eval and exec return the RelPath this is as-per RWS--- which returns @w@ for execRWS (s,w) and evalRWS (a,w)-----evalGenPathSpec :: InterpretUnit u-                => GenPathSpec st u a -> st -> PathTerm -                -> LocImage u (a, RelPath u)-evalGenPathSpec ma st term = -    (\(a,_,w) -> (a,w)) <$> runGenPathSpec ma st term--    --execGenPathSpec :: InterpretUnit u-                => GenPathSpec st u a -> st -> PathTerm -                -> LocImage u (st, RelPath u)-execGenPathSpec ma st term =-    (\(_,s,w) -> (s,w)) <$> runGenPathSpec ma st term----stripGenPathSpec :: InterpretUnit u-                 => GenPathSpec st u a -> st -> PathTerm -                 -> LocQuery u (a, st, RelPath u)-stripGenPathSpec ma st term = stripLocImage $ runGenPathSpec ma st term---runPathSpec :: InterpretUnit u-            => PathSpec u a -> PathTerm -> LocImage u (a, RelPath u)-runPathSpec ma term = evalGenPathSpec ma () term--runPathSpec_ :: InterpretUnit u-             => PathSpec u a -> PathTerm -> LocGraphic u-runPathSpec_ ma term = ignoreAns $ evalGenPathSpec ma () term------ Monad run function nomenclature:------ > run  - both--- > eval - answer (no state)--- > exec - state (no answer)--- --- Note RWS always returns the @w@.------ For Wumpus:--- --- > run  - monadic answer, and the writer /construction/--- > eval - just the monadic answer--- > exec - just the writer /construction/.------ In all case the CatPrim inside the LocImage may contain --- additional graphics.------ Client code can use @ignoreAns@ to generate a @LocGraphic@--- from the @LocImage@.----- | Helper.----drawActivePen :: PathTerm -> ActivePen -> DGraphic -drawActivePen _    PEN_UP                            = mempty-drawActivePen term (PEN_DOWN { ap_start_point = pt-                             , ap_rel_path    = rp}) = case term of-    PATH_OPEN -> ignoreAns $ drawOpenPath rp `at` pt-    PATH_CLOSED styl -> ignoreAns $ drawClosedPath styl rp `at` pt----------- | Form a \"pivot path\" drawing from two path specifications.--- The start point of the drawing is the pivot formed by joining--- the paths.----runPivot :: (Floating u, InterpretUnit u)-          => PathSpec u a -> PathSpec u a -> LocGraphic u-runPivot ma mb = promoteLoc $ \pt -> -    askDC >>= \ctx ->-    let dpt         = normalizeF (dc_font_size ctx) pt-        st_zero     = PathSt (zeroActivePath dpt) ()-        (p1,_,s,w1) = getGenPathSpec mz ctx dpt st_zero-        dp1         = normalizeF (dc_font_size ctx) p1-        v1          = pvec dpt dp1-        (_,wcp)     = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx-        wfinal      = w_trace w1 `mappend` wcp        -    in primGraphic $ cpmove (negateV v1) wfinal-  where-    mz = ma >> location >>= \pt -> mb >> return pt-------------------------------------------------------------------------------------- operations---locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u)-locationImpl = GenPathSpec $ \ctx pt s ->-    let upt = dinterpF (dc_font_size ctx) pt-    in (upt, pt, s, mempty)----- | @extendPen@ causes a pendown.----extendPen :: DPoint2 -> DVec2 -> ActivePen -> ActivePen-extendPen pt v PEN_UP           = PEN_DOWN pt (line1 v)-extendPen _  v (PEN_DOWN p0 rp) = PEN_DOWN p0 (rp `snocLineTo` v)------- NOTE - /lineto/ needs a new name as the @to@ suffix suggests--- moving to a point, whereas the movement is @by@ a vector.------ @relline@ not a good candidate, need a name that supports --- horizontal (h) and vertical (v) versions.-------- | Extend the path with a line, drawn by the pen.--- -penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()-penline v1 = GenPathSpec $ \ctx pt s -> -   let sz  = dc_font_size ctx-       dv1 = normalizeF sz v1-       pen = extendPen pt dv1 (st_active_pen s)-       w1  = PathW { w_rel_path = line1 dv1, w_trace = mempty }-   in ((), pt .+^ dv1, s { st_active_pen = pen }, w1)------ | @extendPenC@ causes a pendown.----extendPenC :: DPoint2 -> DVec2 -> DVec2 -> DVec2 -> ActivePen -> ActivePen-extendPenC pt v1 v2 v3 PEN_UP           = PEN_DOWN pt (curve1 v1 v2 v3)-extendPenC _  v1 v2 v3 (PEN_DOWN p0 rp) = PEN_DOWN p0 (snocCurveTo rp v1 v2 v3)------ | Extend the path with a curve, drawn by the pen.--- -pencurve :: InterpretUnit u -        => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u ()-pencurve v1 v2 v3 = GenPathSpec $ \ctx pt s -> -   let sz  = dc_font_size ctx-       dv1 = normalizeF sz v1-       dv2 = normalizeF sz v2-       dv3 = normalizeF sz v3-       pen = extendPenC pt dv1 dv2 dv3 (st_active_pen s)-       w1  = PathW { w_rel_path = line1 dv1, w_trace = mempty }-   in ((), pt .+^ dv1, s { st_active_pen = pen }, w1)----- | @moveby@ causes a pen up.----movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()-movebyImpl v1 = GenPathSpec $ \ctx pt s -> -    let sz      = dc_font_size ctx-        dv1     = normalizeF sz v1-        (_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx-        w1      = PathW { w_rel_path = mempty, w_trace = wcp }-    in ((), pt .+^ dv1, s { st_active_pen = PEN_UP }, w1)---breakPath :: InterpretUnit u => GenPathSpec st u ()-breakPath = movebyImpl (V2 0 0)--hpenline :: InterpretUnit u => u -> GenPathSpec st u ()-hpenline dx = penline (hvec dx)--vpenline :: InterpretUnit u => u -> GenPathSpec st u ()-vpenline dy = penline (vvec dy)---apenline :: (Floating u, InterpretUnit u) -         => Radian -> u -> GenPathSpec st u ()-apenline ang d = penline (avec ang d)--penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()-penlines = mapM_ penline--pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()-pathmoves = mapM_ moveby----insertlImpl :: InterpretUnit u -            => LocImage u a -> GenPathSpec st u a-insertlImpl gf = GenPathSpec $ \ctx pt s ->-    let upt     = dinterpF (dc_font_size ctx) pt-        (a,wcp) = runLocImage gf ctx upt-        w1      = PathW { w_rel_path = mempty, w_trace = wcp }-    in (a, pt, s, w1)----vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u ()-vamp (Vamp v1 conn) = GenPathSpec $ \ctx pt s ->-    let sz      = dc_font_size ctx-        dv1     = normalizeF sz v1-        (_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx-        upt     = dinterpF sz pt-        (_,ccp) = runConnectorImage conn ctx upt (upt .+^ v1)-        w1      = PathW { w_rel_path = mempty, w_trace = wcp `mappend` ccp }-    in ((), pt .+^ dv1, s { st_active_pen = PEN_UP }, w1)---cycleSubPath :: DrawStyle -> GenPathSpec st u ()-cycleSubPath styl = GenPathSpec $ \ctx pt s ->-    let gf      = drawActivePen (PATH_CLOSED styl) $ st_active_pen s-        (_,wcp) = runImage gf ctx-        w1      = PathW { w_rel_path = mempty, w_trace = wcp }-    in ((), pt, s { st_active_pen = PEN_UP }, w1)----- Design note ------ Should pen changing be @local@ style vis the Reader monad or a --- state change with the State monad?--- --- @local@ is more idiomatic within the context of Wumpus (and --- easier to implement), but @state change@ is probably more --- natural for Path building.--- --- For the time being we go with local.------localPen :: DrawingContextF -> GenPathSpec st u a -> GenPathSpec st u a-localPen upd ma = GenPathSpec $ \ctx pt s ->-    let (_,wcp)      = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx-        (a,p1,s1,w1) = getGenPathSpec ma (upd ctx) pt s-        w2           = let wcp2 = wcp `mappend` w_trace w1 -                       in w1 { w_trace = wcp2 }-    in (a, p1, s1 { st_active_pen = PEN_UP }, w2)-

@@ -1,363 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths.Base.RelPath--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Relative path type - this should be more amenable for building --- complex drawings than the PrimPath type in Wumpus-Core.--- --- Note - RelPath is not directly equivalent to AbsPath.--- AbsPath is more powerful - as it is expected to have more --- demanding use-cases (e.g. connector paths).--------------------------------------------------------------------------------------module Wumpus.Drawing.Paths.Base.RelPath-  ( ---  -- * Relative path type--    RelPath-  , DRelPath--  -- * Construction-  , empty-  , line1-  , curve1-  , vertexPath-  , curvedPath-  -  , circular--  -- * Queries-  , null-  , length--  -- * Concat-  , append-  , consLineTo-  , snocLineTo-  , consCurveTo-  , snocCurveTo---  -- * Conversion-  , fromPathAlgVertices-  , fromPathAlgCurves--  , toPrimPath-  , toAbsPath--  , drawOpenPath-  , drawOpenPath_-  , drawClosedPath-  , drawClosedPath_--  ) where---import Wumpus.Drawing.Paths.Base.AbsPath ( AbsPath )-import qualified Wumpus.Drawing.Paths.Base.AbsPath as Abs--import Wumpus.Basic.Geometry-import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl, join )-import qualified Wumpus.Basic.Utils.JoinList as JL--import Wumpus.Core                              -- package: wumpus-core---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, length )-------- | Relative Path data type.--- --- Note this type is more limited than AbsPath, it does not--- support /introspective/ operations like @length@ or anchors.----data RelPath u = RelPath -      { rel_path_len    :: u-      , rel_path_segs   :: JoinList (RelPathSeg u) }-  deriving (Eq,Show)--type instance DUnit (RelPath u) = u---type DRelPath = RelPath Double---- No annotations...--- -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)---type instance DUnit (RelPathSeg u) = u--------------------------------------------------------------------------------------instance Functor RelPath where-  fmap f (RelPath len xs) = RelPath (f len) (fmap (fmap f) xs)--instance Functor RelPathSeg where-  fmap f (RelLineSeg len v1)        = -      RelLineSeg (f len) (fmap f v1)--  fmap f (RelCurveSeg len v1 v2 v3) = -      RelCurveSeg (f len) (fmap f v1) (fmap f v2) (fmap f v3)---instance Num u => Monoid (RelPath u) where-  mempty  = empty-  mappend = append-------------------------------------------------------------------------------------- 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 :: Num u => RelPath u -empty = RelPath { rel_path_len = 0, rel_path_segs = mempty }---- | Create a relative path from a single straight line.----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 :: 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 :: Floating u => [Vec2 u] -> RelPath u-vertexPath [] = empty-vertexPath (x:xs) = go (line1 x) xs-  where-    go acc []     = acc-    go acc (v:vs) = go (acc `snocLineTo` v) vs----curvedPath :: Floating u => [Vec2 u] -> RelPath u-curvedPath xs = case xs of -    (v1:v2:v3:vs) -> go (curve1 v1 v2 v3) vs-    _             -> empty-  where-    go acc (v1:v2:v3:vs) = go (acc `append` curve1 v1 v2 v3) vs-    go acc _             = acc----circular :: Floating u => u -> RelPath u-circular = snd . fromPathAlgCurves . circlePathAlg ------------------------------------------------------------------------------------- Queries--null :: RelPath u -> Bool-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-------------------------------------------------------------------------------------- Concat --infixr 1 `append`----append :: Num u => RelPath u -> RelPath u -> RelPath u-append (RelPath la ssa) (RelPath lb ssb) = RelPath (la + lb)  $ ssa `join` ssb---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 :: 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 :: (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 :: (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----------------------------------------------------------------------------------------- Conversion--fromPathAlgVertices :: Floating u => PathAlg u -> (Vec2 u, RelPath u)-fromPathAlgVertices = step . runPathAlgVec-  where-    step (Nothing, xs) = (zeroVec, vertexPath xs)-    step (Just v1, xs) = (v1, vertexPath xs)--fromPathAlgCurves :: Floating u => PathAlg u -> (Vec2 u, RelPath u)-fromPathAlgCurves = step . runPathAlgVec-  where-    step (Nothing, xs) = (zeroVec, curvedPath xs)-    step (Just v1, xs) = (v1, curvedPath xs)---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----toAbsPath :: (Floating u, Ord u, Tolerance u) -          => Point2 u -> RelPath u -> AbsPath u-toAbsPath start (RelPath _ segs) = step1 start $ viewl segs-  where-    step1 p0 EmptyL                           = Abs.empty p0--    step1 p0 (RelLineSeg _ v1 :< se)            = -        let (pth,end) = aline p0 v1 in step2 end pth (viewl 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)        = -        let (s1,end) = aline p0 v1 -        in step2 end (acc `Abs.append` s1) (viewl 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)--    aline p0 v1                               = -        let p1 = p0 .+^ v1 in (Abs.line1 p0 p1, p1)--    acurve p0 v1 v2 v3                        = -        let p1 = p0 .+^ v1-            p2 = p1 .+^ v2-            p3 = p2 .+^ v3-        in (Abs.curve1 p0 p1 p2 p3, p3)----drawOpenPath :: InterpretUnit u -             => RelPath u -> LocImage u (RelPath u)-drawOpenPath rp = replaceAns rp $-    promoteLoc $ \start -> liftQuery (toPrimPath start rp) >>= dcOpenPath--drawOpenPath_ :: InterpretUnit u -              => RelPath u -> LocGraphic u-drawOpenPath_ rp = promoteLoc $ \start -> -    liftQuery (toPrimPath start rp) >>= dcOpenPath---drawClosedPath :: InterpretUnit u -               => DrawStyle -> RelPath u -> LocImage u (RelPath u)-drawClosedPath sty rp = replaceAns rp $ -    promoteLoc $ \start -> liftQuery (toPrimPath start rp) >>= dcClosedPath sty--drawClosedPath_ :: InterpretUnit u -                => DrawStyle -> RelPath u -> LocGraphic u-drawClosedPath_ sty rp = promoteLoc $ \start -> -    liftQuery (toPrimPath start rp) >>= dcClosedPath sty-

@@ -0,0 +1,470 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.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.PathBuilder+  ( +++    GenPathSpec+  , PathSpec+  , Vamp(..)+++  , runGenPathSpec+  , execGenPathSpec+  , evalGenPathSpec+  , stripGenPathSpec++  , runPathSpec+  , runPathSpec_++  , runPivot+++  , penline+  , pencurve+ +  +  , breakPath+  , hpenline+  , vpenline+  , apenline++  , penlines+  , pathmoves++  , vamp+  , cycleSubPath+  , updatePen+ +  ) where++import Wumpus.Drawing.Paths.Base++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Control.Applicative+import Control.Monad+import Data.Monoid+import Prelude hiding ( null, cycle, lines )++-- +-- TODO - possibly we need two drawing contexts one for the pen +-- and one for the decoration trace.+-- +-- Alternatively PathSt should have a local DrawingContext for the +-- pen.+--+++-- | Note - a path spec has an immutable start point like +-- @LocDrawing@.+--+-- Effectively a path is draw in a local coordinate system with +-- @(0,0)@ as the origin.+--+newtype GenPathSpec st u a = GenPathSpec { +    getGenPathSpec :: DrawingContext -> PathSt st -> (a, PathSt st, CatPrim) }++type instance DUnit   (GenPathSpec st u a) = u+type instance UState  (GenPathSpec st u)   = st++type PathSpec u a = GenPathSpec () u a+++data PathSt st = PathSt+      { st_active_pen       :: ActivePen+      , st_pen_ctx          :: DrawingContext+      , st_cumulative_path  :: AbsPath Double+      , st_user_state       :: st+      }+++-- | Note - this formulation doesn\'t support monoidal append.+-- +-- Information gets lost for this one (we really would want to +-- draw the left-hand-side):+--+-- > PEN_DOWN _ _ `mappend` PEN_UP+--+-- So it has to be part of the state not the writer.+-- +data ActivePen = PEN_UP +               | PEN_DOWN (AbsPath Double)+                         +++zeroActivePen :: DPoint2 -> ActivePen+zeroActivePen pt = PEN_DOWN (emptyPath pt)+++data Vamp u = Vamp+       { vamp_move :: Vec2 u+       , vamp_conn :: ConnectorGraphic u+       }++type instance DUnit (Vamp u) = u+++--------------------------------------------------------------------------------+-- Instances+++-- Functor++instance Functor (GenPathSpec st u) where+  fmap f ma = GenPathSpec $ \ctx s -> +                let (a,s1,w1) = getGenPathSpec ma ctx s +                in (f a,s1,w1)+++-- Applicative++instance Applicative (GenPathSpec st u) where+  pure a    = GenPathSpec $ \_   s -> (a, s, mempty)+  mf <*> ma = GenPathSpec $ \ctx s -> +                let (f,s1,w1) = getGenPathSpec mf ctx s+                    (a,s2,w2) = getGenPathSpec ma ctx s1+                in (f a, s2, w1 `mappend` w2)+++-- Monad++instance Monad (GenPathSpec st u) where+  return a  = GenPathSpec $ \_   s -> (a, s, mempty)+  ma >>= k  = GenPathSpec $ \ctx s -> +                let (a,s1,w1) = getGenPathSpec ma ctx s+                    (b,s2,w2) = (getGenPathSpec . k) a ctx s1+                in (b, s2, w1 `mappend` w2)+++-- Monoid ++instance Monoid a => Monoid (GenPathSpec st u a) where+  mempty           = GenPathSpec $ \_   s -> (mempty, s, mempty)+  ma `mappend` mb  = GenPathSpec $ \ctx s -> +                       let (a,s1,w1) = getGenPathSpec ma ctx s+                           (b,s2,w2) = getGenPathSpec mb ctx s1+                       in (a `mappend` b, s2, w1 `mappend` w2)+++-- DrawingCtxM++instance DrawingCtxM (GenPathSpec st u) where+  askDC           = GenPathSpec $ \ctx s -> (ctx, s, mempty)+  asksDC f        = GenPathSpec $ \ctx s -> (f ctx, s, mempty)+  localize upd ma = GenPathSpec $ \ctx s -> +                      getGenPathSpec ma (upd ctx) s+++-- UserStateM ++instance UserStateM (GenPathSpec st u) where+  getState        = GenPathSpec $ \_ s -> +                      (st_user_state s, s, mempty)+  setState ust    = GenPathSpec $ \_ s -> +                      ((), s {st_user_state = ust} , mempty)+  updateState upd = GenPathSpec $ \_ s -> +                      let ust = st_user_state s+                      in ((), s {st_user_state =  upd ust}, mempty)++++-- Note - all these need to peek at the cumulative path++-- LocationM++instance InterpretUnit u => LocationM (GenPathSpec st u) where+  location = locationImpl+++-- CursorM ++instance InterpretUnit u => CursorM (GenPathSpec st u) where+  moveby   = movebyImpl+++-- InsertlM++instance InterpretUnit u => InsertlM (GenPathSpec st u) where+  insertl  = insertlImpl+++           +--------------------------------------------------------------------------------+-- Run functions++runGenPathSpec :: InterpretUnit u +               => st -> PathMode -> GenPathSpec st u a +               -> LocImage u (a, st, AbsPath u)+runGenPathSpec st mode ma = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let P2 dx dy  = normalizeF (dc_font_size ctx) pt+        st_zero   = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) st+        (a,s1,w1) = getGenPathSpec ma ctx st_zero+        dpath     = translate dx dy $ st_cumulative_path s1+        upath     = dinterpF (dc_font_size ctx) dpath+        pctx      = st_pen_ctx s1+        (_,w2)    = runImage pctx (drawActivePen mode $ st_active_pen s1) +        wfinal    = cpmove (V2 dx dy) $ w1 `mappend` w2+    in replaceAns (a, st_user_state s1, upath) $ primGraphic wfinal+++-- Note - eval and exec return the AbsPath this is as-per RWS+-- which returns @w@ for execRWS (s,w) and evalRWS (a,w)+--++evalGenPathSpec :: InterpretUnit u+                => st -> PathMode -> GenPathSpec st u a+                -> LocImage u (a, AbsPath u)+evalGenPathSpec st mode ma = +    (\(a,_,w) -> (a,w)) <$> runGenPathSpec st mode ma++    ++execGenPathSpec :: InterpretUnit u+                => st -> PathMode -> GenPathSpec st u a+                -> LocImage u (st, AbsPath u)+execGenPathSpec st mode ma =+    (\(_,s,w) -> (s,w)) <$> runGenPathSpec st mode ma++++stripGenPathSpec :: InterpretUnit u+                 => st -> PathMode -> GenPathSpec st u a+                 -> LocQuery u (a, st, AbsPath u)+stripGenPathSpec st mode ma = stripLocImage $ runGenPathSpec st mode ma+++runPathSpec :: InterpretUnit u+            => PathMode -> PathSpec u a -> LocImage u (a, AbsPath u)+runPathSpec mode ma = evalGenPathSpec () mode ma++runPathSpec_ :: InterpretUnit u+             => PathMode -> PathSpec u a -> LocGraphic u+runPathSpec_ mode ma = ignoreAns $ evalGenPathSpec () mode ma++++-- Monad run function nomenclature:+--+-- > run  - both+-- > eval - answer (no state)+-- > exec - state (no answer)+-- +-- Note RWS always returns the @w@.+--+-- For Wumpus:+-- +-- > run  - monadic answer, and the writer /construction/+-- > eval - just the monadic answer+-- > exec - just the writer /construction/.+--+-- In all case the CatPrim inside the LocImage may contain +-- additional graphics.+--+-- Client code can use @ignoreAns@ to generate a @LocGraphic@+-- from the @LocImage@.++++-- | Helper.+--+drawActivePen :: PathMode -> ActivePen -> DGraphic +drawActivePen _    PEN_UP              = mempty+drawActivePen mode (PEN_DOWN abs_path) = drawPath_ mode abs_path++++++++-- | Form a \"pivot path\" drawing from two path specifications.+-- The start point of the drawing is the pivot formed by joining+-- the paths.+--+runPivot :: (Floating u, InterpretUnit u)+          => PathSpec u a -> PathSpec u a -> LocGraphic u+runPivot ma mb = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let dpt        = normalizeF (dc_font_size ctx) pt+        st_zero    = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) ()+        (p1,s1,w1) = getGenPathSpec mz ctx st_zero+        dp1        = normalizeF (dc_font_size ctx) p1+        v1         = pvec dpt dp1+        pctx       = st_pen_ctx s1+        (_,w2)     = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s1+        wfinal     = w1 `mappend` w2+    in primGraphic $ cpmove (negateV v1) wfinal+  where+    mz = ma >> location >>= \pt -> mb >> return pt+++--------------------------------------------------------------------------------+-- operations+++locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u)+locationImpl = GenPathSpec $ \ctx s ->+    let pt  = tipR $ st_cumulative_path s +        upt = dinterpF (dc_font_size ctx) pt+    in (upt, s, mempty)+++-- | 'extendPaths' extends both the @cumulative_path@ and the +-- @active_pen@. If the pen is up it, changes to a pendown.+--+extendPaths :: DVec2 -> PathSt st -> PathSt st+extendPaths v1 s@(PathSt { st_cumulative_path = cp+                         , st_active_pen      = pen} )  = +    s { st_cumulative_path = snocLine cp v1, st_active_pen = upd pen }+  where+    upd PEN_UP          = let pt = tipR cp in PEN_DOWN $ line1 pt (pt .+^ v1)+    upd (PEN_DOWN absp) = PEN_DOWN $ snocLine absp v1+++++-- | Extend the path with a line, drawn by the pen.+-- +penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()+penline v1 = GenPathSpec $ \ctx s -> +   let sz  = dc_font_size ctx+       dv1 = normalizeF sz v1+   in ((), extendPaths dv1 s, mempty)++++-- | @extendPenC@ causes a pendown.+--+extendPathsC :: DVec2 -> DVec2 -> DVec2 -> PathSt st -> PathSt st+extendPathsC v1 v2 v3 s@(PathSt { st_cumulative_path = cp+                                , st_active_pen      = pen} )  = +    s { st_cumulative_path = snocCurve cp (v1,v2,v3), st_active_pen = upd pen }+  where+    upd PEN_UP          = let p0 = tipR cp +                              p1 = p0 .+^ v1+                              p2 = p1 .+^ v2+                              p3 = p2 .+^ v3+                          in PEN_DOWN $ curve1 p0 p1 p2 p3+    upd (PEN_DOWN absp) = PEN_DOWN $ snocCurve absp (v1,v2,v3)++++-- | Extend the path with a curve, drawn by the pen.+-- +pencurve :: InterpretUnit u +        => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u ()+pencurve v1 v2 v3 = GenPathSpec $ \ctx s -> +   let sz  = dc_font_size ctx+       dv1 = normalizeF sz v1+       dv2 = normalizeF sz v2+       dv3 = normalizeF sz v3+   in ((), extendPathsC dv1 dv2 dv3 s, mempty)+++-- | @moveby@ causes a pen up.+--+movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()+movebyImpl v1 = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) ->+    let sz      = dc_font_size ctx+        dv1     = normalizeF sz v1+        (_,w1)  = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s+        cpath   = snocLine (st_cumulative_path s) dv1+    in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }, w1)+++breakPath :: InterpretUnit u => GenPathSpec st u ()+breakPath = movebyImpl (V2 0 0)++hpenline :: InterpretUnit u => u -> GenPathSpec st u ()+hpenline dx = penline (hvec dx)++vpenline :: InterpretUnit u => u -> GenPathSpec st u ()+vpenline dy = penline (vvec dy)+++apenline :: (Floating u, InterpretUnit u) +         => Radian -> u -> GenPathSpec st u ()+apenline ang d = penline (avec ang d)++penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()+penlines = mapM_ penline++pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()+pathmoves = mapM_ moveby++++insertlImpl :: InterpretUnit u +            => LocImage u a -> GenPathSpec st u a+insertlImpl gf = GenPathSpec $ \ctx s ->+    let upt     = dinterpF (dc_font_size ctx) (tipR $ st_cumulative_path s)+        (a,wcp) = runLocImage ctx upt gf+    in (a, s, wcp)++++vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u ()+vamp (Vamp v1 conn) = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) ->+    let sz     = dc_font_size ctx+        dv1    = normalizeF sz v1+        (_,w1) = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s+        upt    = dinterpF sz (tipR $ st_cumulative_path s)+        (_,w2) = runConnectorImage ctx upt (upt .+^ v1) conn+        cpath  = snocLine (st_cumulative_path s) dv1+    in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }+          , w1 `mappend` w2)+++cycleSubPath :: DrawMode -> GenPathSpec st u ()+cycleSubPath mode = GenPathSpec $ \_ s@(PathSt {st_pen_ctx = pctx}) ->+    let (_,w1) = runImage pctx $ drawActivePen (fn mode) (st_active_pen s)+    in ((), s { st_active_pen = PEN_UP }, w1)+  where+    fn DRAW_STROKE      = CSTROKE+    fn DRAW_FILL        = CFILL+    fn DRAW_FILL_STROKE = CFILL_STROKE++++-- Design note +--+-- Should pen changing be @local@ style vis the Reader monad or a +-- state change with the State monad?+-- +-- Now switched to state change.+--+++-- | Note - updates the pen but doesn\'t draw, the final path+-- will be drawing with the last updated context.+--+updatePen :: DrawingContextF -> GenPathSpec st u ()+updatePen upd = GenPathSpec $ \_ s@(PathSt { st_pen_ctx = pctx})  ->+    ((), s { st_pen_ctx = upd pctx}, mempty )+

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

@@ -22,20 +22,19 @@    ) where -import Wumpus.Drawing.Paths.Base.PathBuilder ( Vamp(..) )-import Wumpus.Drawing.Paths.Base.AbsPath+import Wumpus.Drawing.Paths.PathBuilder ( Vamp(..) )+import Wumpus.Drawing.Paths.Base  import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core  - -- TODO - library of useful / illustrative vamps (circle, square etc.)   --- Note - actual square TODO...+--  -- squareWE :: (Real u, Floating  u, Ord u, Tolerance u, InterpretUnit u)           => u -> Vamp u@@ -43,10 +42,12 @@                      , vamp_conn = conn }   where     conn = promoteConn $ \p1 p2 -> -           -- TODO ...-           drawClosedPath_ STROKE $ vertexPath $ [ p1, p2 ]+             let dir = vdirection $ pvec p1 p2+             in drawPath_ CSTROKE $ vectorPathTheta path1 dir p1 -     -- vertexPath [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ]+    hdiam = 0.5 * diam +    path1 = [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ]   -- Drawing a cirle picks the half point on the vamp_move vector...+

@@ -46,7 +46,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths  import Wumpus.Basic.Kernel                      -- package: wumpus-basic @@ -119,7 +119,7 @@   strokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-strokedShape = shapeToLoc (dcClosedPath STROKE)+strokedShape = shapeToLoc (dcClosedPath DRAW_STROKE)   -- | Note - this is simplistic double stroking - draw a background @@ -134,7 +134,7 @@ dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) dblStrokedShape sh = sdecorate back fore    where-    img  = shapeToLoc (dcClosedPath STROKE) sh+    img  = shapeToLoc (dcClosedPath DRAW_STROKE) sh     back = getLineWidth >>= \lw ->            localize (set_line_width $ lw * 3.0) img     fore = ignoreAns $ localize (stroke_colour white) img@@ -142,11 +142,11 @@   filledShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-filledShape = shapeToLoc (dcClosedPath FILL)+filledShape = shapeToLoc (dcClosedPath DRAW_FILL)   borderedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-borderedShape = shapeToLoc (dcClosedPath FILL_STROKE)+borderedShape = shapeToLoc (dcClosedPath DRAW_FILL_STROKE)   shapeToLoc :: InterpretUnit u@@ -160,15 +160,15 @@   rstrokedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)-rstrokedShape = shapeToLocTheta (dcClosedPath STROKE)+rstrokedShape = shapeToLocTheta (dcClosedPath DRAW_STROKE)   rfilledShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)-rfilledShape = shapeToLocTheta (dcClosedPath FILL)+rfilledShape = shapeToLocTheta (dcClosedPath DRAW_FILL)   rborderedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)-rborderedShape = shapeToLocTheta (dcClosedPath FILL_STROKE)+rborderedShape = shapeToLocTheta (dcClosedPath DRAW_FILL_STROKE)   shapeToLocTheta :: InterpretUnit u@@ -186,7 +186,8 @@ roundCornerShapePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)                      => u -> [Point2 u] -> Query u (AbsPath u) roundCornerShapePath sz xs = -    if sz `tEQ` 0 then return (vertexPath xs) else return (roundTrail  sz xs)+    if sz `tEQ` 0 then return (vertexPath xs) +                  else return (roundExterior sz $ vertexPath xs)  -- | The path angle can be modified. This allows /inverse/  -- versions of shapes (e.g. InvTriangle) to be made by

@@ -24,7 +24,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Kernel                      -- package: wumpus-basic

@@ -25,12 +25,11 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic import Wumpus.Basic.Geometry.Quadrant-import Wumpus.Basic.Geometry.Paths import Wumpus.Basic.Kernel        import Wumpus.Core                              -- package: wumpus-core@@ -155,8 +154,8 @@ mkDiamondPath :: (Real u, Floating u, InterpretUnit u, Tolerance u)               => u -> u -> u -> LocThetaQuery u (AbsPath u) mkDiamondPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> -    let ps = runPathAlgPoint ctr $ diamondPathAlg hw hh-    in roundCornerShapePath rnd $ map (rotateAbout theta ctr) ps+    qapplyLoc (placedTrailPoints $ diamondTrail hw hh) ctr >>= \ps ->+    roundCornerShapePath rnd $ map (rotateAbout theta ctr) ps   

@@ -27,7 +27,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Kernel                      -- package: wumpus-basic

@@ -27,7 +27,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Geometry                    -- package: wumpus-basic

@@ -27,7 +27,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Geometry                    -- package: wumpus-basic

@@ -24,7 +24,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic

@@ -24,7 +24,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic

@@ -25,7 +25,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Geometry                    -- package: wumpus-basic

@@ -24,7 +24,7 @@    ) where -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base  import Wumpus.Basic.Geometry                    -- package: wumpus-basic

@@ -21,10 +21,11 @@ module Wumpus.Drawing.Text.Base.DocTextZero   (  --    Doc +    GenDoc+  , Doc +  , GenDocGraphic   , DocGraphic-  , runDoc+  , runGenDoc    , (<+>)   , blank@@ -58,14 +59,25 @@ import Data.Monoid import Numeric -+--+-- Design Issue:+--+-- Can user state be added to Doc?+--+-- Easy if PosObject had user state, difficult as it doesn\'t...+--   -- | Doc type. ---newtype Doc u a = Doc { getDoc :: DocEnv -> PosObject u a } +newtype GenDoc st u a = GenDoc { getGenDoc :: DocEnv -> GenPosObject st u a }  -type instance DUnit (Doc u a) = u+type instance DUnit  (GenDoc st u a) = u+type instance UState (GenDoc st u)   = st +type GenDocGraphic st u = GenDoc st u (UNil u)++type Doc u a = GenDoc () u a+ type DocGraphic u = Doc u (UNil u)  @@ -74,33 +86,37 @@       , doc_font_family :: FontFamily       } -instance Functor (Doc u) where-  fmap f ma = Doc $ \env -> fmap f $ getDoc ma env+instance Functor (GenDoc st u) where+  fmap f ma = GenDoc $ \env -> fmap f $ getGenDoc ma env -instance Applicative (Doc u) where-  pure a    = Doc $ \_   -> pure a-  mf <*> ma = Doc $ \env -> getDoc mf env <*> getDoc ma env+instance Applicative (GenDoc st u) where+  pure a    = GenDoc $ \_   -> pure a+  mf <*> ma = GenDoc $ \env -> getGenDoc mf env <*> getGenDoc ma env  -instance Monad (Doc u) where-  return a  = Doc $ \_   -> return a-  ma >>= k  = Doc $ \env -> getDoc ma env >>= \a -> getDoc (k a) env+instance Monad (GenDoc st u) where+  return a  = GenDoc $ \_   -> return a+  ma >>= k  = GenDoc $ \env -> getGenDoc ma env >>= \a -> getGenDoc (k a) env +instance (Monoid a, InterpretUnit u) => Monoid (GenDoc st u a) where+  mempty          = GenDoc $ \_   -> mempty+  ma `mappend` mb = GenDoc $ \env -> getGenDoc ma env `hconcat` getGenDoc mb env  -instance DrawingCtxM (Doc u) where-  askDC           = Doc $ \_   -> askDC -  asksDC fn       = Doc $ \_   -> asksDC fn-  localize upd ma = Doc $ \env -> localize upd (getDoc ma env)+instance DrawingCtxM (GenDoc st u) where+  askDC           = GenDoc $ \_   -> askDC +  asksDC fn       = GenDoc $ \_   -> asksDC fn+  localize upd ma = GenDoc $ \env -> localize upd (getGenDoc ma env) -instance (Monoid a, InterpretUnit u) => Monoid (Doc u a) where-  mempty = Doc $ \_ -> mempty-  ma `mappend` mb = Doc $ \env -> getDoc ma env `hconcat` getDoc mb env +instance UserStateM (GenDoc st u) where+  getState        = GenDoc $ \_ -> getState+  setState s      = GenDoc $ \_ -> setState s+  updateState upd = GenDoc $ \_ -> updateState upd  -runDoc :: Doc u a -> VAlign -> FontFamily -> PosObject u a-runDoc ma va ff = getDoc ma env1 +runGenDoc :: VAlign -> FontFamily -> GenDoc st u a -> GenPosObject st u a+runGenDoc va ff ma = getGenDoc ma env1    where     env1 = DocEnv { doc_alignment = va, doc_font_family = ff } @@ -109,16 +125,17 @@ -------------------------------------------------------------------------------- -- Get vcat vconcat... from the Concat class -instance (Monoid a, Fractional u, InterpretUnit u) => Concat (Doc u a) where+instance (Monoid a, Fractional u, InterpretUnit u) => +    Concat (GenDoc st u a) where   hconcat = mappend   vconcat = vcatImpl  vcatImpl        :: (Monoid a, Fractional u, InterpretUnit u) -                => Doc u a -> Doc u a -> Doc u a-vcatImpl ma mb  = Doc $ \env -> +                => GenDoc st u a -> GenDoc st u a -> GenDoc st u a+vcatImpl ma mb  = GenDoc $ \env ->      let va = doc_alignment env      in textlineSpace >>= \sep -> -       valignSpace va sep (getDoc ma env) (getDoc mb env)+       valignSpace va sep (getGenDoc ma env) (getGenDoc mb env)  -------------------------------------------------------------------------------- -- Primitives@@ -129,67 +146,69 @@ -- -- (infixr 6) ---(<+>) :: InterpretUnit u => DocGraphic u -> DocGraphic u -> DocGraphic u+(<+>) :: InterpretUnit u +      => GenDocGraphic st u -> GenDocGraphic st u -> GenDocGraphic st u a <+> b = a `mappend` space `mappend` b    -blank     :: InterpretUnit u => DocGraphic u-blank     = Doc $ \_ -> posTextPrim (Left "")+blank     :: InterpretUnit u => GenDocGraphic st u+blank     = GenDoc $ \_ -> posTextPrim (Left "") -space     :: InterpretUnit u => DocGraphic u-space     = Doc $ \_ -> posCharPrim (Left ' ')+space     :: InterpretUnit u => GenDocGraphic st u+space     = GenDoc $ \_ -> posCharPrim (Left ' ')  -string    :: InterpretUnit u => String -> DocGraphic u-string ss = Doc $ \_ -> posTextPrim (Left ss)+string    :: InterpretUnit u => String -> GenDocGraphic st u+string ss = GenDoc $ \_ -> posTextPrim (Left ss)   -escaped     :: InterpretUnit u => EscapedText -> DocGraphic u-escaped esc = Doc $ \_ -> posTextPrim (Right esc)+escaped     :: InterpretUnit u => EscapedText -> GenDocGraphic st u+escaped esc = GenDoc $ \_ -> posTextPrim (Right esc) -embedPosObject :: PosObject u a -> Doc u a-embedPosObject ma = Doc $ \_ -> ma+embedPosObject :: GenPosObject st u a -> GenDoc st u a+embedPosObject ma = GenDoc $ \_ -> ma    -------------------------------------------------------------------------------- -- Change font weight -bold :: Doc u a -> Doc u a -bold ma = Doc $ \env -> +bold :: GenDoc st u a -> GenDoc st u a +bold ma = GenDoc $ \env ->      localize (set_font $ boldWeight $ doc_font_family env)-             (getDoc ma env)+             (getGenDoc ma env)  -italic :: Doc u a -> Doc u a -italic ma = Doc $ \env -> +italic :: GenDoc st u a -> GenDoc st u a +italic ma = GenDoc $ \env ->      localize (set_font $ italicWeight $ doc_font_family env)-             (getDoc ma env)+             (getGenDoc ma env)  -boldItalic :: Doc u a -> Doc u a -boldItalic ma = Doc $ \env -> +boldItalic :: GenDoc st u a -> GenDoc st u a +boldItalic ma = GenDoc $ \env ->      localize (set_font $ boldItalicWeight $ doc_font_family env)-             (getDoc ma env)+             (getGenDoc ma env)   -------------------------------------------------------------------------------- -- Monospace -monospace :: InterpretUnit u => EscapedChar -> EscapedText -> DocGraphic u-monospace ref_ch esc = Doc $ \_ -> +monospace :: InterpretUnit u +          => EscapedChar -> EscapedText -> GenDocGraphic st u+monospace ref_ch esc = GenDoc $ \_ ->      monospaceEscText (vector_x <$> escCharVector ref_ch) esc    -int :: InterpretUnit u => Int -> DocGraphic u+int :: InterpretUnit u => Int -> GenDocGraphic st u int i = integer $ fromIntegral i  -integer :: InterpretUnit u => Integer -> DocGraphic u+integer :: InterpretUnit u => Integer -> GenDocGraphic st u integer i = monospace (CharLiteral '0') (escapeString $ show i)  @@ -200,7 +219,7 @@ -- | Specialized version of 'ffloat' - the answer is always  -- rendered at \"full precision\". ---float :: (RealFloat a, InterpretUnit u) => a -> DocGraphic u+float :: (RealFloat a, InterpretUnit u) => a -> GenDocGraphic st u float = ffloat Nothing  @@ -209,7 +228,8 @@ -- Like 'showFFloat', the answer is rendered to supplied  -- precision. @Nothing@ indicated full precision. ---ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> DocGraphic u+ffloat :: (RealFloat a, InterpretUnit u) +       => (Maybe Int) -> a -> GenDocGraphic st u ffloat mb d =      monospace (CharLiteral '0') $ escapeString  $ ($ "") $ showFFloat mb d @@ -222,23 +242,24 @@ -- Decorate  strikethrough :: (Fractional u, InterpretUnit u) -              => Doc u a -> Doc u a+              => GenDoc st u a -> GenDoc st u a strikethrough = decorateDoc SUPERIOR drawStrikethrough   underline :: (Fractional u, InterpretUnit u) -          => Doc u a -> Doc u a+          => GenDoc st u a -> GenDoc st u a underline = decorateDoc SUPERIOR drawUnderline  highlight :: (Fractional u, InterpretUnit u) -          => RGBi -> Doc u a -> Doc u a+          => RGBi -> GenDoc st u a -> GenDoc st u a highlight rgb = decorateDoc ANTERIOR (drawBackfill rgb)      decorateDoc :: InterpretUnit u -            => ZDeco -> (Orientation u -> LocGraphic u) -> Doc u a -> Doc u a-decorateDoc zdec fn ma = Doc $ \env -> -    decoratePosObject zdec fn $ getDoc ma env+            => ZDeco -> (Orientation u -> LocGraphic u) -> GenDoc st u a +            -> GenDoc st u a+decorateDoc zdec fn ma = GenDoc $ \env -> +    decoratePosObject zdec fn $ getGenDoc ma env              @@ -289,5 +310,5 @@     mkVec  dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy)     mkRect dx dy = let w = dx + xmin + xmaj + dx                        h = dy + ymin + ymaj + dy-                   in dcRectangle FILL w h+                   in dcRectangle DRAW_FILL w h 

@@ -42,7 +42,7 @@   ) where  -import Wumpus.Drawing.Paths.Absolute+import Wumpus.Drawing.Paths  import Wumpus.Basic.Kernel                      -- package: wumpus-basic 

@@ -35,19 +35,19 @@ -- Also, reversed argument order would be more convenient as  -- RectAddress always short but String could be long.  ---textline :: InterpretUnit u => String -> RectAddress -> BoundedLocGraphic u-textline ss addr = runPosObjectBBox (posText ss) addr+textline :: InterpretUnit u => RectAddress -> String -> BoundedLocGraphic u+textline addr ss = runPosObjectBBox addr (posText ss)   -- | Note - this is likely to be moved too... -- rtextline :: (Real u, Floating u, InterpretUnit u)-          => Radian -> String -> RectAddress -> BoundedLocGraphic u-rtextline ang ss addr = runPosObjectBBox (rposText ang ss) addr+          => Radian -> RectAddress -> String -> BoundedLocGraphic u+rtextline ang addr ss = runPosObjectBBox addr (rposText ang ss)   multilineText :: (Fractional u, InterpretUnit u)-              => VAlign -> String -> RectAddress -> BoundedLocGraphic u-multilineText va ss addr = runPosObjectBBox (multilinePosText va ss) addr+              => VAlign -> RectAddress -> String -> BoundedLocGraphic u+multilineText va addr ss = runPosObjectBBox addr (multilinePosText va ss)  

@@ -0,0 +1,78 @@+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Text.DocSymbols+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Symbols - redefined Basis.Symbols.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Text.DocSymbols+  (++    ocircle+  , small_ocircle++  , empty_box++  , left_slice+  , right_slice++  )+  where++import qualified Wumpus.Drawing.Basis.Symbols as S+import Wumpus.Drawing.Text.Base.DocTextZero+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++-- import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+++ocircle :: (Fractional u, InterpretUnit u) => GenDocGraphic st u+ocircle = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hh = 0.5 * h in Orientation hh hh 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.5 * h) (S.ocircle $ 0.5 * h)++++small_ocircle :: (Fractional u, InterpretUnit u) => GenDocGraphic st u+small_ocircle = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hw = 0.33 * h in Orientation hw hw 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.ocircle $ 0.25 * h)++empty_box :: (Fractional u, InterpretUnit u) => GenDocGraphic st u+empty_box = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hw = 0.5 * h in Orientation hw hw 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.empty_box $ 0.66 * h)++++left_slice :: (Real u, Floating u, InterpretUnit u) => GenDocGraphic st u+left_slice = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hw = 0.66 * h in Orientation hw hw 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.left_slice h)++right_slice :: (Real u, Floating u, InterpretUnit u) => GenDocGraphic st u+right_slice = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hw = 0.66 * h in Orientation hw hw 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.right_slice h)++-- More to follow...+

@@ -23,7 +23,7 @@  -- | Version number ----- > (0,6,0)+-- > (0,7,0) -- wumpus_drawing_version :: (Int,Int,Int)-wumpus_drawing_version = (0,6,0)+wumpus_drawing_version = (0,7,0)

@@ -1,5 +1,5 @@ name:             wumpus-drawing-version:          0.6.0+version:          0.7.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -38,9 +38,24 @@   .   Changelog:   .+  v0.6.0 to v0.7.0+  .+  * Changed paths - @RelPath@ has been removed and there are now +    only absolute paths. @PathBuilder@ builds absolute paths.+    Pen updating in @PathBuilder@ now works like a State monad +    rather than @local@ in a Reader monad.+  .+  * Changed argument order of the run functions to @monadLib@ +    style (params * monadic action) rather than @MTL@ style +    (monadic action * params).+  .+  * Added Symbols to Drawing.Basis.+  .+  * Added a tube box connector.+  .   v0.5.0 to v0.6.0   .-  * Removed @LocTRace@ and @RefTrace@ from @Wumpus.Drawing.Basis@,+  * Removed @LocTrace@ and @RefTrace@ from @Wumpus.Drawing.Basis@,     they are superseded by @LocDrawing@ in Wumpus-Basic.   .    * Remaned path building operations in @RelPathBuilder@.@@ -75,12 +90,13 @@   build-depends:      base            <  5,                        containers      >= 0.3     && <= 0.6,                       vector-space    >= 0.6     && <  1.0,-                      wumpus-core     >= 0.51.0  && <  0.52.0,-                      wumpus-basic    == 0.21.0+                      wumpus-core     >= 0.52.0  && <  0.53.0,+                      wumpus-basic    == 0.22.0       exposed-modules:     Wumpus.Drawing.Basis.DrawingPrimitives,+    Wumpus.Drawing.Basis.Symbols,     Wumpus.Drawing.Colour.SVGColours,     Wumpus.Drawing.Colour.X11Colours,     Wumpus.Drawing.Connectors,@@ -88,17 +104,16 @@     Wumpus.Drawing.Connectors.Base,     Wumpus.Drawing.Connectors.BoxConnectors,     Wumpus.Drawing.Connectors.ConnectorPaths,+    Wumpus.Drawing.Connectors.ConnectorProps,     Wumpus.Drawing.Dots.AnchorDots,     Wumpus.Drawing.Dots.SimpleDots,     Wumpus.Drawing.Extras.Axes,     Wumpus.Drawing.Extras.Clip,     Wumpus.Drawing.Extras.Grids,     Wumpus.Drawing.Extras.Loop,-    Wumpus.Drawing.Paths.Absolute,-    Wumpus.Drawing.Paths.Base.AbsPath,-    Wumpus.Drawing.Paths.Base.PathBuilder,-    Wumpus.Drawing.Paths.Base.RelPath,-    Wumpus.Drawing.Paths.Relative,+    Wumpus.Drawing.Paths,+    Wumpus.Drawing.Paths.Base,+    Wumpus.Drawing.Paths.PathBuilder,     Wumpus.Drawing.Paths.Vamps,     Wumpus.Drawing.Shapes,     Wumpus.Drawing.Shapes.Base,@@ -117,6 +132,7 @@     Wumpus.Drawing.Text.Base.DocTextZero,     Wumpus.Drawing.Text.Base.Label,     Wumpus.Drawing.Text.DirectionZero,+    Wumpus.Drawing.Text.DocSymbols,     Wumpus.Drawing.Text.StandardFontDefs,     Wumpus.Drawing.VersionNumber