wumpus-drawing 0.7.0 → 0.9.0

raw patch · 50 files changed

+2855/−1493 lines, 50 filesdep ~wumpus-basicPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic

API changes (from Hackage documentation)

Files

• demo/ArrowCircuit.hs +29/−16
• demo/Arrowheads.hs +8/−7
• demo/Automata.hs +11/−9
• demo/ClipPic.hs +1/−1
• demo/ColourCharts.hs +2/−2
• demo/Connectors.hs +49/−32
• demo/DotPic.hs +2/−2
• demo/FeatureModel.hs +9/−9
• demo/FontPic.hs +1/−1
• demo/PetriNet.hs +28/−17
• demo/SampleShapes.hs +10/−12
• demo/Symbols.hs +22/−9
• src/Wumpus/Drawing/Basis/BezierCurve.hs +137/−0
• src/Wumpus/Drawing/Basis/DrawingPrimitives.hs +6/−39
• src/Wumpus/Drawing/Basis/Geometry.hs +51/−0
• src/Wumpus/Drawing/Basis/InclineTrails.hs +499/−0
• src/Wumpus/Drawing/Basis/ShapeTrails.hs +213/−0
• src/Wumpus/Drawing/Basis/Symbols.hs +256/−52
• src/Wumpus/Drawing/Connectors.hs +0/−2
• src/Wumpus/Drawing/Connectors/Arrowheads.hs +129/−166
• src/Wumpus/Drawing/Connectors/Base.hs +96/−121
• src/Wumpus/Drawing/Connectors/BoxConnectors.hs +57/−52
• src/Wumpus/Drawing/Connectors/ConnectorPaths.hs +272/−354
• src/Wumpus/Drawing/Connectors/ConnectorProps.hs +10/−0
• src/Wumpus/Drawing/Dots/AnchorDots.hs +27/−36
• src/Wumpus/Drawing/Dots/SimpleDots.hs +12/−15
• src/Wumpus/Drawing/Extras/Axes.hs +13/−12
• src/Wumpus/Drawing/Extras/Loop.hs +24/−26
• src/Wumpus/Drawing/Paths/Base.hs +171/−35
• src/Wumpus/Drawing/Paths/Illustrate.hs +61/−0
• src/Wumpus/Drawing/Paths/Intersection.hs +318/−0
• src/Wumpus/Drawing/Paths/PathBuilder.hs +10/−10
• src/Wumpus/Drawing/Paths/Vamps.hs +1/−1
• src/Wumpus/Drawing/Shapes/Base.hs +7/−3
• src/Wumpus/Drawing/Shapes/Diamond.hs +18/−13
• src/Wumpus/Drawing/Shapes/Ellipse.hs +3/−3
• src/Wumpus/Drawing/Shapes/InvSemicircle.hs +2/−2
• src/Wumpus/Drawing/Shapes/InvSemiellipse.hs +3/−3
• src/Wumpus/Drawing/Shapes/InvTriangle.hs +4/−4
• src/Wumpus/Drawing/Shapes/Parallelogram.hs +55/−50
• src/Wumpus/Drawing/Shapes/Rectangle.hs +13/−13
• src/Wumpus/Drawing/Shapes/Semicircle.hs +33/−99
• src/Wumpus/Drawing/Shapes/Semiellipse.hs +29/−122
• src/Wumpus/Drawing/Shapes/Trapezium.hs +72/−55
• src/Wumpus/Drawing/Shapes/Triangle.hs +42/−70
• src/Wumpus/Drawing/Text/Base/DocTextZero.hs +5/−5
• src/Wumpus/Drawing/Text/Base/Label.hs +2/−2
• src/Wumpus/Drawing/Text/DocSymbols.hs +4/−4
• src/Wumpus/Drawing/VersionNumber.hs +3/−3
• wumpus-drawing.cabal +25/−4

@@ -65,12 +65,12 @@     atext a3 "+1"     a4 <- drawi $ (strokedShape $ rectangle 66 30) `at` P2 120 0     atext a4 "DELAY 0"-    connWith connline (east a1) ((.+^ hvec 76) $ east a1)-    connWith connline (east a2) ((.+^ hvec 180) $ east a2)-    connWith connline ((.+^ vvec 40) $ north a2) (north a2)-    connWith connline ((.+^ vvec 16) $ north a3) (north a3)  -    connWith connaright  (south a3) (east a4)-    connWith connabar (west a4)  (southwest a2)+    connWith conn_line (east a1) ((.+^ hvec 76) $ east a1)+    connWith conn_line (east a2) ((.+^ hvec 180) $ east a2)+    connWith conn_line ((.+^ vvec 40) $ north a2) (north a2)+    connWith conn_line ((.+^ vvec 16) $ north a3) (north a3)  +    connWith conna_right  (south a3) (east a4)+    connWith conna_orthovbar    (west a4)  (southwest a2)     ptext (P2  40  10) "next"     ptext (P2 152 100) "reset"     ptext (P2 252  72) "output"@@ -79,9 +79,9 @@     -- Note - need a variant of /bar/ that draws UDLR only.  connWith :: ( Real u, Floating u, InterpretUnit u ) -         => ConnectorPathQuery u -> Anchor u -> Anchor u -> TraceDrawing u ()+         => ArrowConnector u -> Anchor u -> Anchor u -> TraceDrawing u () connWith con a0 a1 = localize double_point_size $ -    drawc a0 a1 (rightArrow tri45 con)+    drawc a0 a1 (ignoreAns con)   atext :: ( CenterAnchor (t u), u ~ DUnit (t u)@@ -110,15 +110,28 @@  -- Cf. Parsec\'s Token module... -connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u-connline = C.connline default_connector_props+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conn_line =+    renderConnectorConfig default_connector_props $ makeSglArrConn C.conn_line -connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) -         => ConnectorPathQuery u-connabar = C.connabar default_connector_props+conna_orthovbar :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conna_orthovbar = +    renderConnectorConfig default_connector_props $ +      makeSglArrConn C.conna_orthovbar  -connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) -           => ConnectorPathQuery u-connaright = C.connaright default_connector_props+conna_right :: (Real u, Floating u, InterpretUnit u, Tolerance u) +            => ArrowConnector u+conna_right = +    renderConnectorConfig default_connector_props $ makeSglArrConn C.conna_right ++makeSglArrConn :: ConnectorPathSpec u -> ConnectorConfig u+makeSglArrConn cspec = +    ConnectorConfig+      { conn_arrowl     = Nothing+      , conn_arrowr     = Just tri45+      , conn_path_spec  = cspec+      }

@@ -37,7 +37,7 @@  arrow_drawing :: CtxPicture arrow_drawing = -    drawTracing $ localize dotted_line $ tableGraphic arrtable+    drawTracing $ localize line_thick $ tableGraphic arrtable  arrtable :: [(String, ArrowTip)] arrtable = @@ -77,8 +77,7 @@  tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double () tableGraphic tips = -    drawl start $ runTableColumnwise 18 (180,24) -                $ sequenceChain $ map arrowGraphic tips+    drawl start $ distribColumnwiseTable 18 (180,24) $ map arrowGraphic tips   where     start   = P2 0 480 @@ -94,13 +93,15 @@ arrowGraphic (name, utip) = aconn `mappend` lbl   where     aconn = ignoreAns $ promoteLoc $ \pt ->-              connect (uniformArrow utip connline) pt (displace (hvec 60) pt)+              connect (mkConn_line utip) pt (displace (hvec 60) pt)      lbl   = ignoreAns $ promoteLoc $ \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+mkConn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +            => ArrowTip -> ArrowConnector u+mkConn_line = rightArrowConnector default_connector_props C.conn_line++

@@ -79,20 +79,19 @@   -straightconn :: ( Real u, Floating u, InterpretUnit u+straightconn :: ( Real u, Floating u, InterpretUnit u, Tolerance u                 , u ~ DUnit a, u ~ DUnit b                 , CenterAnchor a, RadialAnchor a                 , CenterAnchor b, RadialAnchor b                 )              => a -> b -> Image u (AbsPath u) straightconn a b =-    let (p0,p1) = radialConnectorPoints a b-    in connect (rightArrow tri45 connline) p0 p1+    let (p0,p1) = radialConnectorPoints a b in connect conn_line p0 p1  -astraightconn :: ( Real u, Floating u, InterpretUnit u)+astraightconn :: ( Real u, Floating u, InterpretUnit u, Tolerance u)               => Anchor u -> Anchor u -> Image u (AbsPath u)-astraightconn p0 p1 = connect (rightArrow tri45 connline) p0 p1+astraightconn p0 p1 = connect conn_line p0 p1   -- Note - there is a problem with @rightArrow@ as @loop@@@ -101,8 +100,7 @@ arrloop :: ( Real u, Floating u, InterpretUnit u, Tolerance u)         => Anchor u -> Anchor u -> Image u (AbsPath u) arrloop ctr p1 = -    liftQuery (loop zradius ctr zincl) >>= \absp -> -    rightArrowPath tri45 absp +    rightArrowPath $ loopPath zradius ctr zincl   where     v1      = pvec ctr p1     zradius = vlength v1@@ -111,9 +109,13 @@  -- Cf. Parsec\'s Token module... -connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u-connline = C.connline default_connector_props+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +         => ArrowConnector u+conn_line = rightArrowConnector default_connector_props C.conn_line tri45    +rightArrowPath :: (Real u, Floating u, InterpretUnit u)+               => AbsPath u -> Image u (AbsPath u)+rightArrowPath = arrowDecoratePath Nothing (Just tri45) 

@@ -68,7 +68,7 @@ background rgb = promoteLoc $ \_ ->      ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288   where-    ihh = runTableColumnwise 18 (86,16) $ mapM chain1 $ replicate 112 iheartHaskell+    ihh = distribColumnwiseTable 18 (86,16) $ replicate 112 iheartHaskell                      -- | This is one for Wumpus-Basic - the set of combinators to 

@@ -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 chn (mapM chain1 gs)) `at` pt+tableGraphic row_count xs = +    drawl pt $ distribColumnwiseTable row_count (152,11) gs   where-    chn  = tableColumnwiseScm row_count (152,11)     pt   = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt      gs   = map (uncurry colourSample) xs    

@@ -38,39 +38,47 @@ conn_pic = drawTracing $ tableGraphic conntable  -conntable :: [(String, ConnectorPathQuery Double)]+conntable :: [(String, ConnectorPathSpec Double)] conntable = -    [ ("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)+    [ ("conn_line",             C.conn_line)+    , ("conna_arc",             C.conna_arc)+    , ("connb_arc",             C.connb_arc)+    , ("conn_hdiagh",           C.conn_hdiagh)+    , ("conn_vdiagv",           C.conn_vdiagv)+    , ("conn_diagh",            C.conn_diagh)+    , ("conn_diagv",            C.conn_diagv)+    , ("conn_hdiag",            C.conn_hdiag)+    , ("conn_vdiag",            C.conn_vdiag)+    , ("conna_bar",             C.conna_bar)+    , ("connb_bar",             C.connb_bar)+    , ("conna_flam",            C.conna_flam)+    , ("connb_flam",            C.connb_flam)+    , ("conna_orthohbar",       C.conna_orthohbar)+    , ("connb_orthohbar",       C.connb_orthohbar)+    , ("conna_orthovbar",       C.conna_orthovbar)+    , ("connb_orthovbar",       C.connb_orthovbar)+    , ("conna_right",           C.conna_right)+    , ("connb_right",           C.connb_right)+    , ("conn_hrr",              C.conn_hrr )+    , ("conn_rrh",              C.conn_rrh)+    , ("conn_vrr",              C.conn_vrr)+    , ("conn_rrv",              C.conn_rrv)+    , ("conna_loop",            C.conna_loop)+    , ("connb_loop",            C.connb_loop)+    , ("conn_hbezier",          C.conn_hbezier)+    , ("conn_vbezier",          C.conn_vbezier)     ]-  where-    props = default_connector_props { conn_dst_arm   = 2-                                    , conn_src_space = 0.5-                                    , conn_dst_space = 0.5 }  +props :: ConnectorProps+props = default_connector_props { conn_src_arm   = 1+                                , conn_dst_arm   = 1.5+                                , conn_src_space = 0.5+                                , conn_dst_space = 0.5 }  -tableGraphic :: [(String, ConnectorPathQuery Double)] -> TraceDrawing Double ()++tableGraphic :: [(String, ConnectorPathSpec Double)] -> TraceDrawing Double () tableGraphic conns = -    drawl start $ ignoreAns $ runTableColumnwise 8 (180,64)-                $ mapM (chain1 .  makeConnDrawing) conns+    drawl start $ distribColumnwiseTable 6 (200,80) $ map makeConnDrawing conns   where     start = P2 0 520  @@ -80,15 +88,24 @@   -makeConnDrawing :: (String, ConnectorPathQuery Double) -> DLocGraphic +makeConnDrawing :: (String, ConnectorPathSpec Double) -> DLocGraphic  makeConnDrawing (ss,conn) = -    promoteLoc $ \p0 -> fn p0 (displace (vec 60 40) p0) +    promoteLoc $ \p0 -> fn p0 (displace (vec 72 42) p0)    where     fn p0 p1   = mconcat [disk p0, disk p1, dcon p0 p1, lbl p1]      disk pt    = localize (fill_colour red) $ dcDisk DRAW_FILL 2 `at` pt-    dcon p0 p1 = ignoreAns $ connect (uniformArrow curveTip conn) p0 p1+    dcon p0 p1 = ignoreAns $ connect biarrow p0 p1 -    lbl  pt    = ignoreAns $ textline WW ss `at` (displace (hvec 10) pt)+    lbl  pt    = ignoreAns $ textline WW ss `at` (displace (V2 10 (-10)) pt) +    biarrow    = renderConnectorConfig props conf+                    ++    conf       = ConnectorConfig { conn_arrowl    = Just curveTip+                                 , conn_arrowr    = Just curveTip+                                 , conn_path_spec = conn+                                 }++                     

@@ -72,8 +72,8 @@  tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double () tableGraphic imgs = -    drawl pt $ runTableColumnwise row_count (180,36) -             $ mapM (chain1 . makeDotDrawing) imgs+    drawl pt $ distribColumnwiseTable row_count (180,36) +             $ map makeDotDrawing imgs   where     row_count   = 18     pt          = displace (vvec $ fromIntegral $ 36 * row_count) zeroPt 

@@ -87,35 +87,35 @@ widebox = makeBox 60  -connWith :: ( Real u, Floating u, InterpretUnit u ) +connWith :: ( Real u, Floating u, InterpretUnit u, Tolerance u)           => ArrowTip -> Box u -> Box u -> TraceDrawing u (AbsPath u) connWith arrh b0 b1 = do    lw <- getLineWidth    let p0 = south b0    let p1 = projectAnchor north (realToFrac lw) b1-   drawi $ connect (rightArrow arrh connline) p0 p1+   drawi $ connect (mkConn_line arrh) p0 p1  infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` -cmandatory :: ( Real u, Floating u, InterpretUnit u ) +cmandatory :: ( Real u, Floating u, InterpretUnit u, Tolerance u)             => Box u -> Box u -> TraceDrawing u (AbsPath u) cmandatory = connWith diskTip -coptional :: ( Real u, Floating u, InterpretUnit u ) +coptional :: ( Real u, Floating u, InterpretUnit u, Tolerance u)            => Box u -> Box u -> TraceDrawing u (AbsPath u) coptional = connWith odiskTip  -cmandatory_ :: ( Real u, Floating u, InterpretUnit u ) +cmandatory_ :: ( Real u, Floating u, InterpretUnit u, Tolerance u)              => Box u -> Box u -> TraceDrawing u () cmandatory_ p0 p1 = connWith diskTip p0 p1 >> return () -coptional_ :: ( Real u, Floating u, InterpretUnit u ) +coptional_ :: ( Real u, Floating u, InterpretUnit u, Tolerance 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+mkConn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +            => ArrowTip -> ArrowConnector u+mkConn_line = rightArrowConnector default_connector_props C.conn_line 

@@ -82,7 +82,7 @@ fontDrawing xs = drawTracing $       drawl start $ runChain_ chn_alg $ mapM (chain1 . uncurry fontGraphic) xs   where-    chn_alg   = tableColumnwiseScm 4 (2,180)+    chn_alg   = columnwiseTableScheme 4 (2,180)     start     = P2 0 (4*180)  

@@ -99,22 +99,29 @@   +makeSglArrConn :: ConnectorPathSpec u -> ConnectorConfig u+makeSglArrConn cspec = +    ConnectorConfig+      { conn_arrowl     = Nothing+      , conn_arrowr     = Just tri45+      , conn_path_spec  = cspec+      }  straightconn :: ConnectorGraphic Double-straightconn = ignoreAns $ rightArrow tri45 connline+straightconn = ignoreAns conn_line   connectorC :: ConnectorGraphic Double-connectorC = ignoreAns $ rightArrow tri45 connbbar+connectorC = ignoreAns conna_bar  connectorC' :: ConnectorGraphic Double-connectorC' = ignoreAns $ rightArrow tri45 connabar+connectorC' = ignoreAns connb_bar  connectorD :: ConnectorGraphic Double-connectorD = ignoreAns $ rightArrow tri45 connarc+connectorD = ignoreAns conna_arc  connectorD' :: ConnectorGraphic Double-connectorD' = ignoreAns $ rightArrow tri45 connarc+connectorD' = ignoreAns connb_arc   lblParensParens :: DLocGraphic@@ -140,21 +147,25 @@                                       , 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+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conn_line = renderConnectorConfig conn_props $ makeSglArrConn C.conn_line  -connabar :: (Real u, Floating u, InterpretUnit u, Tolerance u) -         => ConnectorPathQuery u-connabar = C.connabar conn_props+conna_bar :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conna_bar = renderConnectorConfig conn_props $ makeSglArrConn C.conna_bar  -connbbar :: (Real u, Floating u, InterpretUnit u, Tolerance u) -         => ConnectorPathQuery u-connbbar = C.connbbar conn_props+connb_bar :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+connb_bar = renderConnectorConfig conn_props $ makeSglArrConn C.connb_bar  -connarc :: (Real u, Floating u, InterpretUnit u, Tolerance u) -        => ConnectorPathQuery u-connarc = C.connarc conn_props+conna_arc :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conna_arc = renderConnectorConfig conn_props $ makeSglArrConn C.conna_arc++connb_arc :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+connb_arc = renderConnectorConfig conn_props $ makeSglArrConn C.connb_arc

@@ -68,7 +68,7 @@       , shapePic (apexAnchor >=> bottomCorners) $ semiellipse 100 150)      , ( "trapezium"       ,  shapePic (bottomCorners >=> topCorners >=> midPoints 4) $ -          trapezium 300 200 150)+          trapezium 300 180 ang60)     , ( "triangle"       , shapePic (apexAnchor >=> bottomCorners >=> midPoints 3) $            triangle 300 150 )@@ -137,7 +137,7 @@          => (t Double -> DTraceDrawing a) -> DShape t -> String -> CtxPicture shapePic mf sh name = udrawTracing (0::Double) $ do     a1  <- localize shapeSty $ drawi $ -              uniformScale 2 $ rotate05 $ shape `at` (P2 100 0)+              uniformScale 2 $ {- rotate05 $ -} shape `at` (P2 100 0)     draw $ label NORTH        "(center)"      `at` center a1     draw $ label NORTH        "(north)"       `at` north a1     draw $ label SOUTH        "(south)"       `at` south a1@@ -147,22 +147,20 @@     draw $ label NORTH_WEST   "(northwest)"   `at` northwest a1     draw $ label SOUTH_EAST   "(southeast)"   `at` southeast a1     draw $ label SOUTH_WEST   "(southwest)"   `at` southwest a1-    draw $ label EAST         "(10 deg)"      `at` radialAnchor deg10 a1-    draw $ label NORTH_WEST   "(110 deg)"     `at` radialAnchor deg110 a1-    draw $ label WEST         "(190 deg)"     `at` radialAnchor deg190 a1-    draw $ label NORTH        "(250 deg)"     `at` radialAnchor deg250 a1+    draw $ label EAST         "(10 deg)"      `at` radialAnchor (d2r 10) a1+    draw $ label NORTH_WEST   "(110 deg)"     `at` radialAnchor (d2r 110) a1+    draw $ label WEST         "(190 deg)"     `at` radialAnchor (d2r 190) a1+    draw $ label NORTH        "(250 deg)"     `at` radialAnchor (d2r 250) a1+    draw $ label WEST         "(200 deg)"     `at` radialAnchor (d2r 200) a1++--    draw $ label WEST         "(0 deg)"     `at` radialAnchor (d2r 0) a1+    draw $ label NORTH         "(224.5 deg)"     `at` radialAnchor (d2r 225.5) a1     _ <- mf a1     return ()       where     shape   = strokedShape $ setDecoration textF sh     textF   = promoteLocTheta $ \pt _ ->                  ignoreAns (multilineText VALIGN_CENTER CENTER name) `at` pt--    deg10   = d2r (10::Double)-    deg110  = d2r (110::Double)-    deg190  = d2r (190::Double)-    deg250  = d2r (250::Double)-   

@@ -2,7 +2,6 @@  module Symbols where -import Wumpus.Drawing.Basis.DrawingPrimitives import Wumpus.Drawing.Basis.Symbols import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Text.DirectionZero@@ -13,6 +12,7 @@  import Wumpus.Core                              -- package: wumpus-core +import Data.Monoid import System.Directory  @@ -30,7 +30,7 @@             makeCtx :: FontLoadResult -> DrawingContext-makeCtx = set_font times_roman . metricsContext 14+makeCtx = fill_colour khaki . set_font times_roman . metricsContext 14  symb_pic :: CtxPicture  symb_pic = drawTracing $ tableGraphic symbtable@@ -38,17 +38,30 @@  symbtable :: [(String, LocGraphic Double)] symbtable = -    [ ("ocircle",               ocircle 8) +    [ ("scircle",               scircle 8) +    , ("fcircle",               fcircle 8) +    , ("fscircle",              fscircle 8) +    , ("ssquare",               ssquare 8) +    , ("fsquare",               fsquare 8) +    , ("fssquare",              fssquare 8) +    , ("sleft_slice",           sleft_slice 14)+    , ("fleft_slice",           fleft_slice 14)+    , ("fsleft_slice",          fsleft_slice 14)+    , ("sright_slice",          sright_slice 14)+    , ("fright_slice",          fright_slice 14)+    , ("fsright_slice",         fsright_slice 14)+    , ("sleft_triangle",        sleft_triangle 14)+    , ("fleft_triangle",        fleft_triangle 14)+    , ("fsleft_triangle",       fsleft_triangle 14)+    , ("sright_triangle",       sright_triangle 14)+    , ("fright_triangle",       fright_triangle 14)+    , ("fsright_triangle",      fsright_triangle 14)     , ("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)@@ -58,8 +71,8 @@  tableGraphic :: [(String, LocGraphic Double)] -> TraceDrawing Double () tableGraphic symbs = -    drawl start $ ignoreAns $ runTableColumnwise 8 (180,24)-                $ mapM (chain1 .  makeSymbDrawing) symbs+    drawl start $ ignoreAns $ distribColumnwiseTable 14 (180,24)+                $ map makeSymbDrawing symbs   where     start = P2 0 520  

@@ -0,0 +1,137 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.BezierCurve+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Datatype for cubic Bezier curve.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.BezierCurve+  ( ++    BezierCurve(..)+  , vbezierCurve+  , subdivide+  , subdividet++  , bezierLength++  ) where+++import Wumpus.Drawing.Basis.Geometry+++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++--------------------------------------------------------------------------------++++-- | A Strict cubic Bezier curve.+--+data BezierCurve u = BezierCurve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)+  deriving (Eq,Ord,Show)++type instance DUnit (BezierCurve u) = u++++vbezierCurve :: Num u +             => Vec2 u -> Vec2 u -> Vec2 u -> Point2 u -> BezierCurve u+vbezierCurve v1 v2 v3 p0 = BezierCurve p0 p1 p2 p3+  where+    p1 = p0 .+^ v1+    p2 = p1 .+^ v2+    p3 = p2 .+^ v3++++-- | Curve subdivision via de Casteljau\'s algorithm.+--+subdivide :: Fractional u +          => BezierCurve u -> (BezierCurve u, BezierCurve u)+subdivide (BezierCurve p0 p1 p2 p3) =+    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)+  where+    p01   = midpoint p0    p1+    p12   = midpoint p1    p2+    p23   = midpoint p2    p3+    p012  = midpoint p01   p12+    p123  = midpoint p12   p23+    p0123 = midpoint p012  p123+++-- | subdivide with an affine weight along the line...+--+subdividet :: Real u+           => u -> BezierCurve u -> (BezierCurve u, BezierCurve u)+subdividet t (BezierCurve p0 p1 p2 p3) = +    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)+  where+    p01   = affineComb t p0    p1+    p12   = affineComb t p1    p2+    p23   = affineComb t p2    p3+    p012  = affineComb t p01   p12+    p123  = affineComb t p12   p23+    p0123 = affineComb t p012  p123+++--------------------------------------------------------------------------------++-- | 'bezierLength' : @ start_point * control_1 * control_2 * +--        end_point -> Length @ +--+-- Find the length of a Bezier curve. The result is an +-- approximation, with the /tolerance/ is 0.1 of a point. This+-- seems good enough for drawing (potentially the tolerance could +-- be larger still). +--+-- The result is found through repeated subdivision so the +-- calculation is potentially costly.+--+bezierLength :: (Floating u, Ord u, Tolerance u)+             => BezierCurve u -> u+bezierLength = gravesenLength length_tolerance ++++-- | Jens Gravesen\'s bezier arc-length approximation. +--+-- Note this implementation is parametrized on error tolerance.+--+gravesenLength :: (Floating u, Ord u) => u -> BezierCurve u -> u+gravesenLength err_tol crv = step crv +  where+    step c = let l1 = ctrlPolyLength c+                 l0 = cordLength c+             in if   l1-l0 > err_tol+                then let (a,b) = subdivide c in step a + step b+                else 0.5*l0 + 0.5*l1++-- | Length of the tree lines spanning the control points.+--+ctrlPolyLength :: Floating u => BezierCurve u -> u+ctrlPolyLength (BezierCurve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3+  where+    len pa pb = vlength $ pvec pa pb+++-- | Length of the cord - start point to end point.+--+cordLength :: Floating u => BezierCurve u -> u+cordLength (BezierCurve p0 _ _ p3) = vlength $ pvec p0 p3++

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Basis.DrawingPrimitives--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -27,34 +27,27 @@ module Wumpus.Drawing.Basis.DrawingPrimitives   ( -  -- * Monoid mappend-    (<>)    -- * Lines -  , horizontalLine+    horizontalLine   , verticalLine   , pivotLine -  , oStraightLines-  , cStraightLines -   -- * Rectangles   , blRectangle   , ctrRectangle  -  -- * Arc and wedge-  , arc+  -- * Wedge   , wedge    )    where -import Wumpus.Basic.Geometry                    -- package: wumpus-basic-import Wumpus.Basic.Kernel+import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core @@ -63,18 +56,7 @@  import Data.Monoid -infixr 6 <> ---- | Alias for mappend in Monoid.------ >  <> (infixr 6)--- -(<>) :: Monoid a => a -> a -> a-(<>) = mappend--- -------------------------------------------------------------------------------- -- Lines @@ -102,17 +84,8 @@     straightLine (pt .+^ avec (ang+pi) lu) (pt .+^ avec ang ru)  --- | Draw an open path formed from straight line segments.----oStraightLines :: InterpretUnit u => [Point2 u] -> Graphic u-oStraightLines ps = liftQuery (vertexPP ps) >>= dcOpenPath --- | Draw an closed path formed from straight line segments.----cStraightLines :: InterpretUnit u => DrawMode -> [Point2 u] -> Graphic u-cStraightLines mode ps = liftQuery (vertexPP ps) >>= dcClosedPath mode - -------------------------------------------------------------------------------- -- Rectangles @@ -141,12 +114,6 @@ -- Wedge  --- | arc : radius * apex_angle--- -arc :: (Floating u, InterpretUnit u) => u -> Radian -> LocThetaGraphic u-arc radius ang = promoteLocTheta $ \pt inclin -> -    let ps = bezierArcPoints ang radius inclin pt-    in liftQuery (curvePP ps) >>= dcOpenPath  -- | wedge : mode * radius * apex_angle -- @@ -158,8 +125,8 @@     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)+        w_arc    = circularArc CW ang radius (inclin - half_pi)         ct       = line_in `mappend` w_arc `mappend` line_out-    in supplyLoc pt $ drawCatTrail (closedMode mode) ct+    in supplyLoc pt $ renderCatTrail (closedMode mode) ct          

@@ -0,0 +1,51 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.Geometry+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Misc geometric operations.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.Geometry+  ( ++    midpoint+  , affineComb++  ) where+++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++--------------------------------------------------------------------------------++++--------------------------------------------------------------------------------+--+++-- | Affine combination...+--+affineComb :: Real u => u -> Point2 u -> Point2 u -> Point2 u+affineComb t p1 p2 = p1 .+^ t *^ (p2 .-. p1)+++-- | 'midpoint' : @ start_point * end_point -> Midpoint @+-- +-- Mid-point on the line formed between the two supplied points.+--+midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u+midpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0

@@ -0,0 +1,499 @@+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.InclineTrails+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.InclineTrails+  (++    incline_circle+  , incline_ellipse+  , incline_square+  , incline_rect+  , incline_diamond+  , incline_triangle+  , incline_barb+  , incline_tube+  , incline_chamf_rect++  , trail_diagh+  , trail_diagv+  , trail_hdiag+  , trail_vdiag++  , trail_hdiagh+  , trail_vdiagv++  , trail_perp_bar+  , trail_perp_bar2++  , trail_vflam+  , trail_ortho_hbar+  , trail_ortho_vbar++  , trail_hright+  , trail_vright++  , trail_hrr+  , trail_vrr+  , trail_rrh+  , trail_rrv++  , trail_rect_loop++  , vtriCurve+  , vrectCurve+  , vtrapCurve+  , vbowCurve+  , vwedgeCurve++  )+  where+++import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Data.Monoid+++-- Shapes...++incline_circle :: (Real u, Floating u) => Vec2 u -> AnaTrail u+incline_circle v1 = +    anaCatTrail zeroVec (semicircleTrail CW v1 <> semicircleTrail CW rv1)+  where+    rv1 = vreverse v1++incline_ellipse :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u+incline_ellipse ry v1 = +    anaCatTrail zeroVec (semiellipseTrail CW ry v1 <> semiellipseTrail CW ry rv1)+  where+    rv1 = vreverse v1++++incline_square :: (Real u, Floating u) => Vec2 u -> AnaTrail u+incline_square v1 = incline_rect (vlength v1) v1+++incline_rect :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u+incline_rect h v1 = +    anaCatTrail (theta_down (0.5 * h) ang) catt+  where+    len  = vlength v1+    ang  = vdirection v1+    catt = mconcat [ trail_theta_right len ang+                   , trail_theta_up h ang +                   , trail_theta_left len ang +                   , trail_theta_down h ang +                   ]+           +incline_diamond :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u+incline_diamond h v1 = anaCatTrail zeroVec catt+  where+    hw   = 0.5 * vlength v1+    hh   = 0.5 * h+    ang  = vdirection v1+    catt = mconcat [ orthoCatTrail   hw  (-hh) ang+                   , orthoCatTrail   hw    hh  ang +                   , orthoCatTrail (-hw)   hh  ang +                   , orthoCatTrail (-hw) (-hh) ang +                   ]++-- | Note - vector represents midpoint of the baseline to the +-- tip. Angle is the ang of the tip.+--+-- This trail is primarily for drawing arrowheads.+-- +incline_triangle :: (Real u, Floating u) => Radian -> Vec2 u -> AnaTrail u+incline_triangle tip_ang v1 = +    anaCatTrail (theta_up opposite theta) catt+  where+    half_ang = 0.5 * tip_ang+    theta    = vdirection v1+    h        = vlength v1+    opposite = h * (fromRadian $ tan half_ang)++    catt     = mconcat [ trail_theta_adj_grazing h half_ang theta+                       , trail_theta_bkwd_adj_grazing h half_ang theta+                       , trail_theta_up (2 * opposite) theta+                       ]+++-- | Note - vector represents midpoint of the baseline to the +-- tip. Angle is the ang of the tip.+--+-- This trail is primarily for drawing arrowheads. The resulting +-- path is /open/. +-- +incline_barb :: (Real u, Floating u) => Radian -> Vec2 u -> AnaTrail u+incline_barb tip_ang v1 = +    anaCatTrail (theta_up opposite theta) catt+  where+    half_ang = 0.5 * tip_ang+    theta    = vdirection v1+    h        = vlength v1+    opposite = h * (fromRadian $ tan half_ang)++    catt     = mconcat [ trail_theta_adj_grazing h half_ang theta+                       , trail_theta_bkwd_adj_grazing h half_ang theta+                       ]+++-- | @v1@ is the /interior/ vector.+--+incline_tube :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u+incline_tube h v1 = +    anaCatTrail (theta_down_right hh ang) $ mconcat $+      [ trail_theta_right base_len ang+      , semicircleTrail CCW vup+      , trail_theta_left base_len ang+      , semicircleTrail CCW vdown+      ]+  where+    hh        = 0.5 * h+    ang       = vdirection v1 +    base_len  = vlength v1 - h+    vup       = avec (ang + half_pi) h+    vdown     = avec (ang - half_pi) h+++incline_chamf_rect :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u+incline_chamf_rect h v1 = +    anaCatTrail zeroVec $ mconcat $+      [ trail_theta_down_right hh ang+      , trail_theta_right base_len ang+      , trail_theta_up_right hh ang+      , trail_theta_up_left hh ang+      , trail_theta_left base_len ang+      , trail_theta_down_left hh ang+      ]+  where+    hh        = 0.5 * h+    ang       = vdirection v1 +    base_len  = vlength v1 - h++-- | Diagonal-horizontal trail.+--+-- >    --@+-- >   /+-- >  o+-- +trail_diagh :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u+trail_diagh leg v1 = +    let h   = vector_y v1+        mid = (abs $ vector_x v1) - leg+    in case horizontalDirection $ vdirection v1 of+         RIGHTWARDS -> orthoCatTrail mid h 0    <> trail_right leg+         _          -> orthoCatTrail (-mid) h 0 <> trail_left leg++trail_diagv :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u+trail_diagv leg v1 = +    let w   = vector_x v1+        mid = (abs $ vector_y v1) - leg+    in case verticalDirection $ vdirection v1 of+         UPWARDS -> orthoCatTrail w mid 0 <> trail_up leg+         _       -> orthoCatTrail w (-mid) 0 <> trail_down leg+++trail_hdiag :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u+trail_hdiag leg v1 = +    let h   = vector_y v1+        mid = (abs $ vector_x v1) - leg+    in case horizontalDirection $ vdirection v1 of+         RIGHTWARDS -> trail_right leg <> orthoCatTrail mid h 0+         _          -> trail_left  leg <> orthoCatTrail (-mid) h 0+++trail_vdiag :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u+trail_vdiag leg v1 = +    let w   = vector_x v1+        mid = (abs $ vector_y v1) - leg+    in case verticalDirection $ vdirection v1 of+         UPWARDS -> trail_up   leg <> orthoCatTrail w mid 0+         _       -> trail_down leg <> orthoCatTrail w (-mid) 0++++-- | Horizontal-diagonal-horizontal trail.+--+-- >      --@+-- >     /+-- >  o--+-- +--+trail_hdiagh :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u+trail_hdiagh legl legr v1 = +    let h   = vector_y v1+        mid = (abs $ vector_x v1) - (legl + legr)+    in case horizontalDirection $ vdirection v1 of+         RIGHTWARDS -> mconcat [ trail_right legl+                               , orthoCatTrail mid h 0+                               , trail_right legr+                               ] +         _          -> mconcat [ trail_left  legl+                               , orthoCatTrail (-mid) h 0+                               , trail_left legr+                               ] ++++trail_vdiagv :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u+trail_vdiagv legl legr v1 = +    let w   = vector_x v1+        mid = (abs $ vector_y v1) - (legl + legr)+    in case verticalDirection $ vdirection v1 of+         UPWARDS -> mconcat [ trail_up legl+                            , orthoCatTrail w mid 0+                            , trail_up legr+                            ] +         _       -> mconcat [ trail_down  legl+                            , orthoCatTrail w (-mid) 0+                            , trail_down legr+                            ] ++-- | Uniform leg size.+--+trail_perp_bar :: (Real u, Floating u) +               => ClockDirection -> u -> Vec2 u -> CatTrail u+trail_perp_bar CW h v1 = trail_perp_barCW h v1+trail_perp_bar _  h v1 = trail_perp_barCW (-h) v1+++trail_perp_barCW :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u+trail_perp_barCW h v1 = +    trail_theta_up h ang <> catline v1 <> trail_theta_down h ang+  where+    ang = vdirection v1+++-- | Bar connector - independent leg size, legs perpendicular.+--+-- +-- >  o    @ +-- >  |    |+-- >  '----'  +--+-- The bar is drawn /below/ the points.+--+trail_perp_bar2 :: (Real u, Floating u) +                => ClockDirection -> u -> u -> Vec2 u -> CatTrail u+trail_perp_bar2 CW h1 h2 v1 = trail_perp_barCW2 h1 h2 v1+trail_perp_bar2 _  h1 h2 v1 = trail_perp_barCW2 (-h1) (-h2) v1+++trail_perp_barCW2 :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u+trail_perp_barCW2 h1 h2 v1 = +       trail_theta_up h1 ang +    <> orthoCatTrail (vlength v1) (negate $ h1 - h2) ang+    <> trail_theta_down h2 ang+  where+    ang = vdirection v1+++-- | Independent leg size.+--+trail_vflam :: (Real u, Floating u) +            => ClockDirection -> u -> u -> Vec2 u -> CatTrail u+trail_vflam CW h1 h2 v1 = trail_vflamCW h1 h2 v1+trail_vflam _  h1 h2 v1 = trail_vflamCW (-h1) (-h2) v1+++trail_vflamCW :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u+trail_vflamCW h1 h2 v1 = +    diffLines [ p0, p0 .+^ vvec h1, p1 .+^ vvec h2, p1 ]+  where+    p0 = zeroPt+    p1 = p0 .+^ v1+++-- | Height is minimum leg height. Ortho bar is horizontal.+--+trail_ortho_hbar :: (Real u, Floating u) +                 => ClockDirection -> u -> Vec2 u -> CatTrail u+trail_ortho_hbar CW h v1 = trail_ortho_hbarCW  h v1+trail_ortho_hbar _  h v1 = trail_ortho_hbarCCW h v1+++trail_ortho_hbarCW :: (Real u, Floating u) +                   => u -> Vec2 u -> CatTrail u+trail_ortho_hbarCW ymin v1@(V2 x y) = case quadrant $ vdirection v1 of+    QUAD_NE -> trail_up ymaj <> trail_right x <> trail_down ymin+    QUAD_SE -> trail_up ymin <> trail_right x <> trail_down ymaj+    QUAD_NW -> trail_down ymin <> trail_left (abs x) <> trail_up ymaj+    QUAD_SW -> trail_down ymaj <> trail_left (abs x) <> trail_up ymin+  where+    ymaj = ymin + abs y+++++trail_ortho_hbarCCW :: (Real u, Floating u) +                   => u -> Vec2 u -> CatTrail u+trail_ortho_hbarCCW ymin v1@(V2 x y) = case quadrant $ vdirection v1 of+    QUAD_NE -> trail_down ymin <> trail_right x <> trail_up ymaj+    QUAD_SE -> trail_down ymaj <> trail_right x <> trail_up ymin+    QUAD_NW -> trail_up ymaj <> trail_left (abs x) <> trail_down ymin+    QUAD_SW -> trail_up ymin <> trail_left (abs x) <> trail_down ymaj+  where+    ymaj = ymin + abs y+++++-- | Width is minimum leg width. Ortho bar is vertical.+--+trail_ortho_vbar :: (Real u, Floating u) +                 => ClockDirection -> u -> Vec2 u -> CatTrail u+trail_ortho_vbar CW w v1 = trail_ortho_vbarCW  w v1+trail_ortho_vbar _  w v1 = trail_ortho_vbarCCW w v1+++trail_ortho_vbarCW :: (Real u, Floating u) +                   => u -> Vec2 u -> CatTrail u+trail_ortho_vbarCW xmin v1@(V2 x y) = case quadrant $ vdirection v1 of+    QUAD_NE -> trail_left xmin <> trail_up y <> trail_right xmaj+    QUAD_NW -> trail_left xmaj <> trail_up y <> trail_right xmin+    QUAD_SE -> trail_right xmaj <> trail_down (abs y) <> trail_left xmin+    QUAD_SW -> trail_right xmin <> trail_down (abs y) <> trail_left xmaj+  where+    xmaj = xmin + abs x++++trail_ortho_vbarCCW :: (Real u, Floating u) +                   => u -> Vec2 u -> CatTrail u+trail_ortho_vbarCCW xmin v1@(V2 x y) = case quadrant $ vdirection v1 of+    QUAD_NE -> trail_right xmaj <> trail_up y <> trail_left xmin+    QUAD_NW -> trail_right xmin <> trail_up y <> trail_left xmaj+    QUAD_SE -> trail_left  xmin <> trail_down (abs y) <> trail_right xmaj+    QUAD_SW -> trail_left  xmaj <> trail_down (abs y) <> trail_right xmin+  where+    xmaj = xmin + abs x+++trail_hright :: Num u => Vec2 u -> CatTrail u+trail_hright (V2 x y) = trail_right x <> trail_up y+++trail_vright :: Num u => Vec2 u -> CatTrail u+trail_vright (V2 x y) = trail_up y <> trail_right x++trail_hrr :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u+trail_hrr x1 (V2 x y) = +       trail_theta_right x1 ang +    <> trail_theta_up y ang +    <> trail_theta_right (abs x  - x1) ang+  where+    ang = if x < 0 then pi else 0++trail_vrr :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u+trail_vrr y1 (V2 x y) = +       trail_theta_up y1 ang +    <> trail_theta_right x ang +    <> trail_theta_up (abs y  - y1) ang+  where+    ang = if y < 0 then pi else 0+++trail_rrh :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u+trail_rrh x1 (V2 x y) = +       trail_theta_right (abs x  - x1) ang +    <> trail_theta_up y ang +    <> trail_theta_right x1 ang+  where+    ang = if x < 0 then pi else 0++trail_rrv :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u+trail_rrv y1 (V2 x y) = +       trail_theta_up (abs y - y1) ang +    <> trail_theta_right x ang +    <> trail_theta_up y1 ang+  where+    ang = if y < 0 then pi else 0+++trail_rect_loop :: (Real u, Floating u) +                => ClockDirection -> u -> u -> u -> Vec2 u -> CatTrail u+trail_rect_loop CW = trail_rect_loopCW+trail_rect_loop _  = trail_rect_loopCCW++trail_rect_loopCW :: (Real u, Floating u) +                  => u -> u -> u -> Vec2 u -> CatTrail u+trail_rect_loopCW extl extr h v1 = +       trail_theta_left  extl ang+    <> trail_theta_up    h    ang+    <> trail_theta_right (len + extl + extr) ang+    <> trail_theta_down  h    ang+    <> trail_theta_left  extr ang+  where+    ang = vdirection v1+    len = vlength v1++trail_rect_loopCCW :: (Real u, Floating u)+                   => u -> u -> u -> Vec2 u -> CatTrail u+trail_rect_loopCCW extl extr h v1 = +       trail_theta_left  extl ang+    <> trail_theta_down  h    ang+    <> trail_theta_right (len + extl + extr) ang+    <> trail_theta_up    h    ang+    <> trail_theta_left  extr ang+  where+    ang = vdirection v1+    len = vlength v1+++-- | 'triCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination.+--+vtriCurve :: (Real u, Floating u) +          => ClockDirection -> u -> Vec2 u -> CatTrail u +vtriCurve clk h v1 = triCurve clk (vlength v1) h (vdirection v1)+  ++-- | 'rectCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination.+--+vrectCurve :: (Real u, Floating u) +           => ClockDirection -> u -> Vec2 u -> CatTrail u+vrectCurve clk h v1 = rectCurve clk (vlength v1) h (vdirection v1)+++-- | 'trapCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination.+--+vtrapCurve :: (Real u, Floating u)+           => ClockDirection -> u -> Radian -> Vec2 u -> CatTrail u+vtrapCurve clk h interior_ang v1 = +    trapCurve clk (vlength v1) h interior_ang (vdirection v1)+++-- | 'bowCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination.+--+vbowCurve :: (Real u, Floating u)+          => ClockDirection -> u -> Vec2 u -> CatTrail u+vbowCurve clk h v1 = bowCurve clk (vlength v1) h (vdirection v1) ++-- | 'wedgeCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination.+--+vwedgeCurve :: (Real u, Floating u)+            => ClockDirection -> u -> Vec2 u -> CatTrail u+vwedgeCurve clk h v1 = wedgeCurve clk (vlength v1) h (vdirection v1) +

@@ -0,0 +1,213 @@+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.ShapeTrails+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.ShapeTrails+  (++    circle_trail+  , rcircle_trail++  , ellipse_trail+  , rellipse_trail++  , rectangle_trail+  , rrectangle_trail++  , diamond_trail+  , rdiamond_trail++  , isosceles_triangle_trail+  , risosceles_triangle_trail++  , semicircle_trail+  , rsemicircle_trail++  , semiellipse_trail+  , rsemiellipse_trail++  , parallelogram_trail+  , rparallelogram_trail++  , trapezium_trail+  , rtrapezium_trail++  )++  where++import Wumpus.Drawing.Basis.InclineTrails++import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++-- import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Data.Monoid+++-- Shapes...++circle_trail :: (Real u, Floating u) => u -> AnaTrail u+circle_trail r = rcircle_trail r 0++rcircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u+rcircle_trail r ang = +    modifyAna (\v -> v ^-^ avec ang r) $ incline_circle $ avec ang (2 * r)++++ellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u+ellipse_trail rx ry = rellipse_trail rx ry 0++rellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u+rellipse_trail rx ry ang = +    modifyAna (\v -> v ^-^ avec ang rx) $ incline_ellipse ry $ avec ang (2 * rx)+++rectangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u+rectangle_trail w h = rrectangle_trail w h 0+++rrectangle_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u+rrectangle_trail w h ang = +    anaCatTrail (orthoVec (negate $ 0.5 * w) (negate $ 0.5 * h) ang) catt+  where+    catt = mconcat [ trail_theta_right w ang+                   , trail_theta_up    h ang +                   , trail_theta_left  w ang +                   , trail_theta_down  h ang +                   ]+++diamond_trail :: (Real u, Floating u) => u -> u -> AnaTrail u+diamond_trail w h = rdiamond_trail w h 0 ++rdiamond_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u+rdiamond_trail w h ang = +    anaCatTrail (theta_right hw ang) catt+  where+    hw   = 0.5 * w+    hh   = 0.5 * h+    catt = mconcat [ orthoCatTrail (-hw)   hh  ang+                   , orthoCatTrail (-hw) (-hh) ang +                   , orthoCatTrail   hw  (-hh) ang +                   , orthoCatTrail   hw    hh  ang +                   ]+++isosceles_triangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u+isosceles_triangle_trail bw h = risosceles_triangle_trail bw h 0 ++-- | Drawn at the centroid (1/3 * h).+--+risosceles_triangle_trail :: (Real u, Floating u) +                          => u -> u -> Radian -> AnaTrail u+risosceles_triangle_trail bw h ang = +    anaCatTrail (orthoVec (negate hbw) (negate $ h / 3) ang) catt+  where+    hbw  = 0.5 * bw+    catt = mconcat [ trail_theta_right bw ang+                   , orthoCatTrail (-hbw)   h  ang+                   , orthoCatTrail (-hbw) (-h) ang+                   ]+++semicircle_trail :: (Real u, Floating u) => u -> AnaTrail u+semicircle_trail r = rsemicircle_trail r 0++rsemicircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u+rsemicircle_trail r ang = +    anaCatTrail (orthoVec (negate r) (negate hminor) ang) catt+  where+    -- hminor is the centroid formula for semicircle+    hminor = (4 * r) / (3 * pi)+    catt   =  trail_theta_right (2 * r) ang+           <> semicircleTrail CCW (avec ang (negate $ 2 * r) )++++semiellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u+semiellipse_trail rx ry = rsemiellipse_trail rx ry 0++rsemiellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u+rsemiellipse_trail rx ry ang = +    anaCatTrail (orthoVec (negate rx) (negate hminor) ang) catt+  where+    -- hminor is the centroid formula for semiellipse+    hminor = (4 * ry) / (3 * pi)+    catt   =  trail_theta_right (2 * rx) ang+           <> semiellipseTrail CCW ry (avec ang (negate $ 2 * rx) )++-- | Note - bottom left angle must be smaller than 180deg, +-- otherwise a runtime error is thrown.+--+parallelogram_trail :: Floating u => u -> u -> Radian -> AnaTrail u+parallelogram_trail w h bottom_left_ang = +    rparallelogram_trail w h bottom_left_ang 0++-- | Note - bottom left angle must be smaller than 180deg, +-- otherwise a runtime error is thrown.+--+rparallelogram_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u+rparallelogram_trail w h bl_ang ang+    | bl_ang >= ang180 = +        error "rparallelogram_trail - bottom left angle >= 180."+    | otherwise     = anaCatTrail ctr_to_bl catt+  where+    -- Note - base_minor is negative for angles > 90+    base_minor = h / (fromRadian $ tan bl_ang)+                 +    vbase      = theta_right w ang+    vrhs       = orthoVec base_minor h ang+    vtop       = vreverse vbase+    vlhs       = vreverse vrhs+    ctr_to_bl  = vreverse $ 0.5 *^ (vbase ^+^ vrhs)+    catt       = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ]+++-- | Note - bottom left angle must be smaller than 180deg, +-- otherwise a runtime error is thrown.+--+-- Also, no checking is perfomed on the relation between height+-- and bottom_left ang. Out of range values will draw \"twisted\"+-- trapezoids.+-- +trapezium_trail :: Floating u => u -> u -> Radian -> AnaTrail u+trapezium_trail w h bottom_left_ang = +    rtrapezium_trail w h bottom_left_ang 0+++-- | Note - bottom left angle must be smaller than 180deg, +-- otherwise a runtime error is thrown.+--+rtrapezium_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u+rtrapezium_trail bw h bl_ang ang  +    | bl_ang >= ang180 = error "rtrapezium_trail - bottom left angle >= 180."+    | otherwise        = anaCatTrail ctr_to_bl catt+  where+    -- Note - base_minor is negative for angles > 90+    base_minor = h / (fromRadian $ tan bl_ang)+    top_width  = bw - (2 * base_minor)+    vbase      = theta_right bw ang+    vrhs       = orthoVec (-base_minor) h ang+    vtop       = theta_left top_width ang+    vlhs       = orthoVec (-base_minor) (-h) ang+    ctr_to_bl  = orthoVec (negate $ 0.5 * bw) (negate $ 0.5 * h) ang+    catt       = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ]++    

@@ -21,17 +21,35 @@ module Wumpus.Drawing.Basis.Symbols   ( -    ocircle+    scircle+  , fcircle+  , fscircle+    +  , ssquare+  , fsquare+  , fssquare++  , sleft_slice+  , fleft_slice+  , fsleft_slice++  , sright_slice+  , fright_slice+  , fsright_slice++  , sleft_triangle+  , fleft_triangle+  , fsleft_triangle++  , sright_triangle+  , fright_triangle+  , fsright_triangle+   , ochar   , ocharUpright   , ocharDescender   , ocurrency-  , left_slice-  , right_slice -  , left_triangle-  , right_triangle-   , empty_box    , hbar@@ -50,6 +68,8 @@  -- import Data.AffineSpace                         -- package: vector-space +import Data.Monoid+ -- -- DESIGN NOTE  --@@ -57,33 +77,251 @@ -- /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/. +-- expected to be redefined elsewhere (possibly at fixed size) +-- with the re-definitions used in /user code/ rather than these +-- primitives.  --  -- Using camelCase here, then under_score in the DocText versions -- adds double the function signatures to the Haddock docs. --+-- Also - should the names encode start pos, or can all start +-- positions be center?+-- +--+-- TikZ uses o to indicated /circled/.+--+-- Using o as a prefix for /open/ i.e. stroked has the problem +-- that there aren\'t any other characters ideographic for filled+-- or filled stroked.+-- +-- scircle+-- fcircle+-- fscircle -ocircle :: InterpretUnit u => u -> LocGraphic u-ocircle radius = dcDisk DRAW_STROKE radius ++-- | Stroked circle.+-- +-- Start pos - center.+--+scircle :: InterpretUnit u => u -> LocGraphic u+scircle radius = dcDisk DRAW_STROKE radius++-- | Filled circle.+-- +-- Start pos - center.+--+fcircle :: InterpretUnit u => u -> LocGraphic u+fcircle radius = dcDisk DRAW_FILL radius++-- | Filled-stroked circle.+-- +-- Start pos - center.+--+fscircle :: InterpretUnit u => u -> LocGraphic u+fscircle radius = dcDisk DRAW_FILL_STROKE radius+++++-- | Stroked square.+-- +-- Start pos - center.+--+ssquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+ssquare w = renderAnaTrail CSTROKE $ rectangleTrail w w +++-- | Filled square.+-- +-- Start pos - center.+--+fsquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+fsquare w = renderAnaTrail CFILL $ rectangleTrail w w +++-- | Filled-stroked square.+-- +-- Start pos - center.+--+fssquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+fssquare w = renderAnaTrail CFILL_STROKE $ rectangleTrail w w ++++-- | Implementation.+--+lslice :: (Real u, Floating u, InterpretUnit u) +       => DrawMode -> u -> LocGraphic u+lslice mode radius = moveStart (go_left $ 0.5 * radius) lwedge+  where+    lwedge = supplyIncline 0 $ wedge mode radius quarter_pi++-- | Stroked left slice (wedge).+-- +-- Start pos - ....+--+sleft_slice :: (Real u, Floating u, InterpretUnit u) +            => u -> LocGraphic u+sleft_slice = lslice DRAW_STROKE+++-- | Filled left slice (wedge).+-- +-- Start pos - ....+--+fleft_slice :: (Real u, Floating u, InterpretUnit u) +            => u -> LocGraphic u+fleft_slice = lslice DRAW_FILL+++-- | Filled-stroked left slice (wedge).+-- +-- Start pos - ....+--+fsleft_slice :: (Real u, Floating u, InterpretUnit u) +             => u -> LocGraphic u+fsleft_slice = lslice DRAW_FILL_STROKE++++-- | Implementation.+--+rslice :: (Real u, Floating u, InterpretUnit u) +       => DrawMode -> u -> LocGraphic u+rslice mode radius = moveStart (go_right $ 0.5 * radius) rwedge+  where+    rwedge = supplyIncline pi $ wedge mode radius quarter_pi+++-- | Stroked right slice (wedge).+-- +-- Start pos - ....+--+sright_slice :: (Real u, Floating u, InterpretUnit u) +             => u -> LocGraphic u+sright_slice = rslice DRAW_STROKE+++-- | Filled right slice (wedge).+-- +-- Start pos - ....+--+fright_slice :: (Real u, Floating u, InterpretUnit u) +             => u -> LocGraphic u+fright_slice = rslice DRAW_FILL+++-- | Filled-stroked right slice (wedge).+-- +-- Start pos - ....+--+fsright_slice :: (Real u, Floating u, InterpretUnit u) +              => u -> LocGraphic u+fsright_slice = rslice DRAW_FILL_STROKE++++-- | Implementation.+--+left_tri :: (Fractional u, InterpretUnit u) +         => PathMode -> u -> LocGraphic u+left_tri mode w = +    renderAnaTrail mode $ anaCatTrail (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+++-- | Stroked left triangle.+-- +-- Start pos - ....+--+sleft_triangle :: (Real u, Floating u, InterpretUnit u) +                => u -> LocGraphic u+sleft_triangle = left_tri CSTROKE+++-- | Filled left triangle.+-- +-- Start pos - ....+--+fleft_triangle :: (Real u, Floating u, InterpretUnit u) +                => u -> LocGraphic u+fleft_triangle = left_tri CFILL+++-- | Filled-stroked left triangle.+-- +-- Start pos - ....+--+fsleft_triangle :: (Real u, Floating u, InterpretUnit u) +                 => u -> LocGraphic u+fsleft_triangle = left_tri CFILL_STROKE+++-- | Implementation+--+right_tri :: (Fractional u, InterpretUnit u) +          => PathMode -> u -> LocGraphic u+right_tri mode w = +    renderAnaTrail mode $ anaCatTrail (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+++-- | Stroked right triangle.+-- +-- Start pos - ....+--+sright_triangle :: (Real u, Floating u, InterpretUnit u) +                => u -> LocGraphic u+sright_triangle = right_tri CSTROKE+++-- | Filled right triangle.+-- +-- Start pos - ....+--+fright_triangle :: (Real u, Floating u, InterpretUnit u) +                => u -> LocGraphic u+fright_triangle = right_tri CFILL+++-- | Filled-stroked right triangle.+-- +-- Start pos - ....+--+fsright_triangle :: (Real u, Floating u, InterpretUnit u) +                 => u -> LocGraphic u+fsright_triangle = right_tri CFILL_STROKE+++ -- | Note this looks horrible for chars with descenders. -- ochar :: (Fractional u, InterpretUnit u) -             => EscapedChar -> LocGraphic 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)+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (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)+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (0.85 * h)  ocharDescender :: (Fractional u, InterpretUnit u)               => EscapedChar -> LocGraphic u@@ -91,12 +329,12 @@   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)+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (0.85 * h)   ocurrency :: (Floating u, InterpretUnit u)            => u -> LocGraphic u -ocurrency ra = ocircle ra <> lne <> lnw <> lsw <> lse+ocurrency ra = scircle ra <> lne <> lnw <> lsw <> lse   where     ra3 = 0.33 * ra     lne = moveStart (go_north_east ra) $ locStraightLine $ go_north_east ra3@@ -104,52 +342,18 @@     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+empty_box w = renderAnaTrail 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+    renderAnaTrail OSTROKE $ anaCatTrail (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+    renderAnaTrail OSTROKE $ anaCatTrail (go_down $ 0.5 * u) $ trail_up u  dbl_hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u dbl_hbar u = line1 <> line2

@@ -20,12 +20,10 @@   (      module Wumpus.Drawing.Connectors.Arrowheads   , module Wumpus.Drawing.Connectors.Base-  , module Wumpus.Drawing.Connectors.BoxConnectors   , 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.ConnectorProps

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Connectors.Arrowheads--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -12,6 +12,8 @@ -- -- Arrowheads. --+-- \*\* WARNING \*\* - naming scheme due to change.+-- --------------------------------------------------------------------------------  module Wumpus.Drawing.Connectors.Arrowheads@@ -59,104 +61,86 @@   ) where  -import Wumpus.Drawing.Basis.DrawingPrimitives+import Wumpus.Drawing.Basis.InclineTrails import Wumpus.Drawing.Connectors.Base  import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space+-- import Data.AffineSpace                         -- package: vector-space import Data.VectorSpace +import Data.Monoid   --- | Arrow tips are drawn with a sloid line even if the connector++++-- | Arrow tips are drawn with a solid line even if the connector -- line is dashed (tips also override round corners)  solid_stroke_tip :: DrawingContextF-solid_stroke_tip = reset_drawing_metrics+solid_stroke_tip = solid_line -- reset_drawing_metrics  -type PointGen = Radian -> [Vec2 En] +type TrailGen = Radian -> AnaTrail En -filledTipPath :: PointGen -> LocThetaGraphic En-filledTipPath gen = -    localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta ->-      cStraightLines DRAW_FILL $ map (pt .+^) $ gen theta +fillTrailTip :: TrailGen -> LocThetaGraphic En+fillTrailTip gen_pt = +    localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta ->+      supplyLoc pt $ renderAnaTrail CFILL $ gen_pt theta -closedTipPath :: PointGen -> LocThetaGraphic En-closedTipPath gen = +closedTrailTip :: TrailGen -> LocThetaGraphic En+closedTrailTip gen_pt =      localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->-      cStraightLines DRAW_STROKE $ map (pt .+^) $ gen theta+      supplyLoc pt $ renderAnaTrail CSTROKE $ gen_pt theta  -openTipPath :: PointGen -> LocThetaGraphic En-openTipPath gen = +openTrailTip :: TrailGen -> LocThetaGraphic En+openTrailTip gen_pt =      localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->-      oStraightLines $ map (pt .+^) $ gen theta+      supplyLoc pt $ renderAnaTrail OSTROKE $ gen_pt theta   --- | Return @o-a@ and @o-b@:------ >    a--- >    .\--- >    . \--- >  .....o--- >    . /--- >    ./--- >    b----tripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En))-tripointsFromTip baselen ang = \theta -> -    (avec (theta + au) hyp, avec (theta + ad) hyp)-  where-    half_ang  = 0.5 * ang -    au        = pi - half_ang-    ad        = half_ang + pi-    hyp       = baselen / (fromRadian $ cos half_ang)  ---- | Return @o-x@ and @o-a@ and @o-b@:------ >       a--- >      /.--- >     / .--- > .. x..o--- >     \ .--- >      \.--- >       b+-- | All three lines are stated. ---revTripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En, Vec2 En))-revTripointsFromTip baselen ang = \theta -> -    (avec theta (-baselen), oa theta, ob theta)-  where-    half_ang    = 0.5 * ang -    half_height = baselen * (fromRadian $ tan half_ang)-    oa          = \theta -> avec (theta + ang90) half_height-    ob          = \theta -> avec (theta - ang90) half_height---+closedTriTrail :: Radian -> TrailGen+closedTriTrail ang = \theta ->+    modifyAna (\v1 -> v1 ^+^ theta_left 1 theta) $+      incline_triangle ang (avec theta 1)    filledTri :: Radian -> ArrowTip filledTri ang =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5-      , tip_deco         = filledTipPath spec+      , tip_deco         = fillTrailTip $ closedTriTrail ang       }-  where-    spec theta = let (v1,v2) = tripointsFromTip 1 ang theta -                 in [zeroVec, v1, v2] +--+-- DESIGN NOTE +--+-- Naming scheme should change.+--+-- The \"wumpus way\" of naming seems to be coalescing to favour +-- underscore separated names rather than camelCase for /data/ +-- objects. +--+-- These data objects can still be functions but they are +-- distinguished by drawing differently - roughly speaking+-- the difference between a barb tip and a triangle tip is +-- \"what they draw not what they mean\".+--+ -- | Filled triangle - apex is 90 deg. -- tri90 :: ArrowTip@@ -176,13 +160,10 @@ strokedClosedTri :: Radian -> ArrowTip strokedClosedTri ang =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5-      , tip_deco         = closedTipPath spec+      , tip_deco         = closedTrailTip $ closedTriTrail ang       }-  where-    spec theta = let (v1,v2) = tripointsFromTip 1 ang theta -                 in [zeroVec, v1, v2]   otri90 :: ArrowTip@@ -195,17 +176,21 @@ otri45 = strokedClosedTri ang45  +-- | All three lines are stated.+--+revClosedTriSpec :: Radian -> TrailGen+revClosedTriSpec ang = \theta -> incline_triangle ang (avec theta (-1))++ filledRevTri :: Radian -> ArrowTip filledRevTri ang =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 0.5       , tip_half_len     = 0.5-      , tip_deco         = filledTipPath spec+      , tip_deco         = fillTrailTip $ revClosedTriSpec ang       }-  where-    spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta -                 in [v0, v1, v2] + revtri90 :: ArrowTip revtri90 = filledRevTri ang90 @@ -219,15 +204,11 @@ strokedClosedRevTri :: Radian -> ArrowTip strokedClosedRevTri ang =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5-      , tip_deco         = closedTipPath spec+      , tip_deco         = closedTrailTip $ revClosedTriSpec ang       }-  where-    spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta -                 in [v0, v1, v2] - orevtri90 :: ArrowTip orevtri90 = strokedClosedRevTri ang90 @@ -238,19 +219,19 @@ orevtri45 = strokedClosedRevTri ang45  +barbSpec :: Radian -> TrailGen+barbSpec ang = \theta -> +    modifyAna (\v1 -> v1 ^+^ avec theta (-1)) $ incline_barb ang (avec theta 1) + strokedBarb :: Radian -> ArrowTip strokedBarb ang =      ArrowTip-      { retract_distance = const 0+      { retract_distance = 0       , tip_half_len     = 0.5-      , tip_deco         = openTipPath spec+      , tip_deco         = openTrailTip $ barbSpec ang       }-  where-    spec theta = let (v1,v2) = tripointsFromTip 1 ang theta -                 in [v1,zeroVec,v2] - barb90 :: ArrowTip barb90 = strokedBarb ang90 @@ -261,17 +242,18 @@ barb45 = strokedBarb ang45  +revBarbSpec :: Radian -> TrailGen+revBarbSpec ang = \theta -> incline_barb ang (avec theta (-1))+ strokedRevBarb :: Radian -> ArrowTip strokedRevBarb ang =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5-      , tip_deco         = openTipPath spec+      , tip_deco         = openTrailTip $ revBarbSpec ang        }-  where-    spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta -                 in [v1,v0,v2] + revbarb90 :: ArrowTip revbarb90 = strokedRevBarb ang90 @@ -282,98 +264,87 @@ revbarb45 = strokedRevBarb ang45  +perpSpec :: TrailGen+perpSpec ang = +    anaCatTrail (theta_up 0.5 ang) $ trail_theta_down 1 ang  perp :: ArrowTip perp =      ArrowTip-      { retract_distance = const 0+      { retract_distance = 0       , tip_half_len     = 0-      , tip_deco         = openTipPath spec+      , tip_deco         = openTrailTip perpSpec       }+++bracketSpec :: TrailGen+bracketSpec ang = anaCatTrail (orthoVec (-0.5) 0.5 ang) catt   where-    spec theta = let oa = avec (theta + ang90) 0.5-                     ob = avec (theta - ang90) 0.5-                 in [oa, ob]+    catt = mconcat [ trail_theta_right 0.5 ang+                   , trail_theta_down  1.0 ang+                   , trail_theta_left  0.5 ang +                   ]   bracket :: ArrowTip bracket =      ArrowTip-      { retract_distance = const 0+      { retract_distance = 0.0       , tip_half_len     = 0.5-      , tip_deco         = openTipPath spec+      , tip_deco         = openTrailTip bracketSpec       }-  where-    spec theta = let oa = avec (theta + ang90) 0.5-                     ob = avec (theta - ang90) 0.5-                     dv = avec theta (-0.5)-                 in [ oa ^+^ dv, oa, ob, ob ^+^ dv ] -+diskBody :: DrawMode -> Radian -> LocGraphic En+diskBody mode theta = +    localize fill_use_stroke_colour $ moveStart vback $ dcDisk mode 0.5+  where+    vback = theta_left 0.5 theta  diskTip :: ArrowTip diskTip =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 0.5       , tip_half_len     = 0.5-      , tip_deco         = promoteLocTheta $ \pt theta -> body theta `at` pt+      , tip_deco         = promoteLocTheta $ \pt theta -> +                             diskBody DRAW_FILL theta `at` pt       }-  where-    body :: Radian -> LocGraphic En-    body theta = let v1 = avec theta (-0.5)-                 in localize fill_use_stroke_colour $ -                      moveStart v1 (dcDisk DRAW_FILL 0.5)   odiskTip :: ArrowTip odiskTip =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5-      , tip_deco         = promoteLocTheta $ \pt theta -> body theta `at` pt+      , tip_deco         = promoteLocTheta $ \pt theta -> +                             diskBody DRAW_STROKE theta `at` pt       }-  where-    body :: Radian -> LocGraphic En-    body theta = let v1 = avec theta (-0.5)-                 in localize solid_stroke_tip $ -                      moveStart v1 (dcDisk DRAW_STROKE 0.5)  --- | squareSpec:------ > --- >    ,-----a--- >    |     |--- > ...v.....o--- >    |     | --- >    `-----b+-- | Note - need to draw square East-West rather than West-East+-- hence the base_width is negative. ---squareSpec :: PointGen-squareSpec theta = [ oa ^+^ ov, oa, ob, ob ^+^ ov ]-  where-    oa = avec (theta + ang90) 0.5-    ob = avec (theta - ang90) 0.5-    ov = avec theta (-1)-    +squareSpec :: TrailGen+squareSpec theta = incline_square $ avec theta (-1) + squareTip :: ArrowTip squareTip =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5-      , tip_deco         = filledTipPath squareSpec+      , tip_deco         = fillTrailTip squareSpec       }+      osquareTip :: ArrowTip osquareTip =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5-      , tip_deco         = closedTipPath squareSpec+      , tip_deco         = closedTrailTip squareSpec       }  - -- | squareSpec: -- -- > @@ -383,52 +354,46 @@ -- >     \   /  -- >       b ---diamondSpec :: En -> PointGen-diamondSpec width theta = [ ow, oa, zeroVec, ob ]-  where-    ow = avec theta (-width)-    ov = avec theta (negate $ 0.5 * width)-    oa = ov ^+^ avec (theta + ang90) 0.5-    ob = ov ^+^ avec (theta - ang90) 0.5-+diamondSpec :: En -> TrailGen+diamondSpec w theta = incline_diamond 1 $ avec theta (-w)  diamondTip :: ArrowTip diamondTip =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 0.5       , tip_half_len     = 0.5-      , tip_deco         = filledTipPath (diamondSpec 1)+      , tip_deco         = fillTrailTip $ diamondSpec 1       }  odiamondTip :: ArrowTip odiamondTip =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5-      , tip_deco         = closedTipPath (diamondSpec 1)+      , tip_deco         = closedTrailTip $ diamondSpec 1       }   diamondWideTip :: ArrowTip diamondWideTip =      ArrowTip-      { retract_distance = const 2+      { retract_distance = 1.0       , tip_half_len     = 1.0-      , tip_deco         = filledTipPath (diamondSpec 2)+      , tip_deco         = fillTrailTip $ diamondSpec 2       }  odiamondWideTip :: ArrowTip odiamondWideTip =      ArrowTip-      { retract_distance = const 2+      { retract_distance = 2.0       , tip_half_len     = 1.0-      , tip_deco         = closedTipPath (diamondSpec 2)+      , tip_deco         = closedTrailTip $ diamondSpec 2       }  -curveTipTrail :: Radian -> PlacedTrail En-curveTipTrail theta = -    placeCatTrail dv $ vectrapCCW v1 <> vectrapCCW v2+curveTipSpec :: TrailGen+curveTipSpec theta = +    anaCatTrail dv $ vectrapCCW v1 <> vectrapCCW v2   where     dv  = orthoVec (-1.0)   0.75  theta     -- back and up     v1  = orthoVec   1.0  (-0.75) theta     -- fwd and down@@ -436,7 +401,7 @@   vectrapCW :: (Real u, Floating u) => Vec2 u -> CatTrail u-vectrapCW v1 = trapcurveCW w h ang45 ang+vectrapCW v1 = trapCurve CW w h quarter_pi ang   where     w   = vlength v1     h   = w / 4@@ -444,7 +409,7 @@   vectrapCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u-vectrapCCW v1 = trapcurveCCW w h quarter_pi ang+vectrapCCW v1 = trapCurve CCW w h quarter_pi ang   where     w   = vlength v1     h   = w / 4@@ -454,20 +419,19 @@ curveTip :: ArrowTip curveTip =      ArrowTip-      { retract_distance = const 0+      { retract_distance = 0       , tip_half_len     = 0.5       , tip_deco         = body       }   where-    body = promoteLocTheta $ \pt theta -> -             localize (join_bevel . solid_stroke_tip) $ -               supplyLoc pt $ drawPlacedTrail OSTROKE $ curveTipTrail theta+    body = localize (cap_round . join_round . solid_stroke_tip) $ +             openTrailTip curveTipSpec   -curveTipRevTrail :: Radian -> PlacedTrail En-curveTipRevTrail theta = -    placeCatTrail dv $ vectrapCW v1 <> vectrapCW v2+curveTipRevSpec :: TrailGen+curveTipRevSpec theta = +    anaCatTrail dv $ vectrapCW v1 <> vectrapCW v2   where     dv  = orthoVec   0.0    0.75  theta     -- just up     v1  = orthoVec (-1.0) (-0.75) theta     -- back and down@@ -478,13 +442,12 @@ revcurveTip :: ArrowTip revcurveTip =      ArrowTip-      { retract_distance = const 1+      { retract_distance = 1       , tip_half_len     = 0.5       , tip_deco         = body       }   where-    body = promoteLocTheta $ \pt theta -> -             localize (join_bevel . solid_stroke_tip) $ -               supplyLoc pt $ drawPlacedTrail OSTROKE $ curveTipRevTrail theta+    body = localize (cap_round . join_round . solid_stroke_tip) $ +             openTrailTip curveTipRevSpec  

@@ -19,19 +19,24 @@       ConnectorPathQuery+  , SpacingProjection    , ArrowTip(..)   , ArrowConnector -  , leftArrow-  , rightArrow  -  , leftRightArrow-  , uniformArrow  +  , ConnectorConfig(..)+  , ConnectorPathSpec(..)+  , renderConnectorConfig -  , rightArrowPath+  , arrowDecoratePath +  , leftArrowConnector+  , rightArrowConnector+  , uniformArrowConnector+   ) where +import Wumpus.Drawing.Connectors.ConnectorProps import Wumpus.Drawing.Paths  import Wumpus.Basic.Kernel                      -- package: wumpus-basic@@ -43,151 +48,121 @@   --- | The type of Connectors - a query from start and end point to --- a Path.+type SpacingProjection u = +      ConnectorProps -> Point2 u -> Point2 u -> Query u (Point2 u)++++-- | The type of Connectors - a query from start and end point +-- returning an AbsPath. -- type ConnectorPathQuery u = ConnectorQuery u (AbsPath u) ++ -- | Arrowhead /algorithm/ - the components of an arrowhead. -- --- Retract distance may have to account for line width.+-- Retract distance is rather vague - depending on the arrowhead+-- it may represent a flush join between the path and the tip+-- or a join that uses the z-order (tip over path) to create the +-- join. --+-- \*\* WARNING \*\* - pending revision...+-- data ArrowTip = ArrowTip-      { retract_distance :: Double -> En+      { retract_distance :: En       , tip_half_len     :: En       , tip_deco         :: LocThetaGraphic En       } --- Ideally there should be a plus operation to combine tips --- allowing double tips.---  -type ArrowConnector u = ConnectorImage u (AbsPath u)----runArrowTip :: InterpretUnit u -            => ArrowTip -> Query u (u, u, LocThetaGraphic u)-runArrowTip (ArrowTip df len deco) = -   getLineWidth             >>= \lw    -> -   uconvertCtx1 (df lw)     >>= \uretd ->-   uconvertCtx1 len         >>= \ulen  ->-   return (uretd, ulen, uconvF deco)----- | Connector with an arrow tip at the end point (i.e right).----rightArrow :: (Real u, Floating u, InterpretUnit u) -           => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u-rightArrow alg conn = promoteConn $ \p0 p1 ->-    applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> -    rightArrowPath alg full_path ------ | Connector with an arrow tip at the start point (i.e left).----leftArrow :: (Real u, Floating u, InterpretUnit u) -            => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u-leftArrow alg conn = promoteConn $ \p0 p1 ->-    applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> -    leftArrowPath alg full_path ----- | Connector with different arrow tips at the start point and --- end points.----leftRightArrow :: (Real u, Floating u, InterpretUnit 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 --+newtype ConnectorPathSpec u = ConnectorPathSpec { +      getConnectorPathSpec :: ConnectorProps -> ConnectorPathQuery u } --- | Connector with the same arrow tip at the start point and --- end points.+-- | total_path is the path before accounting for arrow +-- retract distances. ---uniformArrow :: (Real u, Floating u, InterpretUnit u) -               => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u-uniformArrow alg conn = promoteConn $ \p0 p1 ->-    applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> -    leftRightArrowPath alg alg full_path +data ConnectorConfig u = ConnectorConfig+      { conn_arrowl     :: Maybe ArrowTip+      , conn_arrowr     :: Maybe ArrowTip+      , conn_path_spec  :: ConnectorPathSpec u +      }   --- TODO - possible there are opportunities to be more --- compositional here.----- | Path with an arrow tip at the start point (i.e left).------ TODO - shortening a curve does not seem to be working properly...+-- Ideally there should be a plus operation to combine tips +-- allowing double tips. -- ----leftArrowPath :: (Real u, Floating u, InterpretUnit u) -              => ArrowTip -> AbsPath u -> Image u (AbsPath u)-leftArrowPath alg full_path =-    liftQuery (runArrowTip alg) >>= \(retract, len, deco) -> -    let short_path      = if retract > 0 then shortenL retract full_path -                                         else full_path-        mid_ang         = tipDirectionL len full_path-        tip             = applyLocTheta deco (tipL full_path) mid_ang-    in replaceAns full_path $ -         sdecorate tip $ drawPath OSTROKE short_path ----- | Path with an arrow tip at the end point (i.e right).------ TODO - shortening a curve does not seem to be working properly...--- ----rightArrowPath :: (Real u, Floating u, InterpretUnit u) -               => ArrowTip -> AbsPath u -> Image u (AbsPath u)-rightArrowPath alg full_path =-    liftQuery (runArrowTip alg) >>= \(retract, len, deco) -> -    let short_path      = if retract > 0 then shortenR retract full_path -                                         else full_path-        mid_ang         = tipDirectionR len full_path-        tip             = applyLocTheta deco (tipR full_path) mid_ang-    in replaceAns full_path $ -         sdecorate tip $ drawPath OSTROKE short_path+type ArrowConnector u = ConnectorImage u (AbsPath u)    --- | Path with an arrow tip at the end point (i.e right).------ TODO - shortening a curve does not seem to be working properly...+-- | NOTE - the prefix /render/ needs (re-) consideration... -- +-- If it is a good prefix other functions e.g. drawPath should +-- use render rather than draw. ---leftRightArrowPath :: (Real u, Floating u, InterpretUnit u) -                   => ArrowTip -> ArrowTip -> AbsPath u -> Image u (AbsPath u)-leftRightArrowPath algl algr full_path =-    liftQuery (runArrowTip algl) >>= \(retractl, lenl, decol) -> -    liftQuery (runArrowTip algr) >>= \(retractr, lenr, decor) -> -    let short_path      = shortenPath retractl retractr full_path-        mid_angl        = tipDirectionL lenl full_path-        mid_angr        = tipDirectionR lenr full_path-        tipl            = applyLocTheta decol (tipL full_path) mid_angl-        tipr            = applyLocTheta decor (tipR full_path) mid_angr-    in replaceAns full_path $ -         sdecorate (tipl `mappend` tipr) $ drawPath OSTROKE short_path-          +renderConnectorConfig :: (Real u, Floating u, InterpretUnit u)+                      => ConnectorProps+                      -> ConnectorConfig u+                      -> ConnectorImage u (AbsPath u)+renderConnectorConfig props (ConnectorConfig mbl mbr pspec) = +    promoteConn $ \src dst -> +      liftQuery (qapplyConn path_spec src dst) >>= \tot_path -> +      connectorSrcSpace props >>= \sepl -> +      connectorDstSpace props >>= \sepr ->+      arrowDecoratePath mbl mbr $ shortenL sepl $ shortenR sepr tot_path+  where+    path_spec = getConnectorPathSpec pspec props   +arrowDecoratePath :: (Real u, Floating u, InterpretUnit u) +                  => Maybe ArrowTip -> Maybe ArrowTip -> (AbsPath u) +                  -> Image u (AbsPath u)+arrowDecoratePath mbl mbr initial_path = +      uconvertCtx1 (maybe 0 retract_distance mbl) >>= \retl -> +      uconvertCtx1 (maybe 0 retract_distance mbr) >>= \retr -> +      let (p1,theta1)  = atstart initial_path+          (p2,theta2)  = atend   initial_path+          new_path     = shortenL retl $ shortenR retr initial_path+          arrl         = mbTip p1 (pi + theta1) mbl+          arrr         = mbTip p2 theta2 mbr+      in replaceAns initial_path $ +           decorate ZABOVE (renderPath OSTROKE new_path) (arrl `mappend` arrr)+  where+    mbTip pt ang = maybe emptyImage (supplyLocTheta pt ang . uconvF . tip_deco) --- | Helper - direction looks best at half the retract distance.++-- | Shorthand... ---tipDirectionL :: (Real u, Floating u) => u -> AbsPath u -> Radian-tipDirectionL u absp | u <= 0   = directionL absp-                     |otherwise = directionL $ shortenL (0.5*u) absp-   -tipDirectionR :: (Real u, Floating u) => u -> AbsPath u -> Radian-tipDirectionR u absp | u <= 0   = directionR absp-                     |otherwise = directionR $ shortenR (0.5*u) absp-   +leftArrowConnector :: (Real u, Floating u, InterpretUnit u)+                    => ConnectorProps -> ConnectorPathSpec u -> ArrowTip+                    -> ConnectorImage u (AbsPath u)+leftArrowConnector props cpath tip = renderConnectorConfig props cfg +  where+    cfg = ConnectorConfig { conn_arrowl    = Just tip +                          , conn_arrowr    = Nothing+                          , conn_path_spec = cpath } +rightArrowConnector :: (Real u, Floating u, InterpretUnit u)+                    => ConnectorProps -> ConnectorPathSpec u -> ArrowTip+                    -> ConnectorImage u (AbsPath u)+rightArrowConnector props cpath tip = renderConnectorConfig props cfg +  where+    cfg = ConnectorConfig { conn_arrowl    = Nothing+                          , conn_arrowr    = Just tip+                          , conn_path_spec = cpath }+    +uniformArrowConnector :: (Real u, Floating u, InterpretUnit u)+                    => ConnectorProps -> ConnectorPathSpec u -> ArrowTip+                    -> ConnectorImage u (AbsPath u)+uniformArrowConnector props cpath tip = renderConnectorConfig props cfg +  where+    cfg = ConnectorConfig { conn_arrowl    = Just tip+                          , conn_arrowr    = Just tip+                          , conn_path_spec = cpath }+     

@@ -17,22 +17,27 @@ module Wumpus.Drawing.Connectors.BoxConnectors   (      ConnectorBox-  , connbox-  , conntube+  , ConnectorBoxSpec(..)+  , renderConnectorBoxSpec +  , conn_box+  , conn_tube+  , conn_chamf_box ++   ) where --- import Wumpus.Drawing.Connectors.Base+import Wumpus.Drawing.Basis.InclineTrails import Wumpus.Drawing.Connectors.ConnectorProps  import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core +import Data.VectorSpace                         -- package: vector-space -import Data.Monoid --- NOTE - boxes (currently) seem to only support stroke otherwise+-- NOTE - boxes seem to only support stroke otherwise -- they would obliterate what they connect.  @@ -45,67 +50,67 @@ -- type ConnectorBox u = ConnectorGraphic u +newtype ConnectorBoxSpec u = ConnectorBoxSpec { +      getConnectorBoxSpec :: ConnectorProps -> ConnectorBox u } ++renderConnectorBoxSpec :: (Real u, Floating u, InterpretUnit u)+                       => ConnectorProps+                       -> ConnectorBoxSpec u+                       -> ConnectorBox u+renderConnectorBoxSpec props spec = +    getConnectorBoxSpec spec props+++++ -- -- DESIGN NOTE - boxes (probably) should not use source and dest -- separators. -- ---- | Draw a stroked, rectangular box around the connector points.------ The rectangle will be inclined to the line.----connbox :: (Real u, Floating u, InterpretUnit u) -        => ConnectorProps -> ConnectorBox u-connbox props = promoteConn $ \p0 p1 -> -    connectorBoxHalfSize props >>= \sz ->-    applyLoc (drawPlacedTrail CSTROKE $ cfconnbox sz (pvec p0 p1)) p0+boxConnector :: (Floating u, Ord u, InterpretUnit u) +             => (ConnectorProps -> Point2 u -> Point2 u -> Image u a) +             -> ConnectorBoxSpec u+boxConnector mf = ConnectorBoxSpec $ \props -> +    promoteConn $ \p0 p1 -> ignoreAns $ mf props p0 p1   -conntube :: (Real u, Floating u, InterpretUnit u) -        => ConnectorProps -> ConnectorBox u-conntube props = promoteConn $ \p0 p1 -> +adaptAnaTrail :: (Real u, Floating u, Ord u, InterpretUnit u) +              => (u -> Vec2 u -> AnaTrail u) +              -> ConnectorBoxSpec u+adaptAnaTrail fn = boxConnector $ \props p0 p1 ->     connectorBoxHalfSize props >>= \sz ->-    applyLoc (drawPlacedTrail CSTROKE $ cfconntube sz (pvec p0 p1)) p0-+    let v0    = pvec p0 p1 +        v1    = v0 ^+^ avec (vdirection v0) (2*sz)+        vinit = avec (vdirection v0) (-sz)+    in applyLoc (renderAnaTrail CSTROKE $ fn sz v1) (displace vinit p0)+      --- Box connectors aren\'t especially coordinate free.---- | @v1@ is the /interior/ vector.+-- | Draw a stroked, rectangular box around the connector points. ---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-    +-- The rectangle will be inclined to the line.+--+conn_box :: (Real u, Floating u, InterpretUnit u) +        => ConnectorBoxSpec u+conn_box = adaptAnaTrail (\sz -> incline_rect (2 * sz))  --- | @v1@ is the /interior/ vector.+-- | Draw a stroked, tube around the connector points. ---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)--    +-- The tube will be inclined to the line.+--+conn_tube :: (Real u, Floating u, InterpretUnit u) +         => ConnectorBoxSpec u+conn_tube = adaptAnaTrail (\sz -> incline_tube (2 * sz)) +-- | Draw a stroked, chamfered box around the connector points.+--+-- The tube will be inclined to the line.+--+conn_chamf_box :: (Real u, Floating u, InterpretUnit u) +               => ConnectorBoxSpec u+conn_chamf_box = adaptAnaTrail (\sz -> incline_chamf_rect (2 * sz)) 

@@ -17,194 +17,85 @@ module Wumpus.Drawing.Connectors.ConnectorPaths   (  -    connline-  , connarc-  , connhdiagh-  , connvdiagv+    conn_line++  , conna_arc+  , connb_arc++  , conn_hdiagh+  , conn_vdiagv   -  , conndiagh-  , conndiagv+  , conn_diagh+  , conn_diagv -  , connhdiag-  , connvdiag+  , conn_hdiag+  , conn_vdiag -  , connabar-  , connbbar+  , conna_bar+  , connb_bar+  +  , conna_flam+  , connb_flam -  , connaright-  , connbright+  , conna_orthohbar+  , connb_orthohbar -  , connhrr-  , connrrh-  , connvrr-  , connrrv+  , conna_orthovbar+  , connb_orthovbar -  , connaloop-  , connbloop+  , conna_right+  , connb_right -  , connhbezier-  , connvbezier+  , conn_hrr+  , conn_rrh+  , conn_vrr+  , conn_rrv +  , conna_loop+  , connb_loop++  , conn_hbezier+  , conn_vbezier+   ) where +import Wumpus.Drawing.Basis.InclineTrails import Wumpus.Drawing.Connectors.Base import Wumpus.Drawing.Connectors.ConnectorProps import Wumpus.Drawing.Paths -import Wumpus.Basic.Geometry.Quadrant           -- package: wumpus-basic-import Wumpus.Basic.Kernel hiding ( promoteConn )+import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space +import Control.Applicative  -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.+-- | Build as Path as a CatTrail between two points. ---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----+catConnector :: (Floating u, Ord u, InterpretUnit u, Tolerance u) +             => (ConnectorProps -> Point2 u -> Point2 u -> Query u (CatTrail u)) +             -> ConnectorPathSpec u+catConnector mf = ConnectorPathSpec $ \props -> +    qpromoteConn $ \p0 p1 -> catTrailPath p0 <$> mf props p0 p1   +horizontally :: (Real u, Floating u) +             => (Vec2 u -> a) -> (Vec2 u -> a) -> Vec2 u -> a+horizontally rightf leftf v1 = +    case horizontalDirection $ vdirection v1 of+      RIGHTWARDS -> rightf v1+      LEFTWARDS  -> leftf v1  -- | Straight line connector. ---connline :: (Real u, Floating u, InterpretUnit u) -         => ConnectorProps -> ConnectorPathQuery u-connline props = buildConn props inlineSrc inlineDst $ \p0 p1 -> -    return $ line1 p0 p1+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ConnectorPathSpec u+conn_line = catConnector $ \_ p0 p1 -> pure $ catline $ pvec p0 p1   @@ -218,17 +109,28 @@ -- The notion of /above/ is respective to the line direction, of  -- course. -- +-- TODO - above and below versions... ---connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) -        => ConnectorProps -> ConnectorPathQuery u-connarc props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +conna_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) +          => ConnectorPathSpec u+conna_arc = connArcBody (vtriCurve CW) (vtriCurve CCW)++-- | Below version of 'conna_arc'.+--+connb_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) +          => ConnectorPathSpec u+connb_arc = connArcBody (vtriCurve CCW) (vtriCurve CW)+++connArcBody :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) +            => (u -> Vec2 u -> CatTrail u) +            -> (u -> Vec2 u -> CatTrail u) +            -> ConnectorPathSpec u+connArcBody rightf leftf = catConnector $ \props 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-        cp1     = p1 .+^ avec (pi + ang - arc_ang) hlen-    in return $ curve1 p0 cp0 cp1 p1+        h       = (0.5 * vlength v1) * (fromRadian $ tan arc_ang)+    in return $ horizontally (rightf h) (leftf h) v1    @@ -242,22 +144,14 @@ -- Horizontal /arms/ are drawn from the start and end points, a -- diagonal segment joins the arms.  -- -connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)-           => 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-      _       -> left  p0 p1 src_arm dst_arm-  where-    right p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .+^ hvec h0-                                            , p1 .-^ hvec h1, p1 ]--    left  p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .-^ hvec h0 -                                            , p1 .+^ hvec h1, p1 ]+conn_hdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)+           => ConnectorPathSpec u+conn_hdiagh = catConnector $ \props p0 p1 -> +    connectorLegs props >>= \(src_leg, dst_leg) ->+    return $ trail_hdiagh src_leg dst_leg $ pvec p0 p1  +-- probably want trail_hdiagh as a library function  -- | Vertical-diagonal-vertical connector. --@@ -270,21 +164,11 @@ -- Vertical /arms/ are drawn from the start and end points, a -- diagonal segment joins the arms.  -- -connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)-           => 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-      _       -> down p0 p1 src_arm dst_arm-  where-    up   p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .+^ vvec v0-                                           , p1 .-^ vvec v1, p1 ]--    down p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .-^ vvec v0 -                                           , p1 .+^ vvec v1, p1 ]-+conn_vdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)+            => ConnectorPathSpec u+conn_vdiagv = catConnector $ \props p0 p1 -> +    connectorLegs props >>= \(src_leg, dst_leg) ->+    return $ trail_vdiagv src_leg dst_leg $ pvec p0 p1   -- | Diagonal-horizontal connector.@@ -297,18 +181,11 @@ -- from the start point joining a horizontal arm drawn from the  -- end point -- -conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => 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-      _       -> left  p0 p1 dst_arm-  where-    right p0 p1 h1 = return $ vertexPath [ p0, p1 .-^ hvec h1, p1 ]--    left  p0 p1 h1 = return $ vertexPath [ p0, p1 .+^ hvec h1, p1 ]+conn_diagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)+           => ConnectorPathSpec u+conn_diagh = catConnector $ \props p0 p1 -> +    connectorLegs props >>= \(_, dst_leg) ->+    return $ trail_diagh dst_leg $ pvec p0 p1   -- | Diagonal-vertical connector.@@ -322,18 +199,11 @@ -- from the start point joining a vertical arm drawn from the end  -- point. -- -conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => 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-      _       -> down  p0 p1 dst_arm-  where-    up   p0 p1 v1 = return $ vertexPath [ p0, p1 .-^ vvec v1, p1 ]--    down p0 p1 v1 = return $ vertexPath [ p0, p1 .+^ vvec v1, p1 ]+conn_diagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)+           => ConnectorPathSpec u+conn_diagv = catConnector $ \props p0 p1 -> +    connectorLegs props >>= \(_, dst_leg) ->+    return $ trail_diagv dst_leg $ pvec p0 p1   @@ -347,18 +217,11 @@ -- from the start point joining a diagonal segment drawn from the  -- end point. -- -connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => 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-      _       -> left  p0 p1 src_arm-  where-    right p0 p1 h1 = return $ vertexPath [ p0, p0 .+^ hvec h1, p1 ]--    left  p0 p1 h1 = return $ vertexPath [ p0, p0 .-^ hvec h1, p1 ]+conn_hdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)+           => ConnectorPathSpec u+conn_hdiag = catConnector $ \props p0 p1 -> +    connectorLegs props >>= \(src_leg, _) ->+    return $ trail_hdiag src_leg $ pvec p0 p1   -- | Vertical-diagonal connector.@@ -372,23 +235,16 @@ -- from the start point joining a vertical segment drawn from the  -- end point. -- -connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)-          => 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-      _       -> down  p0 p1 src_arm-  where-    up   p0 p1 v1 = return $ vertexPath [ p0, p0 .+^ vvec v1, p1 ]--    down p0 p1 v1 = return $ vertexPath [ p0, p0 .-^ vvec v1, p1 ]+conn_vdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)+           => ConnectorPathSpec u+conn_vdiag = catConnector $ \props p0 p1 -> +    connectorLegs props >>= \(src_leg, _) ->+    return $ trail_vdiag src_leg $ pvec p0 p1    -- DESIGN NOTE - should the concept of /above/ and /below/ use --- quadrants?+-- ClockDirection instead? --  @@ -400,13 +256,9 @@ -- -- The bar is drawn /above/ the points. ---connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) -         => 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 ]+conna_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +          => ConnectorPathSpec u+conna_bar = connBarBody (trail_perp_bar2 CW) (trail_perp_bar2 CCW)   -- | Bar connector.@@ -417,16 +269,104 @@ -- -- The bar is drawn /below/ the points. ---connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) -         => 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 ]+connb_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +          => ConnectorPathSpec u+connb_bar = connBarBody (trail_perp_bar2 CCW) (trail_perp_bar2 CW)  +connBarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) +            => (u -> u -> Vec2 u -> CatTrail u) +            -> (u -> u -> Vec2 u -> CatTrail u) +            -> ConnectorPathSpec u+connBarBody rightf leftf = catConnector $ \props p0 p1 ->+    connectorLegs props >>= \(src, dst) ->+    return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1 +++-- | /Flam/ connector.+--+-- >    ,- '+-- >  ,-   | +-- >  |    |+-- >  o    @  +--+-- The bar is drawn /above/ the points.+--+conna_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) +           => ConnectorPathSpec u+conna_flam = connFlamBody (trail_vflam CW) (trail_vflam CCW)++-- | /Flam/ connector - bleow.+--+connb_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) +         => ConnectorPathSpec u+connb_flam = connFlamBody (trail_vflam CCW) (trail_vflam CW)  +++connFlamBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) +             => (u -> u -> Vec2 u -> CatTrail u) +             -> (u -> u -> Vec2 u -> CatTrail u) +             -> ConnectorPathSpec u+connFlamBody rightf leftf = catConnector $ \props p0 p1 ->+    connectorLegs props >>= \(src,dst) ->+    return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1+++++-- | Bar connector - always orthonormal .+--+-- >  +-- >  ,----, +-- >  |    |+-- >  o    @  +--+-- The bar is drawn /above/ the points.+--+conna_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +                => ConnectorPathSpec u+conna_orthohbar = connOrthobarBody (trail_ortho_hbar CW) (trail_ortho_hbar CCW)++-- | Bar connector orthonormal - below.+--+connb_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +                => ConnectorPathSpec u+connb_orthohbar = connOrthobarBody (trail_ortho_hbar CCW) (trail_ortho_hbar CW)++++connOrthobarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) +                 => (u -> Vec2 u -> CatTrail u)+                 -> (u -> Vec2 u -> CatTrail u)+                 -> ConnectorPathSpec u+connOrthobarBody rightf leftf = catConnector $ \props p0 p1 ->+    connectorLoopSize props >>= \looph ->+    return $ horizontally (rightf looph) (leftf looph) $ pvec p0 p1+++-- | Bar connector - always orthonormal.+--+-- >  +-- >  ,--- o +-- >  |   +-- >  '--- @  +-- > +--+-- The bar is drawn /left/ of the points.+--+conna_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +                => ConnectorPathSpec u+conna_orthovbar = connOrthobarBody (trail_ortho_vbar CW) (trail_ortho_vbar CCW)++-- | Bar connector orthonormal - right of the points.+--+connb_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) +                => ConnectorPathSpec u+connb_orthovbar = connOrthobarBody (trail_ortho_vbar CCW) (trail_ortho_vbar CW)+++ -- | Right angle connector. --  -- >  ,----@ @@ -435,11 +375,10 @@ -- -- The bar is drawn /above/ the points. ---connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) -           => 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]+conna_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) +            => ConnectorPathSpec u+conna_right = catConnector $ \_ p0 p1 ->+    return $ trail_vright $ pvec p0 p1   -- | Right angle connector.@@ -450,24 +389,15 @@ -- -- The bar is drawn /below/ the points. ---connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u) -           => 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]+connb_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) +            => ConnectorPathSpec u+connb_right = catConnector $ \_ p0 p1 -> +    return $ trail_hright $ pvec p0 p1   --- Helper  --- | Derive the direction aka. sign of an arm.----directional :: (Num u, Ord u) => u -> u -> u -> u-directional src dst arm = if src < dst then arm else negate arm-                    ----- | Connector with two horizontal segements and a joining +-- | Connector with two horizontal segments and a joining  -- vertical segment. -- -- >       ,--@@@ -475,17 +405,14 @@ -- >  o----'   -- -- The length of the first horizontal segment is the source arm --- length. The length of the final segment is the remaing +-- length. The length of the final segment is the remaining  -- horizontal distance.  ---connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) -        => 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]+conn_hrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) +         => ConnectorPathSpec u+conn_hrr = catConnector $ \props p0 p1 ->+    connectorLegs props >>= \(src_leg,_) ->+    return $ trail_hrr src_leg $ pvec p0 p1   -- | Connector with two horizontal segements and a joining @@ -495,18 +422,15 @@ -- >     | -- >  o--'   ----- The length of the final horizontal segment is the distination +-- The length of the final horizontal segment is the destination  -- arm length. The length of the initial segment is the remaining -- horizontal distance.  ---connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) -        => 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]+conn_rrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) +         => ConnectorPathSpec u+conn_rrh = catConnector $ \props p0 p1 ->+    connectorLegs props >>= \(_,dst_leg) ->+    return $ trail_rrh dst_leg $ pvec p0 p1   -- | Connector with two right angles...@@ -517,14 +441,15 @@ -- >  | -- >  o   ---connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) -        => 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]+-- The length of the first vertical segment is the source arm +-- length. The length of the final segment is the remaining +-- vertical distance. +--+conn_vrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) +         => ConnectorPathSpec u+conn_vrr = catConnector $ \props p0 p1 ->+    connectorLegs props >>= \(src_leg,_) ->+    return $ trail_vrr src_leg $ pvec p0 p1   -- | Connector with two right angles...@@ -535,15 +460,15 @@ -- >  | -- >  o   ---connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) -        => 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]-+-- The length of the final vertical segment is the destination +-- arm length. The length of the initial segment is the remaining+-- vertical distance. +--+conn_rrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) +         => ConnectorPathSpec u+conn_rrv = catConnector $ \props p0 p1 ->+    connectorLegs props >>= \(_,dst_leg) ->+    return $ trail_rrv dst_leg $ pvec p0 p1   @@ -555,9 +480,10 @@ -- -- The loop is drawn /above/ the points. ---connaloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) -          => ConnectorProps -> ConnectorPathQuery u-connaloop = loopbody id+conna_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) +           => ConnectorPathSpec u+conna_loop = connLoopBody (trail_rect_loop CW) (trail_rect_loop CCW)+    -- | Loop connector. --@@ -565,26 +491,25 @@ -- >  |         | -- >  '---------' ----- The loop is drawn /above/ the points.+-- The loop is drawn /below/ the points. ---connbloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) -          => ConnectorProps -> ConnectorPathQuery u-connbloop = loopbody negate+connb_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) +           => ConnectorPathSpec u+connb_loop = connLoopBody (trail_rect_loop CCW) (trail_rect_loop CW) --- | Looping just differs on a negate...----loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u)-         => (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-        z0  = dispParallel dst_arm ang p1-        z1  = dispPerpendicular (fn loop_len) ang z0-    in return $ vertexPath [ p0, a0, a1, z1, z0, p1 ] +connLoopBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) +             => (u -> u -> u -> Vec2 u -> CatTrail u) +             -> (u -> u -> u -> Vec2 u -> CatTrail u) +             -> ConnectorPathSpec u+connLoopBody rightf leftf = catConnector $ \props p0 p1 -> +    connectorLegs props     >>= \(src,dst) ->+    connectorLoopSize props >>= \looph ->+    return $ horizontally (rightf src dst looph) (leftf src dst looph) +           $ pvec p0 p1+++ -- | Bezier curve connector - the control points are positioned  -- horizontally respective to the source and dest. --@@ -596,17 +521,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)-            => ConnectorProps -> ConnectorPathQuery u-connhbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +conn_hbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)+             => ConnectorPathSpec u+conn_hbezier = ConnectorPathSpec $ \props -> +    qpromoteConn $ \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-      _       -> left  p0 p1 src_arm dst_arm+    case horizontalDirection $ vdirection $ pvec p0 p1 of+      RIGHTWARDS -> right p0 p1 src_arm dst_arm+      _          -> left  p0 p1 src_arm dst_arm   where     right p0 p1 h0 h1 = return $ curve1 p0 (p0 .+^ hvec h0) (p1 .-^ hvec h1) p1 @@ -625,20 +547,16 @@ -- 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)-            => ConnectorProps -> ConnectorPathQuery u-connvbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +conn_vbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)+             => ConnectorPathSpec u+conn_vbezier = ConnectorPathSpec $ \props -> +    qpromoteConn $ \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-      _       -> down p0 p1 src_arm dst_arm+      case verticalDirection $ vdirection $ pvec p0 p1 of+        UPWARDS -> up   p0 p1 src_arm dst_arm+        _       -> down p0 p1 src_arm dst_arm   where     up   p0 p1 v0 v1 = return $ curve1 p0 (p0 .+^ vvec v0) (p1 .-^ vvec v1) p1-     down p0 p1 v0 v1 = return $ curve1 p0 (p0 .-^ vvec v0) (p1 .+^ vvec v1) p1  

@@ -25,6 +25,7 @@   , connectorSrcSpace   , connectorDstSpace   , connectorArms+  , connectorLegs   , connectorLoopSize   , connectorBoxHalfSize  @@ -131,6 +132,15 @@ connectorArms props =      (\sz -> ( uconvert1 sz $ conn_src_arm props             , uconvert1 sz $ conn_dst_arm props) )+        <$> pointSize++-- | /legs/ are Arms + spacing.+--+connectorLegs :: (DrawingCtxM m, InterpretUnit u) +              => ConnectorProps -> m (u,u)+connectorLegs props = +    (\sz -> ( uconvert1 sz $ conn_src_space props + conn_src_arm props+            , uconvert1 sz $ conn_dst_space props + conn_dst_arm props ) )         <$> pointSize  

@@ -65,9 +65,9 @@  import Wumpus.Drawing.Dots.SimpleDots ( MarkSize ) import qualified Wumpus.Drawing.Dots.SimpleDots as SD+import Wumpus.Drawing.Paths.Intersection -import Wumpus.Basic.Geometry                    -- package: wumpus-basic-import Wumpus.Basic.Kernel               +import Wumpus.Basic.Kernel                      -- package: wumpus-basic            import Wumpus.Core                              -- package: wumpus-core @@ -141,17 +141,7 @@ rectCardinal hw _  ctr WEST         = ctr .+^ (hvec (-hw))  rectCardinal hw hh ctr NORTH_WEST   = ctr .+^ (vec  (-hw)  hh)  -polyCardinal :: Floating u => (Radian -> Point2 u) -> Cardinal -> Point2 u-polyCardinal f NORTH                = f (0.5  * pi)-polyCardinal f NORTH_EAST           = f (0.25 * pi) -polyCardinal f EAST                 = f 0 -polyCardinal f SOUTH_EAST           = f (1.75 * pi) -polyCardinal f SOUTH                = f (1.5  * pi) -polyCardinal f SOUTH_WEST           = f (1.25 * pi)-polyCardinal f WEST                 = f pi -polyCardinal f NORTH_WEST           = f (0.75 * pi)  - -- | All anchors are the center! -- zeroAnchor :: Point2 u -> DotAnchor u@@ -161,15 +151,27 @@               , cardinal_anchor = const ctr }  -rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u+rectangleAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) +                => u -> u -> Point2 u -> DotAnchor u rectangleAnchor hw hh ctr =      DotAnchor { center_anchor   = ctr               , radial_anchor   = fn                 , cardinal_anchor = rectCardinal hw hh ctr }   where-    fn theta =  displace (rectRadialVector hw hh theta) ctr+    fn theta = let mb_v1 = rectangleRadialIntersect (2*hw) (2*hh) theta+               in displace (maybe zeroVec id  mb_v1) ctr +triangleAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) +               => u -> Point2 u -> DotAnchor u+triangleAnchor hh ctr = +    DotAnchor { center_anchor   = ctr+              , radial_anchor   = fn  +              , cardinal_anchor = radialCardinal hh ctr }+  where+    fn theta = let mb_v1 = isoscelesTriangleRadialIntersect (2*hh) (2*hh) theta+               in  displace (maybe zeroVec id mb_v1) ctr + circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u circleAnchor rad ctr =      DotAnchor { center_anchor   = ctr@@ -179,19 +181,9 @@     fn theta = displace (avec theta rad) ctr  -polygonAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) -              => [Point2 u] -> Point2 u -> DotAnchor u-polygonAnchor ps ctr = -    DotAnchor { center_anchor   = ctr-              , radial_anchor   = fn  -              , cardinal_anchor = polyCardinal fn }-  where-    fn theta =  maybe ctr id $ findIntersect ctr theta -                             $ polygonLineSegments ps ---bboxRectAnchor  :: (Real u, Floating u) => BoundingBox u -> DotAnchor u+bboxRectAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) +               => BoundingBox u -> DotAnchor u bboxRectAnchor (BBox bl@(P2 x1 y1) (P2 x2 y2)) =    let hw = 0.5 * (x2 - x1)        hh = 0.5 * (y2 - y1)@@ -201,7 +193,7 @@ zeroLDO :: InterpretUnit u => LocQuery u (DotAnchor u) zeroLDO = qpromoteLoc $ \pt -> return $ zeroAnchor pt -rectangleLDO :: (Real u, Floating u, InterpretUnit u) +rectangleLDO :: (Real u, Floating u, InterpretUnit u, Tolerance u)               => MarkSize -> MarkSize -> LocQuery u (DotAnchor u) rectangleLDO w h = qpromoteLoc $ \pt ->      (\uw uh -> rectangleAnchor (uw*0.5) (uh*0.5) pt) @@ -224,12 +216,8 @@ triangleLDO :: (Real u, Floating u, Tolerance u, InterpretUnit u)              => MarkSize -> LocQuery u (DotAnchor u) triangleLDO h = qpromoteLoc $ \pt -> -    uconvertCtx1 h >>= \uh -> -    let alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices uh-    in (\ps -> polygonAnchor ps pt) -         <$> qapplyLoc (placedTrailPoints alg) pt-  where-    fn3 (a,b,c) = [a,b,c]+    (\uh -> triangleAnchor (uh*0.5) pt) +      <$> uconvertCtx1 h   --------------------------------------------------------------------------------@@ -260,7 +248,8 @@ largeCirc = intoLocImage (circleLDO 1.00) SD.largeCirc  -dotChar :: (Floating u, Real u, InterpretUnit u) => Char -> DotLocImage u+dotChar :: (Floating u, Real u, InterpretUnit u, Tolerance u) +        => Char -> DotLocImage u dotChar ch = dotText [ch]  @@ -271,7 +260,8 @@ --  -dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u +dotText :: (Floating u, Real u, InterpretUnit u, Tolerance u) +        => String -> DotLocImage u  dotText ss =      fmap bboxRectAnchor $ runPosObjectBBox CENTER $ posText ss @@ -307,7 +297,8 @@ dotDisk = intoLocImage (circleLDO 0.5) SD.dotDisk  -dotSquare :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+dotSquare :: (Floating u, Real u, InterpretUnit u, Tolerance u) +          => DotLocImage u dotSquare = intoLocImage (rectangleLDO 1 1) SD.dotSquare  

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Dots.SimpleDots--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -67,9 +67,9 @@    ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Basis.Symbols -import Wumpus.Basic.Geometry                    -- package: wumpus-basic import Wumpus.Basic.Kernel          import Wumpus.Core                              -- package: wumpus-core@@ -128,13 +128,13 @@ -- | Stroked disk (circle) - radius 0.25 MarkSize. -- smallCirc :: InterpretUnit u => LocGraphic u-smallCirc = umark $ ocircle 0.25+smallCirc = umark $ scircle 0.25   -- | Stroked disk (circle) - radius 1.0 MarkSize. -- largeCirc :: InterpretUnit u => LocGraphic u-largeCirc = umark $ ocircle 1+largeCirc = umark $ scircle 1   -- possibly:@@ -197,15 +197,15 @@   dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-dotDiamond = umark $ drawPlacedTrail CSTROKE (diamondTrail 0.5 0.66)+dotDiamond = umark $ renderAnaTrail CSTROKE (diamondTrail 0.5 0.66)  dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-dotFDiamond = umark $ drawPlacedTrail CFILL (diamondTrail 0.5 0.66)+dotFDiamond = umark $ renderAnaTrail CFILL (diamondTrail 0.5 0.66)    dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u-dotBDiamond = umark $ drawPlacedTrail CFILL_STROKE (diamondTrail 0.5 0.66)+dotBDiamond = umark $ renderAnaTrail CFILL_STROKE (diamondTrail 0.5 0.66)   -- | Note disk is filled.@@ -216,11 +216,11 @@   dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u-dotSquare = umark $ drawPlacedTrail CSTROKE (rectangleTrail 1 1)+dotSquare = umark $ renderAnaTrail CSTROKE (rectangleTrail 1 1)   dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u-dotCircle = umark $ ocircle 0.5+dotCircle = umark $ scircle 0.5   dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u@@ -229,7 +229,7 @@   dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u-dotPentagon = umark $ drawPlacedTrail CSTROKE (polygonTrail 5 0.5)+dotPentagon = umark $ renderAnaTrail CSTROKE (polygonTrail 5 0.5)    @@ -241,7 +241,7 @@           => u -> LocGraphic u starLines hh = promoteLoc $ \ctr ->     let alg = polygonTrail 5 hh-    in liftQuery (qapplyLoc (placedTrailPoints alg) ctr) >>= \ps -> +    in liftQuery (qapplyLoc (anaTrailPoints alg) ctr) >>= \ps ->         step $ map (fn ctr) ps   where     fn p0 p1    = straightLine p0 p1@@ -278,7 +278,4 @@   dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u-dotTriangle = umark $ drawPlacedTrail CSTROKE alg -  where-    alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices 1-    fn3 = \(a,b,c) -> [a,b,c]+dotTriangle = umark $ renderAnaTrail CSTROKE $ isosceles_triangle_trail 1 1

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Extras.Axes--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -37,11 +37,11 @@  -- | Simple orthonormal axes using snap grid units. ---orthontAxes :: (Real u, Floating u, InterpretUnit u)+orthontAxes :: (Real u, Floating u, InterpretUnit u, Tolerance u)             => (Int,Int) -> (Int,Int) -> LocGraphic u orthontAxes (xl,xr) (yl,yr) = promoteLoc $ \(P2 x y) ->      snapmove (1,1) >>= \(V2 uw uh) ->-    let conn1 = rightArrow barb45 connline+    let conn1 = ignoreAns conn_line         xPtl  = P2 (x - (uw * fromIntegral xl)) y         xPtr  = P2 (x + (uw * fromIntegral xr)) y         yPtl  = P2 x (y - (uh * fromIntegral yl))@@ -51,24 +51,25 @@   -horizontalLabels :: (Num a, Fractional u, InterpretUnit u) +horizontalLabels :: (Num a, Show a, Fractional u, InterpretUnit u)                   => RectAddress -> [a] -> LocGraphic u  horizontalLabels addr ns = -    snapmove (1,1) >>= \(V2 uw _) -> ignoreAns (runChainH uw $ mapM mf ns)+    snapmove (1,1) >>= \(V2 uw _) -> ignoreAns (distribH uw $ map mf ns)   where-    mf n = chain1 $ runPosObject addr $ posTextUpright $ show n+    mf n = runPosObject addr $ posTextUpright $ show n  -verticalLabels :: (Num a, Fractional u, InterpretUnit u) +verticalLabels :: (Num a, Show a, Fractional u, InterpretUnit u)                 => RectAddress -> [a] -> LocGraphic u  verticalLabels addr ns = -    snapmove (1,1) >>= \(V2 _ uh) -> ignoreAns (runChainV uh $ mapM mf ns)+    snapmove (1,1) >>= \(V2 _ uh) -> ignoreAns (distribV uh $ map mf ns)   where-    mf n = chain1 $ runPosObject addr $ posTextUpright $ show n+    mf n = runPosObject addr $ posTextUpright $ show n   --- Cf. Parsec\'s Token module...+-- Cf. Parsec\'s Token module - remake with same name... ---connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u-connline = C.connline default_connector_props+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conn_line = rightArrowConnector default_connector_props C.conn_line barb45

@@ -16,8 +16,10 @@  module Wumpus.Drawing.Extras.Loop   ( -    loop-  , loopPoints++    loopPath+  , loopTrail+   ) where  @@ -31,33 +33,28 @@ import Data.AffineSpace                         -- package: vector-space  --- TODO - Loop is a decoration not a connector.--- It should probably have the same signature as wedge / arc.+import Data.Monoid --- | Generate a loop - suitable for decorating a circle.------ The radius and the (implicit) start point are the center and --- radius of the initial circle not the loop itself.----loop :: (Real u, Floating u, InterpretUnit u, Tolerance u) -      => u -> Point2 u -> Radian -> Query u (AbsPath u)-loop zradius zctr ang = return $ curvePath $ loopPoints zradius zctr ang  +loopPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) +      => u -> Point2 u -> Radian -> AbsPath u+loopPath zradius ctr incl = anaTrailPath ctr $ loopTrail zradius incl --- Should be able to use trig to get a loop suitable for--- decorating rectangles (provided the start-to-end arc is smaller--- than the side length   +-- This is a legacy definition updated to use Trails, hence it is +-- not so clear. --- | Note - intermediate names and quadrants represent a loop --- drawn upwards.--- -loopPoints :: (Real u, Floating u) => u -> Point2 u -> Radian -> [Point2 u]-loopPoints circ_radius circ_ctr incl = -    [ startl, cp1, cp2, kitel, cp3, cp4, top, cp5, cp6, kiter, cp7, cp8, startr ]+loopTrail :: (Real u, Floating u) => u -> Radian -> AnaTrail u+loopTrail circ_radius incl = +    anaCatTrail (pvec zeroPt startl) $ +       mconcat [ diffCurve startl cp1 cp2 kitel+               , diffCurve kitel  cp3 cp4 top+               , diffCurve top    cp5 cp6 kiter+               , diffCurve kiter  cp7 cp8 startr+               ]   where     hw          = 1.25  * circ_radius     height      = 3.8   * circ_radius@@ -71,12 +68,12 @@     top_right   = negate $ 0.8 * circ_radius     top_left    = 0.8 * circ_radius -    top         = dispParallel height incl circ_ctr-    kiter       = dispOrtho (V2 hminor (-hw)) incl circ_ctr-    kitel       = dispOrtho (V2 hminor (hw) ) incl circ_ctr+    top         = dispParallel height incl zeroPt+    kiter       = dispOrtho hminor (-hw) incl zeroPt+    kitel       = dispOrtho hminor   hw  incl zeroPt     -    startr      = circ_ctr .+^ avec (circularModulo $ incl - theta) circ_radius-    startl      = circ_ctr .+^ avec (circularModulo $ incl + theta) circ_radius+    startr      = zeroPt .+^ avec (circularModulo $ incl - theta) circ_radius+    startl      = zeroPt .+^ avec (circularModulo $ incl + theta) circ_radius      -- quadrant III     cp1         = startl .+^ end_vec @@ -93,3 +90,4 @@     -- quadrant IV      cp7         = dispParallel minor_down incl kiter     cp8         = startr .+^ start_vec+

@@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Paths.Base--- Copyright   :  (c) Stephen Tetley 2010-2011+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -14,6 +14,15 @@ -- -- Absolute path type - this should be more amenable for building  -- complex drawings than the PrimPath type in Wumpus-Core.+--+-- Note - there is no concatenation (i.e. no Monoid instance),+-- this is because concatenating \*\* absolute \*\* paths has no +-- obvious interpretation - draw a join between the paths, move+-- the second path to start where the first ends...+--+-- Use @CatTrail@ from Wumpus-Basic if you need a relative-path +-- like object that supports concatenation, then convert it in a +-- final step to an @AbsPath@. --  -------------------------------------------------------------------------------- @@ -36,7 +45,7 @@   , vectorPath   , vectorPathTheta -  , placedTrailPath+  , anaTrailPath   , catTrailPath    -- * Queries@@ -53,19 +62,20 @@   -- * Conversion   , toPrimPath -  , drawPath-  , drawPath_+  , renderPath+  , renderPath_    -- * Shortening   , shortenPath   , shortenL   , shortenR -  -- * Tips and direction+  -- * Tips and inclination   , tipL   , tipR-  , directionL-  , directionR+  , inclinationL+  , inclinationR+   , isBezierL   , isBezierR @@ -94,15 +104,18 @@   , roundExterior   , roundInterior +  , deBezier+  , pathMajorPoints+  , pathAllPoints+   -- * Path division   , pathdiv     ) where -+import Wumpus.Drawing.Basis.BezierCurve -import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl                                    , ViewR(..), viewr, cons, snoc )@@ -210,17 +223,88 @@ -------------------------------------------------------------------------------- -- Translate --- Translate is cheap on AbsPath +-- | AbsPathSegments are build from vectors so they do not+-- respond to translation.+--+instance Num u => Translate (AbsPathSeg u) where+  translate _ _ s1 = s1+++instance (Floating u, Ord u, Tolerance u) => Scale (AbsPathSeg u) where+  scale sx sy (AbsLineSeg _ v1)        = absLineSeg $ scale sx sy v1+  scale sx sy (AbsCurveSeg _ v1 v2 v3) = +    absCurveSeg (scale sx sy v1) (scale sx sy v2) (scale sx sy v3)++++-- | Translate is cheap on AbsPath it just moves the start and+-- end points. The path itself is otherwise built from vectors+-- so it doesn\'t respond to translation (translate == id).+-- 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)   +-- | This is expensive on paths - needs a traversal.+--+instance (Floating u, Ord u, Tolerance u) => Scale (AbsPath u) where+  scale sx sy = rebuildPath (scale sx sy) (scale sx sy)+                            (\v1 v2 v3 -> ( scale sx sy v1+                                          , scale sx sy v2+                                          , scale sx sy v3 ))+++-- | This is expensive on paths - needs a traversal.+--+instance (Real u, Floating u, Ord u, Tolerance u) => Rotate (AbsPath u) where+  rotate ang = rebuildPath (rotate ang) (rotate ang)+                           (\v1 v2 v3 -> ( rotate ang v1+                                         , rotate ang v2+                                         , rotate ang v3 ))++-- | This is expensive on paths - needs a traversal.+--+instance (Real u, Floating u, Ord u, Tolerance u) => RotateAbout (AbsPath u) where+  rotateAbout ang pt = +    rebuildPath (rotateAbout ang pt) (rotateAbout ang pt)+                (\v1 v2 v3 -> ( rotateAbout ang pt v1+                              , rotateAbout ang pt v2+                              , rotateAbout ang pt v3 ))+++++rebuildPath :: (Floating u, Ord u, Tolerance u) +            => (Point2 u -> Point2 u) +            -> (Vec2 u -> Vec2 u) +            -> (Vec2 u -> Vec2 u -> Vec2 u -> (Vec2 u, Vec2 u, Vec2 u))+            -> AbsPath u +            -> AbsPath u+rebuildPath pointf linef curvef (AbsPath _ sp segs _) = +    step (emptyPath $ pointf sp) (viewl segs)+  where+    step ac EmptyL                         = ac++    step ac (AbsLineSeg _ v1 :< xs)        = +      step (snocLine ac $ linef v1) (viewl xs) ++    step ac (AbsCurveSeg _ v1 v2 v3 :< xs) = +      step (snocCurve ac $ curvef v1 v2 v3) (viewl xs) + -------------------------------------------------------------------------------- -- Construction +absLineSeg :: Floating u => Vec2 u -> AbsPathSeg u+absLineSeg v1 = AbsLineSeg (vlength v1) v1++absCurveSeg :: (Floating u, Ord u, Tolerance u) +            => Vec2 u -> Vec2 u -> Vec2 u -> AbsPathSeg u+absCurveSeg v1 v2 v3 = +    AbsCurveSeg (bezierLength $ vbezierCurve v1 v2 v3 zeroPt) v1 v2 v3+ -- | Create the empty path. --  -- Note - an absolute path needs /locating/ and cannot be built @@ -237,10 +321,9 @@ -- supplied points. -- line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u -line1 p0 p1 = AbsPath len p0 (JL.one $ AbsLineSeg len v1) p1+line1 p0 p1 = AbsPath len p0 (JL.one s1) p1   where-    v1  = pvec p0 p1-    len = vlength v1+    s1@(AbsLineSeg len _) = absLineSeg $ pvec p0 p1  -- | Create an absolute path from a single cubic Bezier curve. --@@ -320,10 +403,10 @@ 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+anaTrailPath :: (Floating u, Ord u, Tolerance u) +             => Point2 u -> AnaTrail u -> AbsPath u+anaTrailPath pt trl = +    let (v1,ss) = destrAnaTrail trl in step (emptyPath $ pt .+^ v1) ss   where     step ac []                   = ac     step ac (TLine v1:xs)        = step (ac `snocLine` v1) xs@@ -468,15 +551,15 @@      -drawPath :: InterpretUnit u +renderPath :: InterpretUnit u           => PathMode -> AbsPath u -> Image u (AbsPath u)-drawPath mode rp = replaceAns rp $ +renderPath mode rp = replaceAns rp $      liftQuery (toPrimPath rp) >>= dcPath mode  -drawPath_ :: InterpretUnit u +renderPath_ :: InterpretUnit u            => PathMode -> AbsPath u -> Graphic u-drawPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode+renderPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode   -- | Turn a Path into an ordinary PrimPath.@@ -552,7 +635,7 @@             => u -> Point2 u -> AbsPathSeg u -> (Point2 u, AbsPathSeg u) shortenSegL n sp (AbsLineSeg  u v1)        =      let v2  = shortenVec n v1 -        sp' = sp .+^ (v1 ^-^ v2)+        sp' = sp .+^ avec (vdirection v1) n     in (sp', AbsLineSeg  (u-n) v2)  shortenSegL n sp (AbsCurveSeg u v1 v2 v3)  = @@ -586,7 +669,7 @@     | otherwise               = step n (viewr segs) endpt   where     step _ EmptyR    _  = AbsPath 0 sp mempty sp -    step d (se :> e) ep = let z   = segmentLength e +    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@@ -606,7 +689,7 @@             => u -> AbsPathSeg u -> Point2 u -> (AbsPathSeg u, Point2 u) shortenSegR n (AbsLineSeg u v1)        ep =      let v2  = shortenVec n v1 -        ep' = ep .-^ (v1 ^+^ v2)+        ep' = ep .-^ avec (vdirection v1) n     in (AbsLineSeg (u-n) v2, ep')  shortenSegR n (AbsCurveSeg u v1 v2 v3) ep = @@ -636,24 +719,28 @@ -------------------------------------------------------------------------------- -- 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+inclinationL :: (Real u, Floating u) => AbsPath u -> Radian+inclinationL (AbsPath _ _ se _)  = step $ viewl se   where-    step (AbsLineSeg  _ v1 :< _)       = vdirection $ negateV v1-    step (AbsCurveSeg _ v1 _  _  :< _) = vdirection $ negateV v1+    step (AbsLineSeg  _ v1 :< _)       = vdirection v1+    step (AbsCurveSeg _ v1 _  _  :< _) = vdirection 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+inclinationR :: (Real u, Floating u) => AbsPath u -> Radian+inclinationR (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? --@@ -682,7 +769,7 @@ 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)+    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, inclinationR pa1)  -- Just the midway point. --@@ -691,14 +778,14 @@   atstart :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)-atstart pa@(AbsPath _ sp _ _) = (sp, directionL pa)+atstart pa@(AbsPath _ sp _ _) = (sp, inclinationL 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 pa@(AbsPath _ _ _ ep) = (ep, inclinationR pa)    atend_ :: AbsPath u -> Point2 u@@ -857,7 +944,7 @@ -- -- 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 +-- straight line joins are rounded, joins to or from Bezier  -- curves are not rounded. --  -- Caution - all path segments are expected to be longer than@@ -896,7 +983,8 @@     base_vec = tv1 ^+^ tv2     bw       = vlength base_vec     h        = sqrt $ pow2 du - (pow2 $ 0.5 * bw)-    tcurve   = tricurve bw (-h) (vdirection base_vec)+    clockd   = clockDirection v1 v2+    tcurve   = triCurve clockd bw (-h) (vdirection base_vec)          -- note the (-h) in tricurve is wrong, we need to account      -- for CCW or CW properly...@@ -946,6 +1034,54 @@      step1 _  _                 []                 =        error "roundExteriorCat - unreachable 2."+++-- | Redraw an 'AbsPath' replacing the Bezier curves with three +-- lines along the control vectors.+--+deBezier :: Floating u => AbsPath u -> AbsPath u+deBezier (AbsPath _ sp segs _) = +    step (emptyPath sp) (viewl segs)+  where+    step ac EmptyL                         = ac++    step ac (AbsLineSeg _ v1 :< xs)        = +      step (ac `snocLine` v1) (viewl xs) ++    step ac (AbsCurveSeg _ v1 v2 v3 :< xs) = +      step (ac `snocLine` v1 `snocLine` v2 `snocLine` v3) (viewl xs) ++-- | This does not extract the control points of Bezier curves.+-- +pathMajorPoints :: Num u => AbsPath u -> [Point2 u]+pathMajorPoints (AbsPath _ sp segs _) = sp : step sp (viewl segs)+  where+    step _  EmptyL = []++    step pt (AbsLineSeg _ v1 :< xs)        = +      let p1 = pt .+^ v1 in p1 : step p1 (viewl xs) ++    step pt (AbsCurveSeg _ v1 v2 v3 :< xs) = +      let p1 = pt .+^ v1 in p1 : step (p1 .+^ (v2 ^+^ v3)) (viewl xs) +    ++-- | This extracts the control points of Bezier curves.+-- +pathAllPoints :: Num u => AbsPath u -> [Point2 u]+pathAllPoints (AbsPath _ sp segs _) = sp : step sp (viewl segs)+  where+    step _  EmptyL                         = []+    +    step pt (AbsLineSeg _ v1 :< xs)        = +      let p1 = pt .+^ v1 in p1 : step p1 (viewl xs) ++    step pt (AbsCurveSeg _ v1 v2 v3 :< xs) = +      let p1 = pt .+^ v1 +          p2 = p1 .+^ v2+          p3 = p2 .+^ v3+      in p1 : p2 : p3 : step p3 (viewl xs) ++  -------------------------------------------------------------------------------- -- Path division

@@ -0,0 +1,61 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.Illustrate+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Illustrate a path - show the construction of its Bezier curves.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.Illustrate+  ( ++    path_as_control_box+  , path_with_control_points+    +  ) where++import Wumpus.Drawing.Paths.Base++import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Colour+import Data.Monoid++++grey1 :: RGBi+grey1 = RGBi 200 200 200++-- | Illustrate the control points as a /boxed/ path - Bezier +-- curves are replaced with straight lines spanning the +-- control points.+--+path_as_control_box :: (Floating u, InterpretUnit u) => AbsPath u -> Graphic u+path_as_control_box path1 = pic1 `mappend` pic2+  where+    pic1  = localize (set_line_width 8 . stroke_colour grey1) $+              renderPath_ OSTROKE path1+    pic2  = localize (set_line_width 1 . stroke_colour black) $+              renderPath_ OSTROKE $ deBezier path1+++path_with_control_points :: (Floating u, InterpretUnit u) => AbsPath u -> Graphic u+path_with_control_points path1 = pic1 `mappend` pic2+  where+    pic1  = localize (fill_colour grey1) $+              mconcat $ map (disk1 `at`) $ pathAllPoints path1++    pic2  = localize (set_line_width 1 . stroke_colour black) $+              renderPath_ OSTROKE path1++    disk1 = dcDisk DRAW_FILL 3+

@@ -0,0 +1,318 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.Intersection+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Intersection of Paths with (infinite) lines.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.Intersection+  ( ++    Line(..)+  , inclinedLine+  , vectorLine+  , Ray(..)+  , inclinedRay++  , lineLineIntersection+  , linePathIntersection+  , linePathSegmentIntersection+  , rayPathIntersection+  , rayPathSegmentIntersection++  , rectangleRadialIntersect+  , isoscelesTriangleRadialIntersect++  ) where++import Wumpus.Drawing.Basis.BezierCurve+import Wumpus.Drawing.Basis.ShapeTrails+import Wumpus.Drawing.Paths.Base++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++--------------------------------------------------------------------------------+++--+-- Private types - LineEquation, 2x2 matrix and bezier curve.+--+-- Although these types are /general/ exposing them just leads +-- to a bloated API.+--+-- If these types are fund to be more useful - they can go into +-- @Drawing.Basis@.+--+++-- | Line in equational form, i.e. @Ax + By + C = 0@.+--+data LineEquation u = LineEquation +      { _line_eqn_A :: !u+      , _line_eqn_B :: !u+      , _line_eqn_C :: !u +      }+  deriving (Eq,Show)++type instance DUnit (LineEquation u) = u+++-- | 'lineEquation' : @ point1 * point2 -> LineEquation @+-- +-- Construct a line in equational form bisecting the supplied +-- points.+--+lineEquation :: Num u => Point2 u -> Point2 u -> LineEquation u+lineEquation (P2 x1 y1) (P2 x2 y2) = LineEquation a b c +  where+    a = y1 - y2+    b = x2 - x1+    c = (x1*y2) - (x2*y1)++-- | 2x2 matrix, considered to be in row-major form.+-- +-- > (M2'2 a b+-- >       c d)+--+-- ++data Matrix2'2 u = M2'2 !u !u   !u !u+  deriving (Eq)++type instance DUnit (Matrix2'2 u) = u+++-- | Determinant of a 2x2 matrix.+--+det2'2 :: Num u => Matrix2'2 u -> u+det2'2 (M2'2 a b c d) = a*d - b*c++++++--------------------------------------------------------------------------------++-- | Infinite line represented by two points.+--+data Line u = Line (Point2 u) (Point2 u)+  deriving (Eq,Show)++type instance DUnit (Line u) = u++++-- | 'inclinedLine' : @ point * ang -> Line @+--+++-- | Make an infinite line passing through the supplied point +-- inclined by @ang@.+--+inclinedLine :: Floating u => Point2 u -> Radian -> Line u+inclinedLine radial_ogin ang = Line radial_ogin (radial_ogin .+^ avec ang 100)++vectorLine :: Num u => Vec2 u -> Point2 u -> Line u+vectorLine v1 p0 = Line p0 (p0 .+^ v1)+++-- | A 'Ray' extends from the first point, through the second to+-- infinity.+--+-- ('Line' extends to infinity in both directions.+--+data Ray u = Ray (Point2 u) (Point2 u) +  deriving (Eq,Show)++type instance DUnit (Ray u) = u+++-- | Make an infinite ray starting from the supplied point +-- inclined by @ang@.+--+inclinedRay :: Floating u => Point2 u -> Radian -> Ray u+inclinedRay ray_ogin ang = Ray ray_ogin (ray_ogin .+^ avec ang 100)+  +++++pointOnLineSeg :: (Real u, Floating u, Ord u, Tolerance u) +               => Point2 u -> (Point2 u, Point2 u) -> Bool+pointOnLineSeg pt (p0,p1) +    | pt == p0 || pt == p1 = True+    | otherwise            = +        vdirection v1 == vdirection v0 && vlength v1 `tLTE`  vlength v0+  where+    v0 = pvec p0 p1+    v1 = pvec p0 pt+                 ++-- | 'interLineLine' : @ line1 * line2 -> Maybe Point @+-- +-- Find the intersection of two lines, if there is one. +--+-- Lines are infinite they are represented by points on them, +-- they are not line segments.+--+-- An answer of @Nothing@ may indicate either the lines coincide+-- or the are parallel.+--+lineLineIntersection :: (Fractional u, Ord u, Tolerance u)+                     => Line u -> Line u -> Maybe (Point2 u)+lineLineIntersection (Line p1 p2) (Line q1 q2) = +    if det_co `tEQ` 0 then Nothing +                      else Just $ P2 (det_xm / det_co) (det_ym / det_co)+  where+    -- Ax + By + C = 0+    LineEquation a1 b1 c1 = lineEquation p1 p2+    LineEquation a2 b2 c2 = lineEquation q1 q2++    coeffM                = M2'2 a1 b1  a2 b2+    det_co                = det2'2 coeffM++    xM                    = M2'2  (negate c1) b1  (negate c2) b2+    det_xm                = det2'2 xM++    yM                    = M2'2  a1 (negate c1) a2 (negate c2)+    det_ym                = det2'2 yM+++linePathIntersection :: (Real u, Floating u, Ord u, Tolerance u) +                     => Line u -> AbsPath u -> Maybe (Point2 u)+linePathIntersection ln = step . pathViewL+  where+    step EmptyPathL = Nothing+    step (a :<< bs) = let ans = linePathSegmentIntersection ln a+                      in case ans of+                         Nothing -> step (pathViewL bs)+                         _       -> ans++linePathSegmentIntersection :: (Real u, Floating u, Ord u, Tolerance u) +                            => Line u -> PathSegment u -> Maybe (Point2 u)+linePathSegmentIntersection ln1 (LineSeg _ p0 p1)        = +    mbWithin p0 p1 $ lineLineIntersection ln1 (Line p0 p1)++linePathSegmentIntersection (Line pa pb) (CurveSeg _ p0 p1 p2 p3) = +    lineEqnCurveIntersection (lineEquation pa pb) (BezierCurve p0 p1 p2 p3)+++mbWithin :: (Real u, Floating u, Ord u, Tolerance u) +         => Point2 u -> Point2 u -> Maybe (Point2 u) -> Maybe (Point2 u)+mbWithin p0 p1 mb = mb >>= \pt -> +    if pointOnLineSeg pt (p0,p1) then Just pt else Nothing++lineEqnCurveIntersection :: (Floating u, Ord u, Tolerance u) +                         => LineEquation u -> BezierCurve u -> Maybe (Point2 u)+lineEqnCurveIntersection eqnline c0 = step c0+  where+    step c  = case cut eqnline c of+                Left pt     -> Just pt      -- cut at start or end+                Right False -> Nothing+                Right True  -> let (a,b) = subdivide c+                               in case step a of+                                   Just pt -> Just pt+                                   Nothing -> step b+++rayPathIntersection :: (Real u, Floating u, Ord u, Tolerance u) +                    => Ray u -> AbsPath u -> Maybe (Point2 u)+rayPathIntersection ry = step . pathViewL+  where+    step EmptyPathL = Nothing+    step (a :<< bs) = let ans = rayPathSegmentIntersection ry a+                      in case ans of+                         Nothing -> step (pathViewL bs)+                         _       -> ans++rayPathSegmentIntersection :: (Real u, Floating u, Ord u, Tolerance u) +                           => Ray u -> PathSegment u -> Maybe (Point2 u)+rayPathSegmentIntersection (Ray p0 p1) seg = +    test =<< linePathSegmentIntersection (Line p0 p1) seg+  where+    test pt = if vdirection (pvec p0 p1) == vdirection (pvec p0 pt)+              then Just pt else Nothing+ +-- | Is the curve cut by the line? +--+-- The curve might cut at the start or end points - which is good+-- as it saves performing a subdivision, but it makes the return +-- type a bit involved.+--+cut :: (Floating u , Ord u, Tolerance u)+    => LineEquation u -> BezierCurve u -> Either (Point2 u) Bool+cut eqnline (BezierCurve p0 p1 p2 p3) = +    if d0 `tEQ` 0 then Left p0 else+    if d3 `tEQ` 0 then Left p3 else+    let ds = [d0,d1,d2,d3] in Right $ not $ all pve ds || all nve ds+  where+    pve = (>= 0)+    nve = (< 0)+    d0  = pointLineDistance p0 eqnline +    d1  = pointLineDistance p1 eqnline +    d2  = pointLineDistance p2 eqnline +    d3  = pointLineDistance p3 eqnline +++++-- | 'pointLineDistance' : @ point -> line -> Distance @+--+-- Find the distance from a point to a line in equational form+-- using this formula:+-- +-- > P(u,v) +-- > L: Ax + By + C = 0+-- >+-- > (A*u) + (B*v) + C +-- > -----------------+-- > sqrt $ (A^2) +(B^2)+--+-- A positive distance indicates the point is above the line, +-- negative indicates below.+--+pointLineDistance :: Floating u => Point2 u -> LineEquation u -> u+pointLineDistance (P2 u v) (LineEquation a b c) = +    ((a*u) + (b*v) + c) / base+  where+    base = sqrt $ (a^two) + (b^two)+    two  :: Integer+    two  = 2+++--------------------------------------------------------------------------------+-- Intersections on common shapes++-- | Answer is vector from center.+--+rectangleRadialIntersect :: (Real u, Floating u, InterpretUnit u, Tolerance u) +                         => u -> u -> Radian -> Maybe (Vec2 u) +rectangleRadialIntersect w h ang = +    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp +  where+    rp = anaTrailPath zeroPt $ rectangle_trail w h++++-- | Answer is vector from centroid.+--+isoscelesTriangleRadialIntersect :: (Real u, Floating u+                                    , InterpretUnit u, Tolerance u) +                                 => u -> u -> Radian -> Maybe (Vec2 u) +isoscelesTriangleRadialIntersect bw h ang = +    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp +  where+    rp = anaTrailPath zeroPt $ isosceles_triangle_trail bw h

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Paths.PathBuilder--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -90,7 +90,7 @@     getGenPathSpec :: DrawingContext -> PathSt st -> (a, PathSt st, CatPrim) }  type instance DUnit   (GenPathSpec st u a) = u-type instance UState  (GenPathSpec st u)   = st+type instance UState  (GenPathSpec st u a) = st  type PathSpec u a = GenPathSpec () u a @@ -228,7 +228,7 @@         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) +        (_,w2)    = runImage pctx (renderActivePen mode $ st_active_pen s1)          wfinal    = cpmove (V2 dx dy) $ w1 `mappend` w2     in replaceAns (a, st_user_state s1, upath) $ primGraphic wfinal @@ -293,9 +293,9 @@  -- | Helper. ---drawActivePen :: PathMode -> ActivePen -> DGraphic -drawActivePen _    PEN_UP              = mempty-drawActivePen mode (PEN_DOWN abs_path) = drawPath_ mode abs_path+renderActivePen :: PathMode -> ActivePen -> DGraphic +renderActivePen _    PEN_UP              = mempty+renderActivePen mode (PEN_DOWN abs_path) = renderPath_ mode abs_path   @@ -317,7 +317,7 @@         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+        (_,w2)     = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s1         wfinal     = w1 `mappend` w2     in primGraphic $ cpmove (negateV v1) wfinal   where@@ -393,7 +393,7 @@ 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+        (_,w1)  = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s         cpath   = snocLine (st_cumulative_path s) dv1     in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }, w1) @@ -433,7 +433,7 @@ 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+        (_,w1) = runImage pctx $ renderActivePen 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@@ -443,7 +443,7 @@  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)+    let (_,w1) = runImage pctx $ renderActivePen (fn mode) (st_active_pen s)     in ((), s { st_active_pen = PEN_UP }, w1)   where     fn DRAW_STROKE      = CSTROKE

@@ -43,7 +43,7 @@   where     conn = promoteConn $ \p1 p2 ->               let dir = vdirection $ pvec p1 p2-             in drawPath_ CSTROKE $ vectorPathTheta path1 dir p1+             in renderPath_ CSTROKE $ vectorPathTheta path1 dir p1      hdiam = 0.5 * diam      path1 = [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ]

@@ -42,6 +42,7 @@   , makeShapeCTM   , ctmCenter   , ctmAngle+  , ctmLocale   , projectFromCtr    ) where@@ -132,7 +133,7 @@ -- Probably Wumpus should calculate two paths instead. -- dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)-dblStrokedShape sh = sdecorate back fore +dblStrokedShape sh = decorateAbove back fore    where     img  = shapeToLoc (dcClosedPath DRAW_STROKE) sh     back = getLineWidth >>= \lw ->@@ -155,7 +156,7 @@     applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh)  pt 0 >>= \a ->      applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt 0 >>= \spath ->      let g2 = atIncline (shape_decoration sh) pt 0 -    in replaceAns a (sdecorate g2 $ liftQuery (toPrimPath spath) >>= drawF)+    in replaceAns a (decorateAbove g2 $ liftQuery (toPrimPath spath) >>= drawF)   @@ -177,7 +178,7 @@     applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh) pt theta >>= \a ->      applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt theta >>= \spath ->      let g2 = atIncline (shape_decoration sh) pt theta-    in replaceAns a $ sdecorate g2 (liftQuery (toPrimPath spath) >>= drawF)+    in replaceAns a $ decorateAbove g2 (liftQuery (toPrimPath spath) >>= drawF)   @@ -246,6 +247,9 @@  ctmAngle :: ShapeCTM u -> Radian ctmAngle = ctm_rotation++ctmLocale :: ShapeCTM u -> (Point2 u, Radian)+ctmLocale ctm = (ctm_center ctm, ctm_rotation ctm)   instance (Fractional u) => Scale (ShapeCTM u) where

@@ -25,12 +25,14 @@    ) where ++import Wumpus.Drawing.Basis.ShapeTrails+import Wumpus.Drawing.Basis.Geometry import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic-import Wumpus.Basic.Geometry.Quadrant-import Wumpus.Basic.Kernel      +import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core @@ -123,14 +125,21 @@   -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>        RadialAnchor (Diamond u) where   radialAnchor ang = runDisplaceCenter $ \hw hh -> -                     diamondRadialVector hw hh ang+      maybe zeroVec id $ diamondRadialAnchor hw hh ang   +diamondRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) +                    => u -> u -> Radian -> Maybe (Vec2 u) +diamondRadialAnchor hw hh ang = +    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp +  where+    rp = anaTrailPath zeroPt $ diamond_trail (2*hw) (2*hh) + -------------------------------------------------------------------------------- -- Construction @@ -140,7 +149,7 @@ -- diamond :: (Real u, Floating u, InterpretUnit u, Tolerance u)         => u -> u -> Shape Diamond u-diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath 0 hw hh)+diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath hw hh)   mkDiamond :: InterpretUnit u => u -> u -> LocThetaQuery u (Diamond u)@@ -152,11 +161,7 @@   mkDiamondPath :: (Real u, Floating u, InterpretUnit u, Tolerance u)-              => u -> u -> u -> LocThetaQuery u (AbsPath u)-mkDiamondPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> -    qapplyLoc (placedTrailPoints $ diamondTrail hw hh) ctr >>= \ps ->-    roundCornerShapePath rnd $ map (rotateAbout theta ctr) ps---+              => u -> u -> LocThetaQuery u (AbsPath u)+mkDiamondPath hw hh = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rdiamond_trail (2*hw) (2*hh) theta 

@@ -27,6 +27,7 @@    ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base @@ -148,8 +149,7 @@  mkEllipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)                => u -> u -> LocThetaQuery u (AbsPath u)-mkEllipsePath rx ry = qpromoteLocTheta $ \pt theta -> -    let xs = map (rotateAbout theta pt) $ bezierEllipse rx ry pt-    in return $ curvePath xs+mkEllipsePath rx ry = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rellipse_trail rx ry theta  

@@ -100,7 +100,7 @@   west  = runRotateAnchor east  -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor2 (InvSemicircle u) where   northeast = runRotateAnchor southwest   southeast = runRotateAnchor northwest@@ -109,7 +109,7 @@   -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      RadialAnchor (InvSemicircle u) where   radialAnchor theta =      runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)

@@ -93,7 +93,7 @@   topLeftCorner  = runRotateAnchor bottomRightCorner   topRightCorner = runRotateAnchor bottomLeftCorner -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor (InvSemiellipse u) where   north = runRotateAnchor south   south = runRotateAnchor north@@ -101,7 +101,7 @@   west  = runRotateAnchor east  -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor2 (InvSemiellipse u) where   northeast = runRotateAnchor southwest   southeast = runRotateAnchor northwest@@ -110,7 +110,7 @@   -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      RadialAnchor (InvSemiellipse u) where   radialAnchor theta =      runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)

@@ -25,11 +25,11 @@    ) where +import Wumpus.Drawing.Basis.Geometry import Wumpus.Drawing.Shapes.Base import Wumpus.Drawing.Shapes.Triangle -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 @@ -122,7 +122,7 @@   west  = runRotateAnchor east  -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor2 (InvTriangle u) where   northeast = runRotateAnchor southwest   southeast = runRotateAnchor northwest@@ -131,7 +131,7 @@   -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      RadialAnchor (InvTriangle u) where   radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta) 

@@ -27,12 +27,15 @@    ) where +import Wumpus.Drawing.Basis.Geometry+import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry                    -- package: wumpus-basic-import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  import Data.VectorSpace                         -- package: vector-space@@ -48,10 +51,10 @@ -- | A Paralleogram. -- data Parallelogram u = Parallelogram -      { pll_ctm         :: ShapeCTM u-      , pll_base_width  :: !u-      , pll_height      :: !u-      , pll_base_l_ang  :: Radian+      { pll_ctm             :: ShapeCTM u+      , pll_base_width      :: !u+      , pll_height          :: !u+      , pll_base_left_ang   :: Radian       }  type instance DUnit (Parallelogram u) = u@@ -88,21 +91,28 @@ -------------------------------------------------------------------------------- -- Anchors --- | 'runDisplaceCenter' : @ ( half_base_width---                           * half_height +-- | 'runDisplaceCenter' : @ ( base_width+--                           * height  --                           * base_minor---                           * base_major -> Vec ) * parallelogram -> Point @+--                           -> Vec ) * parallelogram -> Point @ -- runDisplaceCenter :: (Real u, Floating u)                   => (u -> u -> Radian -> Vec2 u) -> Parallelogram u -> Anchor u-runDisplaceCenter fn (Parallelogram { pll_ctm        = ctm-                                    , pll_base_width = bw-                                    , pll_height     = h -                                    , pll_base_l_ang = lang }) =-    projectFromCtr (fn (0.5 * bw) (0.5 * h) lang) ctm+runDisplaceCenter fn (Parallelogram { pll_ctm           = ctm+                                    , pll_base_width    = bw+                                    , pll_height        = h +                                    , pll_base_left_ang = lang }) =+    projectFromCtr (fn bw h lang) ctm  +runDisplaceCenterHalves :: (Real u, Floating u)+                        => (u -> u -> Radian -> Vec2 u) +                        -> Parallelogram u +                        -> Anchor u+runDisplaceCenterHalves fn = +    runDisplaceCenter $ \bw h bl_ang -> fn (0.5*bw) (0.5*h) bl_ang + instance (Real u, Floating u) =>      CenterAnchor (Parallelogram u) where   center = runDisplaceCenter $ \_ _ _ -> V2 0 0@@ -115,18 +125,18 @@  instance (Real u, Floating u) =>      TopCornerAnchor (Parallelogram u) where-  topLeftCorner  = runDisplaceCenter $ \hw hh lang -> +  topLeftCorner  = runDisplaceCenterHalves $ \hw hh lang ->        let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang hypo -  topRightCorner = runDisplaceCenter $ \hw hh lang ->+  topRightCorner = runDisplaceCenterHalves $ \hw hh lang ->       let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang hypo  instance (Real u, Floating u) =>      BottomCornerAnchor (Parallelogram u) where-  bottomLeftCorner  = runDisplaceCenter $ \hw hh lang ->+  bottomLeftCorner  = runDisplaceCenterHalves $ \hw hh lang ->       let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang (-hypo) -  bottomRightCorner = runDisplaceCenter $ \hw hh lang -> +  bottomRightCorner = runDisplaceCenterHalves $ \hw hh lang ->        let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang (-hypo)  @@ -142,28 +152,30 @@   -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor (Parallelogram u) where-  north = runDisplaceCenter $ \_  hh _ -> V2 0 hh-  south = runDisplaceCenter $ \_  hh _ -> V2 0 (-hh)-  east  = runDisplaceCenter $ \hw _  _ -> V2 hw 0-  west  = runDisplaceCenter $ \hw _  _ -> V2 (-hw) 0+  north = radialAnchor (0.5 * pi)+  south = radialAnchor (1.5 * pi)+  east  = radialAnchor 0+  west  = radialAnchor pi   instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor2 (Parallelogram u) where-  northeast = pllRadialAnchor (0.25*pi)-  southeast = pllRadialAnchor (1.75*pi)-  southwest = pllRadialAnchor (1.25*pi)-  northwest = pllRadialAnchor (0.75*pi)+  northeast = radialAnchor (0.25*pi)+  southeast = radialAnchor (1.75*pi)+  southwest = radialAnchor (1.25*pi)+  northwest = radialAnchor (0.75*pi)    instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>       RadialAnchor (Parallelogram u) where-   radialAnchor = pllRadialAnchor+   radialAnchor ang = runDisplaceCenter $ \bw h bl_ang-> +      maybe zeroVec id $ pllRadialAnchor bw h bl_ang ang  + -- | Note - it is not worth changing this to a quadrantAlg. -- -- There are pathological parallelograms that the current @@ -171,19 +183,12 @@ -- needed (rather than better implementation of QuadrantAlg). -- pllRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) -                => Radian -> Parallelogram u -> Anchor u-pllRadialAnchor theta (Parallelogram { pll_ctm         = ctm-                                     , pll_base_width  = bw-                                     , pll_height      = h-                                     , pll_base_l_ang  = lang }) =-    post $ findIntersect zeroPt theta $ polygonLineSegments ps-  where -    ps    = runVertices4 zeroPt $ parallelogramVertices bw h lang+                => u -> u -> Radian -> Radian -> Maybe (Vec2 u)+pllRadialAnchor bw h bl_ang ang =+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp +  where+    rp = anaTrailPath zeroPt $ parallelogram_trail bw h bl_ang -    post  = \ans -> case ans of -                    Nothing       -> projectFromCtr (V2 0 0) ctm-                    Just (P2 x y) -> projectFromCtr (V2 x y) ctm-      -------------------------------------------------------------------------------- -- Construction@@ -195,7 +200,7 @@ parallelogram :: (Real u, Floating u, InterpretUnit u, Tolerance u)                => u -> u -> Radian -> Shape Parallelogram u parallelogram bw h lang =-    makeShape (mkParallelogram bw h lang) (mkParallelogramPath 0 bw h lang)+    makeShape (mkParallelogram bw h lang) (mkParallelogramPath bw h lang)   -- | 'zparallelogram'  : @ base_width * height -> Parallelogram @@@ -213,21 +218,21 @@  mkParallelogram :: (Real u, Fractional u, InterpretUnit u, Tolerance u)                  => u -> u -> Radian -> LocThetaQuery u (Parallelogram u)-mkParallelogram bw h lang = qpromoteLocTheta $ \ctr theta -> -    pure $ Parallelogram { pll_ctm          = makeShapeCTM ctr theta-                         , pll_base_width   = bw-                         , pll_height       = h-                         , pll_base_l_ang   = lang+mkParallelogram bw h bl_ang = qpromoteLocTheta $ \ctr theta -> +    pure $ Parallelogram { pll_ctm            = makeShapeCTM ctr theta+                         , pll_base_width     = bw+                         , pll_height         = h+                         , pll_base_left_ang  = bl_ang                          }     mkParallelogramPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) -                    => u -> u -> u -> Radian -> LocThetaQuery u (AbsPath u)-mkParallelogramPath rnd bw h lang = qpromoteLocTheta $ \ctr theta -> -    let xs = runVertices4 ctr  $ parallelogramVertices bw h lang-    in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs +                    => u -> u -> Radian -> LocThetaQuery u (AbsPath u)+mkParallelogramPath bw h bl_ang = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rparallelogram_trail bw h bl_ang theta+                            

@@ -27,10 +27,11 @@    ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry                    -- package: wumpus-basic import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core@@ -124,7 +125,7 @@   east  = runDisplaceCenter $ \hw _  -> V2 hw 0   west  = runDisplaceCenter $ \hw _  -> V2 (-hw) 0 -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor2 (Rectangle u) where   northeast = radialAnchor (0.25*pi)   southeast = radialAnchor (1.75*pi)@@ -132,11 +133,10 @@   northwest = radialAnchor (0.75*pi)  -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      RadialAnchor (Rectangle u) where-  radialAnchor theta = runDisplaceCenter $ \hw hh -> -                          rectRadialVector hw hh theta-+  radialAnchor ang = runDisplaceCenter $ \hw hh -> +      maybe zeroVec id $ rectangleRadialIntersect (2*hw) (2*hh) ang   --------------------------------------------------------------------------------@@ -148,7 +148,7 @@ rectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u)            => u -> u -> Shape Rectangle u rectangle w h = -    makeShape (mkRectangle (0.5*w) (0.5*h)) (mkRectPath 0 (0.5*w) (0.5*h))+    makeShape (mkRectangle (0.5*w) (0.5*h)) (mkRectPath (0.5*w) (0.5*h))   mkRectangle :: InterpretUnit u => u -> u -> LocThetaQuery u (Rectangle u)@@ -158,12 +158,12 @@                      , rect_hh     = hh                      } - mkRectPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) -           => u -> u -> u -> LocThetaQuery u (AbsPath u)-mkRectPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> -    let xs       = runVertices4 ctr $ rectangleVertices hw hh-    in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs-    +           => u -> u -> LocThetaQuery u (AbsPath u)+mkRectPath hw hh = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rrectangle_trail (2*hw) (2*hh) theta+++    

@@ -24,18 +24,16 @@    ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic-import Wumpus.Basic.Geometry.Intersection-import Wumpus.Basic.Kernel+import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space - import Control.Applicative  @@ -50,15 +48,6 @@  type instance DUnit (Semicircle u) = u --- | Height minor and major.----data SyntheticProps u = SP-      { sc_hminor  :: u-      , sc_hmajor  :: u-      }--type instance DUnit (SyntheticProps u) = u-    type DSemicircle = Semicircle Double @@ -76,14 +65,15 @@ -- -- to get the yminor. ---synthesizeProps :: Floating u => u -> SyntheticProps u-synthesizeProps radius = -    SP { sc_hminor = hminor, sc_hmajor = hmajor  }-  where-    hminor = (4 * radius) / (3 * pi)-    hmajor = radius - hminor  +hminor :: Floating u => u -> u+hminor radius = (4 * radius) / (3 * pi)++hmajor :: Floating u => u -> u+hmajor radius = radius - hminor radius++ -------------------------------------------------------------------------------- -- Affine trans @@ -112,34 +102,31 @@ --                           * height_major -> Vec ) * semicircle -> Point @ -- runDisplaceCenter :: (Real u, Floating u) -                  => (u -> u -> u -> Vec2 u) -> Semicircle u -> Anchor u+                  => (u -> Vec2 u) -> Semicircle u -> Anchor u runDisplaceCenter fn (Semicircle { sc_ctm       = ctm                                  , sc_radius    = radius }) = -    projectFromCtr (fn radius hminor hmajor) ctm-  where-    props  = synthesizeProps radius  -    hminor = sc_hminor props-    hmajor = sc_hmajor props+    projectFromCtr (fn radius) ctm + instance (Real u, Floating u) =>      CenterAnchor (Semicircle u) where-  center = runDisplaceCenter $ \_ _ _ -> V2 0 0+  center = runDisplaceCenter $ \_ -> V2 0 0  instance (Real u, Floating u) =>      ApexAnchor (Semicircle u) where-  apex = runDisplaceCenter $ \_ _    cmaj -> V2 0  cmaj+  apex = runDisplaceCenter $ \r -> V2 0 (hmajor r)  instance (Real u, Floating u) =>      BottomCornerAnchor (Semicircle u) where-  bottomLeftCorner  = runDisplaceCenter $ \r hminor _  -> V2 (-r) (-hminor)-  bottomRightCorner = runDisplaceCenter $ \r hminor _  -> V2  r   (-hminor)+  bottomLeftCorner  = runDisplaceCenter $ \r -> V2 (-r) (negate $ hminor r)+  bottomRightCorner = runDisplaceCenter $ \r -> V2  r   (negate $ hminor r)  instance (Real u, Floating u) =>      CardinalAnchor (Semicircle u) where   north = apex-  south = runDisplaceCenter $ \_ cmin _    -> V2 0  (-cmin)-  east  = runDisplaceCenter $ \r cmin _    -> let x = pyth r cmin in V2 x 0-  west  = runDisplaceCenter $ \r cmin _    -> let x = pyth r cmin in V2 (-x) 0+  south = runDisplaceCenter $ \r -> V2 0  (negate $ hminor r)+  east  = runDisplaceCenter $ \r -> let x = pyth r (hminor r) in V2 x 0+  west  = runDisplaceCenter $ \r -> let x = pyth r (hminor r) in V2 (-x) 0  -- | Use Pythagoras formula for working out the /east/ and /west/ -- distances. A right-triangle is formed below the centroid, @@ -151,7 +138,7 @@     pow2 = (^ (2::Int))  -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor2 (Semicircle u) where   northeast = radialAnchor (0.25*pi)   southeast = radialAnchor (1.75*pi)@@ -161,70 +148,21 @@   -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      RadialAnchor (Semicircle u) where-  radialAnchor theta = runDisplaceCenter (scRadialVec theta)---- helpers---- | Semicircle does not fit into a QuadrantAlg easily.------ So all the work has to be done here.----scRadialVec :: (Real u, Floating u, Ord u, Tolerance u)-            => Radian -> u -> u -> u -> Vec2 u-scRadialVec theta radius hminor _ = go (circularModulo theta)-  where-    (lang,rang)                     = baselineRange radius hminor-    (bctr, br, _, bl)               = constructionPoints radius hminor-    plane                           = inclinedLine zeroPt theta-    base_line                       = LineSegment bl br-    left_curve                      = mkCurve radius half_pi bctr-    right_curve                     = mkCurve radius 0 bctr-    post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)-    go a -      | lang    <= a && a <= rang   = post $ interLinesegLine base_line plane -      | half_pi <= a && a <  lang   = post $ interCurveLine left_curve plane-      | otherwise                   = post $ interCurveLine right_curve plane----mkCurve :: Floating u => u -> Radian -> Point2 u -> BezierCurve u-mkCurve radius theta ctr = BezierCurve p0 p1 p2 p3-  where-    (BezierCurve p0 p1 p2 p3) = bezierMinorArc half_pi radius theta ctr+  radialAnchor ang = runDisplaceCenter $ \r ->+      maybe zeroVec id $ semicircleRadialAnchor r ang   --- | 'constructionPoints' : @ radius * hminor -> ---     (base_ctr, base_right, apex, base_left) @------ Assumes centroid is (0,0).----constructionPoints :: Num u -                   => u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)-constructionPoints radius hminor = (bctr, br, apx, bl)+semicircleRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) +                    => u -> Radian -> Maybe (Vec2 u) +semicircleRadialAnchor r ang = +    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp    where-    bctr  = P2 0 (-hminor)-    br    = bctr .+^ hvec radius-    apx   = bctr .+^ vvec radius-    bl    = bctr .+^ hvec (-radius)--+    rp = anaTrailPath zeroPt $ semicircle_trail r  --- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @------ Find the angle range where a ray from the centroid will cross--- the baseline rather than cut the curve.----baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)-baselineRange radius hminor = (lang, rang)-  where-    ang   = toRadian $ atan (radius / hminor)-    lang  = (1.5*pi) - ang-    rang  = (1.5*pi) + ang- -------------------------------------------------------------------------------- -- Construction @@ -232,10 +170,7 @@ -- semicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u)             => u -> Shape Semicircle u-semicircle radius = -    let props = synthesizeProps radius-    in makeShape (mkSemicircle radius) -                 (mkSemicirclePath radius (sc_hminor props))+semicircle radius = makeShape (mkSemicircle radius) (mkSemicirclePath radius)             @@ -252,8 +187,7 @@ -- the center properly... -- mkSemicirclePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) -                 => u -> u -> LocThetaQuery u (AbsPath u)-mkSemicirclePath radius cminor = qpromoteLocTheta $ \pt theta ->-    let ctr = dispPerpendicular (-cminor) theta pt-    in pure $ curvePath $ bezierArcPoints pi radius theta ctr +                 => u -> LocThetaQuery u (AbsPath u)+mkSemicirclePath radius = qpromoteLocTheta $ \ctr theta ->+    return $ anaTrailPath ctr $ rsemicircle_trail radius theta 

@@ -24,17 +24,15 @@    ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic-import Wumpus.Basic.Geometry.Intersection-import Wumpus.Basic.Kernel+import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space- import Control.Applicative  @@ -51,12 +49,6 @@ type instance DUnit (Semiellipse u) = u  -data SyntheticProps u = SP-      { se_hminor  :: u-      , se_hmajor  :: u-      }--type instance DUnit (SyntheticProps u) = u    type DSemiellipse = Semiellipse Double @@ -65,14 +57,13 @@   -synthesizeProps :: Floating u => u -> SyntheticProps u-synthesizeProps ry = -    SP { se_hminor = ry_minor, se_hmajor = ry_major }-  where-    ry_minor = (4 * ry) / (3 * pi)-    ry_major = ry - ry_minor+ryminor :: Floating u => u -> u+ryminor ry = (4 * ry) / (3 * pi) +rymajor :: Floating u => u -> u+rymajor ry = ry - ryminor ry + -------------------------------------------------------------------------------- -- Affine trans @@ -103,41 +94,37 @@ --                           * ry_major -> Vec ) * semiellipse -> Point @ -- runDisplaceCenter :: (Real u, Floating u) -                  => (u -> u -> u -> u -> Vec2 u) -> Semiellipse u -> Anchor u+                  => (u -> u -> Vec2 u) -> Semiellipse u -> Anchor u runDisplaceCenter fn (Semiellipse { se_ctm       = ctm                                   , se_rx        = rx                                   , se_ry        = ry  }) = -    projectFromCtr (fn rx ry hminor hmajor) ctm-  where-    props  = synthesizeProps ry  -    hminor = se_hminor props-    hmajor = se_hmajor props+    projectFromCtr (fn rx ry) ctm     instance (Real u, Floating u) =>      CenterAnchor (Semiellipse u) where-  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0+  center = runDisplaceCenter $ \_ _ -> V2 0 0  instance (Real u, Floating u, Tolerance u) =>      ApexAnchor (Semiellipse u) where-  apex = runDisplaceCenter $ \_ _ _ ry_major -> V2 0 ry_major+  apex = runDisplaceCenter $ \_ ry -> V2 0 (rymajor ry)  instance (Real u, Floating u) =>      BottomCornerAnchor (Semiellipse u) where-  bottomLeftCorner  = runDisplaceCenter $ \rx _ ry_minor _  -> V2 (-rx) (-ry_minor)-  bottomRightCorner = runDisplaceCenter $ \rx _ ry_minor _  -> V2  rx   (-ry_minor)+  bottomLeftCorner  = runDisplaceCenter $ \rx ry -> V2 (-rx) (negate $ ryminor ry)+  bottomRightCorner = runDisplaceCenter $ \rx ry -> V2  rx   (negate $ ryminor ry)  -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor (Semiellipse u) where   north = apex-  south = runDisplaceCenter $ \_ _ ry_minor _ -> V2 0 (-ry_minor)+  south = runDisplaceCenter $ \_ ry -> V2 0 (negate $ ryminor ry)   east  = radialAnchor 0   west  = radialAnchor pi -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor2 (Semiellipse u) where   northeast = radialAnchor (0.25*pi)   southeast = radialAnchor (1.75*pi)@@ -146,56 +133,18 @@   -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      RadialAnchor (Semiellipse u) where-  radialAnchor theta = runDisplaceCenter (seRadialVec theta)---seRadialVec :: (Real u, Floating u, Ord u, Tolerance u)-            => Radian -> u -> u -> u -> u -> Vec2 u-seRadialVec theta rx ry hminor _ = go theta-  where-    (lang,rang)                     = baselineRange rx hminor-    (bctr, br, _, bl)               = constructionPoints rx ry hminor-    plane                           = inclinedLine zeroPt theta-    base_line                       = LineSegment bl br-    (right_curve,left_curve)        = bezierSemiellipse rx ry bctr-    post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)-    go a | lang <= a && a <= rang   = post $ interLinesegLine base_line plane -         | half_pi <= a && a < lang = post $ interCurveLine left_curve plane-         | otherwise                = post $ interCurveLine right_curve plane------ | 'constructionPoints' : @ rx * ry * hminor -> ---     (base_ctr, base_right, apex, base_left) @------ Assumes centroid is (0,0).----constructionPoints :: Num u -                   => u -> u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)-constructionPoints rx ry hminor = (bctr, br, apx, bl)-  where-    bctr  = P2 0 (-hminor)-    br    = bctr .+^ hvec rx-    apx   = bctr .+^ vvec ry-    bl    = bctr .+^ hvec (-rx)--+  radialAnchor ang = runDisplaceCenter $ \rx ry ->+      maybe zeroVec id $ semiellipseRadialAnchor rx ry ang  --- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @------ Find the angle range where a ray from the centroid will cross--- the baseline rather than cut the curve.----baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)-baselineRange rx hminor = (lang, rang)+semiellipseRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) +                        => u -> u -> Radian -> Maybe (Vec2 u) +semiellipseRadialAnchor rx ry ang = +    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp    where-    ang   = toRadian $ atan (rx / hminor)-    lang  = (1.5*pi) - ang-    rang  = (1.5*pi) + ang-+    rp = anaTrailPath zeroPt $ semiellipse_trail rx ry   --------------------------------------------------------------------------------@@ -206,10 +155,7 @@ -- semiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u)              => u -> u -> Shape Semiellipse u-semiellipse rx ry = -    let props = synthesizeProps ry-    in makeShape (mkSemiellipse rx ry) -                 (mkSemiellipsePath rx ry (se_hminor props))+semiellipse rx ry = makeShape (mkSemiellipse rx ry) (mkSemiellipsePath rx ry)             @@ -224,46 +170,7 @@   mkSemiellipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) -                  => u -> u -> u -> LocThetaQuery u (AbsPath u)-mkSemiellipsePath rx ry hminor = qpromoteLocTheta $ \pt theta ->-    let ctr = dispPerpendicular (-hminor) theta pt-        xs  = bezierSemiellipsePoints rx ry ctr-    in return $ curvePath $ map (rotateAbout theta ctr) xs ---bezierSemiellipsePoints :: Floating u-                        => u -> u -> Point2 u -> [Point2 u]-bezierSemiellipsePoints rx ry pt = [ p0, c1,c2,p3, c4,c5,p6 ]-  where -    (BezierCurve p0 c1 c2 p3, BezierCurve _ c4 c5 p6) = bezierSemiellipse rx ry pt----- For Geometry?---- | Generate the bezier arcs for quadrants I and II. ------ Drawing is expected to proceed CCW.--- --- Note - Point is the (full) ellipse center.----bezierSemiellipse :: Floating u-                  => u -> u -> Point2 u -> (BezierCurve u, BezierCurve u)-bezierSemiellipse rx ry (P2 x y) = -    (BezierCurve p00 c01 c02 p03, BezierCurve p03 c04 c05 p06)-  where-    lrx = rx * kappa-    lry = ry * kappa-    p00 = P2 (x + rx) y-    c01 = p00 .+^ vvec lry-    c02 = p03 .+^ hvec lrx--    p03 = P2 x (y + ry) -    c04 = p03 .+^ hvec (-lrx)-    c05 = p06 .+^ vvec lry--    p06 = P2 (x - rx) y--+                  => u -> u -> LocThetaQuery u (AbsPath u)+mkSemiellipsePath rx ry = qpromoteLocTheta $ \ctr theta ->+    return $ anaTrailPath ctr $ rsemiellipse_trail rx ry theta -kappa :: Floating u => u-kappa = 4 * ((sqrt 2 - 1) / 3)

@@ -25,11 +25,12 @@    ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry                    -- package: wumpus-basic-import Wumpus.Basic.Kernel+import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core @@ -46,10 +47,11 @@ -- | A trapezium. -- data Trapezium u = Trapezium -      { tz_ctm          :: ShapeCTM u-      , tz_base_width   :: !u-      , tz_top_width   :: !u-      , tz_height       :: !u+      { tz_ctm              :: ShapeCTM u+      , tz_base_width       :: !u+      , tz_top_width        :: !u+      , tz_height           :: !u+      , tz_bottom_left_ang  :: Radian        }  type instance DUnit (Trapezium u) = u@@ -57,7 +59,8 @@ type DTrapezium = Trapezium Double  instance Functor Trapezium where-  fmap f (Trapezium ctm bw tw h) = Trapezium (fmap f ctm) (f bw) (f tw) (f h)+  fmap f (Trapezium ctm bw tw h ang) = +    Trapezium (fmap f ctm) (f bw) (f tw) (f h) ang  -------------------------------------------------------------------------------- -- Affine trans@@ -83,20 +86,34 @@ -- Anchors  ---- | 'runDisplaceCenter' : @ ( half_base_width ---                           * half_top_width---                           * half_height -> Vec ) * trapezium -> Point @+-- | 'runDisplaceCenter' : @ ( base_width +--                           * height+--                           * bl_ang -> Vec ) * trapezium -> Point @ -- runDisplaceCenter :: (Real u, Floating u)-                  => (u -> u -> u -> Vec2 u) +                  => (u -> u -> Radian -> Vec2 u)                    -> Trapezium u -> Anchor u-runDisplaceCenter fn (Trapezium { tz_ctm          = ctm-                                , tz_base_width   = bw-                                , tz_top_width    = tw-                                , tz_height       = h   }) =+runDisplaceCenter fn (Trapezium { tz_ctm              = ctm+                                , tz_base_width       = bw+                                , tz_height           = h +                                , tz_bottom_left_ang  = bl_ang  }) =+    projectFromCtr (fn bw h bl_ang) ctm+++-- | 'runDisplaceCenterHalves' : @ ( half_base_width +--                                 * half_top_width+--                                 * half_height -> Vec ) * trapezium -> Point @+--+runDisplaceCenterHalves :: (Real u, Floating u)+                        => (u -> u -> u -> Vec2 u) +                        -> Trapezium u -> Anchor u+runDisplaceCenterHalves fn (Trapezium { tz_ctm          = ctm+                                      , tz_base_width   = bw+                                      , tz_top_width    = tw+                                      , tz_height       = h   }) =     projectFromCtr (fn (0.5 * bw) (0.5 * tw) (0.5 * h)) ctm + instance (Real u, Floating u) =>      CenterAnchor (Trapezium u) where   center = runDisplaceCenter $ \_ _ _ -> V2 0 0@@ -105,8 +122,8 @@  instance (Real u, Floating u) =>      BottomCornerAnchor (Trapezium u) where-  bottomLeftCorner  = runDisplaceCenter $ \hbw _ hh -> V2 (-hbw) (-hh)-  bottomRightCorner = runDisplaceCenter $ \hbw _ hh -> V2  hbw   (-hh)+  bottomLeftCorner  = runDisplaceCenterHalves $ \hbw _ hh -> V2 (-hbw) (-hh)+  bottomRightCorner = runDisplaceCenterHalves $ \hbw _ hh -> V2  hbw   (-hh)   @@ -114,8 +131,8 @@  instance (Real u, Floating u) =>      TopCornerAnchor (Trapezium u) where-  topLeftCorner  = runDisplaceCenter $ \_ htw hh -> V2 (-htw) hh-  topRightCorner = runDisplaceCenter $ \_ htw hh -> V2   htw  hh+  topLeftCorner  = runDisplaceCenterHalves $ \_ htw hh -> V2 (-htw) hh+  topRightCorner = runDisplaceCenterHalves $ \_ htw hh -> V2   htw  hh   instance (Real u, Floating u, Tolerance u) => @@ -131,39 +148,36 @@  instance (Real u, Floating u, Tolerance u) =>      CardinalAnchor (Trapezium u) where-  north = runDisplaceCenter $ \_ _ hh -> V2 0 hh-  south = runDisplaceCenter $ \_ _ hh -> V2 0 (-hh)-  east  = tzRadialAnchor 0-  west  = tzRadialAnchor pi+  north = radialAnchor half_pi+  south = radialAnchor (1.5 * pi)+  east  = radialAnchor 0+  west  = radialAnchor pi   instance (Real u, Floating u, Tolerance u) =>      CardinalAnchor2 (Trapezium u) where-  northeast = tzRadialAnchor (0.25*pi)-  southeast = tzRadialAnchor (1.75*pi)-  southwest = tzRadialAnchor (1.25*pi)-  northwest = tzRadialAnchor (0.75*pi)+  northeast = radialAnchor (0.25*pi)+  southeast = radialAnchor (1.75*pi)+  southwest = radialAnchor (1.25*pi)+  northwest = radialAnchor (0.75*pi)    instance (Real u, Floating u, Tolerance u) =>      RadialAnchor (Trapezium u) where-  radialAnchor = tzRadialAnchor+   radialAnchor ang = runDisplaceCenter $ \bw h bl_ang -> +      maybe zeroVec id $ trapeziumRadialAnchor bw h bl_ang ang + -- -tzRadialAnchor :: (Real u, Floating u, Tolerance u) -               => Radian -> Trapezium u -> Anchor u-tzRadialAnchor theta (Trapezium { tz_ctm        = ctm-                                , tz_base_width = bw-                                , tz_top_width  = tw-                                , tz_height     = h  }) =-    post $ findIntersect zeroPt theta $ polygonLineSegments ps-  where -    ps   = runVertices4 zeroPt $ isoscelesTrapeziumVertices bw tw h-    post = \ans -> case ans of -                    Nothing       -> projectFromCtr (V2 0 0) ctm-                    Just (P2 x y) -> projectFromCtr (V2 x y) ctm-    +trapeziumRadialAnchor :: (Real u, Floating u, Tolerance u) +                      => u -> u -> Radian -> Radian -> Maybe (Vec2 u)+trapeziumRadialAnchor bw h bl_ang ang =+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp +  where+    rp = anaTrailPath zeroPt $ trapezium_trail bw h bl_ang++      -------------------------------------------------------------------------------- -- Construction@@ -174,9 +188,9 @@ -- -- trapezium :: (Real u, Floating u, InterpretUnit u, Tolerance u) -          => u -> u -> u -> Shape Trapezium u-trapezium bw tw h = -    makeShape (mkTrapezium bw tw h) (mkTrapeziumPath 0 bw tw h)+          => u -> u -> Radian -> Shape Trapezium u+trapezium bw h base_ang = +    makeShape (mkTrapezium bw h base_ang) (mkTrapeziumPath bw h base_ang)   @@ -185,19 +199,22 @@   mkTrapezium :: (Real u, Fractional u, InterpretUnit u) -            => u -> u -> u -> LocThetaQuery u (Trapezium u)-mkTrapezium bw tw h = qpromoteLocTheta $ \ctr theta -> -    pure $ Trapezium { tz_ctm           = makeShapeCTM ctr theta-                     , tz_base_width    = bw-                     , tz_top_width     = tw-                     , tz_height        = h+            => u -> u -> Radian -> LocThetaQuery u (Trapezium u)+mkTrapezium bw h base_ang = qpromoteLocTheta $ \ctr theta -> +    pure $ Trapezium { tz_ctm             = makeShapeCTM ctr theta+                     , tz_base_width      = bw+                     , tz_top_width       = tw+                     , tz_height          = h+                     , tz_bottom_left_ang = base_ang                      }+  where+    base_minor = h / (fromRadian $ tan base_ang)+    tw         = bw - (2 * base_minor)   mkTrapeziumPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) -                => u -> u -> u -> u -> LocThetaQuery u (AbsPath u)-mkTrapeziumPath rnd bw tw h = qpromoteLocTheta $ \ctr theta -> -    let xs = runVertices4 ctr $ isoscelesTrapeziumVertices bw tw h-    in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs+                => u -> u -> Radian -> LocThetaQuery u (AbsPath u)+mkTrapeziumPath bw h bl_ang = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rtrapezium_trail bw h bl_ang theta  

@@ -24,11 +24,13 @@    ) where +import Wumpus.Drawing.Basis.ShapeTrails+import Wumpus.Drawing.Basis.Geometry import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry                    -- package: wumpus-basic-import Wumpus.Basic.Kernel+import Wumpus.Basic.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core @@ -49,36 +51,21 @@       }  type instance DUnit (Triangle u) = u-      -data SyntheticProps u = SyntheticProps-      { tri_hmajor      :: u           -      , tri_hminor      :: u-      , tri_base_ang    :: Radian-      , tri_apex_ang    :: Radian-      } - type DTriangle = Triangle Double  instance Functor Triangle where   fmap f (Triangle ctm bw h) = Triangle (fmap f ctm) (f bw) (f h)  -synthesizeProps :: (Real u, Fractional u) => u -> u -> SyntheticProps u-synthesizeProps bw h = -    SyntheticProps { tri_hmajor      = hmajor-                   , tri_hminor      = hminor-                   , tri_base_ang    = base_ang-                   , tri_apex_ang    = apex_ang-                   }-  where-    half_base   = 0.5 * bw -    hminor      = h / 3-    hmajor      = 2 * hminor -    base_ang    = atan $ toRadian (h / half_base)-    apex_ang    = 2 * ((pi/4) - base_ang)+hminor :: Fractional u => u -> u +hminor h = h / 3 +hmajor :: Fractional u => u -> u +hmajor h = 2 * (h / 3) ++ -------------------------------------------------------------------------------- -- Affine trans @@ -107,33 +94,29 @@ --                           * base_ang -> Vec ) * traingle -> Point @ -- runDisplaceCenter :: (Real u, Floating u)-                  => (u -> u -> u -> Radian -> Vec2 u) -> Triangle u -> Anchor u+                  => (u -> u -> Vec2 u) -> Triangle u -> Anchor u runDisplaceCenter fn (Triangle { tri_ctm        = ctm                                , tri_base_width = bw                                 , tri_height     = h   }) =  -    projectFromCtr (fn (0.5*bw) hminor hmajor base_ang) ctm-  where-    props    = synthesizeProps bw h-    hminor   = tri_hminor props  -    hmajor   = tri_hmajor props-    base_ang = tri_base_ang props-+    projectFromCtr (fn bw h) ctm   instance (Real u, Floating u) =>      CenterAnchor (Triangle u) where-  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0+  center = runDisplaceCenter $ \_ _ -> V2 0 0   instance (Real u, Floating u) =>      ApexAnchor (Triangle u) where-  apex = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj+  apex = runDisplaceCenter $ \_ h -> V2 0 (hmajor h)   instance (Real u, Floating u) =>      BottomCornerAnchor (Triangle u) where-  bottomLeftCorner  = runDisplaceCenter $ \hbw hmin _ _  -> V2 (-hbw) (-hmin)-  bottomRightCorner = runDisplaceCenter $ \hbw hmin _ _  -> V2  hbw   (-hmin)+  bottomLeftCorner  = runDisplaceCenter $ \bw h -> +                        V2 (negate $ 0.5 * bw) (negate $ hminor h)+  bottomRightCorner = runDisplaceCenter $ \bw h -> +                        V2 (0.5 * bw)          (negate $ hminor h)   -- east and west should be parallel to the centroid.@@ -141,10 +124,10 @@  instance (Real u, Floating u) =>      CardinalAnchor (Triangle u) where-  north = runDisplaceCenter $ \_   _    hmaj _    -> V2 0 hmaj-  south = runDisplaceCenter $ \_   hmin _    _    -> V2 0 (-hmin)-  east  = runDisplaceCenter $ \hbw hmin _    ang  -> findEast hbw hmin ang-  west  = runDisplaceCenter $ \hbw hmin _    ang  -> findWest hbw hmin ang+  north = runDisplaceCenter $ \_  h -> V2 0 (hmajor h)+  south = runDisplaceCenter $ \_  h -> V2 0 (negate $ hminor h)+  east  = runDisplaceCenter $ \bw h -> findEast bw h+  west  = runDisplaceCenter $ \bw h -> findWest bw h   instance (Real u, Floating u) => @@ -156,18 +139,20 @@       step _ = midpoint (bottomRightCorner a) (apex a)  -findEast :: Fractional u => u -> u -> Radian -> Vec2 u-findEast half_base_width hminor base_ang = V2 xdist 0+findEast :: (Real u, Fractional u) => u -> u -> Vec2 u+findEast bw h = V2 xdist 0   where-    b1    = hminor / (fromRadian $ tan base_ang)-    xdist = half_base_width - b1+    half_base   = 0.5 * bw +    base_ang    = atan $ toRadian (h / half_base)+    b1          = (hminor h) / (fromRadian $ tan base_ang)+    xdist       = (0.5 * bw) - b1 -findWest :: Fractional u => u -> u -> Radian -> Vec2 u-findWest hbw hm ang = let (V2 xdist 0) = findEast hbw hm ang in V2 (-xdist) 0 +findWest :: (Real u, Fractional u) => u -> u -> Vec2 u+findWest bw h = let (V2 xdist 0) = findEast bw h in V2 (-xdist) 0    -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      CardinalAnchor2 (Triangle u) where   northeast = radialAnchor (0.25*pi)   southeast = radialAnchor (1.75*pi)@@ -176,11 +161,14 @@   -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) =>      RadialAnchor (Triangle u) where-  radialAnchor theta = runDisplaceCenter $ \hbw hmin hmaj _ -> -                         triangleRadialVector hbw hmin hmaj theta-       +  radialAnchor ang = runDisplaceCenter $ \bw h -> +      maybe zeroVec id $ isoscelesTriangleRadialIntersect bw h ang++++      -------------------------------------------------------------------------------- -- Construction@@ -190,11 +178,7 @@ -- triangle :: (Real u, Floating u, InterpretUnit u, Tolerance u)           => u -> u -> Shape Triangle u-triangle bw h =-    let props  = synthesizeProps bw h-        hminor = tri_hminor props-        hmajor = tri_hmajor props-    in makeShape (mkTriangle bw h) (mkTrianglePath 0 bw hminor hmajor)+triangle bw h = makeShape (mkTriangle bw h) (mkTrianglePath bw h)   @@ -213,19 +197,7 @@   mkTrianglePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) -               => u -> u -> u -> u -> LocThetaQuery u (AbsPath u)-mkTrianglePath rnd bw hminor hmajor = qpromoteLocTheta $ \ctr theta -> -    let xs = runVertices3 ctr $ trianglePath bw hminor hmajor-    in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs----trianglePath :: (Real u, Floating u) -             => u -> u -> u -> Vertices3 u-trianglePath bw hminor hmajor = (br, apx, bl)-  where-    half_base = 0.5 * bw-    br        = V2   half_base  (-hminor)-    apx       = V2   0            hmajor-    bl        = V2 (-half_base) (-hminor)+               => u -> u -> LocThetaQuery u (AbsPath u)+mkTrianglePath bw h = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ risosceles_triangle_trail bw h theta 

@@ -72,7 +72,7 @@ newtype GenDoc st u a = GenDoc { getGenDoc :: DocEnv -> GenPosObject st u a }   type instance DUnit  (GenDoc st u a) = u-type instance UState (GenDoc st u)   = st+type instance UState (GenDoc st u a) = st  type GenDocGraphic st u = GenDoc st u (UNil u) @@ -243,20 +243,20 @@  strikethrough :: (Fractional u, InterpretUnit u)                => GenDoc st u a -> GenDoc st u a-strikethrough = decorateDoc SUPERIOR drawStrikethrough +strikethrough = decorateDoc ZABOVE drawStrikethrough   underline :: (Fractional u, InterpretUnit u)            => GenDoc st u a -> GenDoc st u a-underline = decorateDoc SUPERIOR drawUnderline+underline = decorateDoc ZABOVE drawUnderline  highlight :: (Fractional u, InterpretUnit u)            => RGBi -> GenDoc st u a -> GenDoc st u a-highlight rgb = decorateDoc ANTERIOR (drawBackfill rgb) +highlight rgb = decorateDoc ZBELOW (drawBackfill rgb)      decorateDoc :: InterpretUnit u -            => ZDeco -> (Orientation u -> LocGraphic u) -> GenDoc st u a +            => ZOrder -> (Orientation u -> LocGraphic u) -> GenDoc st u a              -> GenDoc st u a decorateDoc zdec fn ma = GenDoc $ \env ->      decoratePosObject zdec fn $ getGenDoc ma env

@@ -59,7 +59,7 @@               -> LocImage u a                -> LocImage u a locImageLabel fn rpos mklabel obj = promoteLoc $ \pt -> -    selaborate (obj `at` pt)  (\a -> ignoreAns $ mklabel rpos `at` fn a)+    elaborateAbove (obj `at` pt)  (\a -> ignoreAns $ mklabel rpos `at` fn a)   @@ -96,7 +96,7 @@                    -> Image u (AbsPath u)                     -> Image u (AbsPath u) connectorPathLabel fn rpos lbl img =  -    selaborate img  (\a -> ignoreAns $ lbl rpos `at` (fn a))+    elaborateAbove img  (\a -> ignoreAns $ lbl rpos `at` (fn a))   label_midway_of :: (Real u, Floating u, InterpretUnit u) 

@@ -44,7 +44,7 @@ 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)+    gf = capHeight >>= \h -> moveStart (go_up $ 0.5 * h) (S.scircle $ 0.5 * h)   @@ -52,7 +52,7 @@ 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)+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.scircle $ 0.25 * h)  empty_box :: (Fractional u, InterpretUnit u) => GenDocGraphic st u empty_box = embedPosObject $ makePosObject qy gf@@ -66,13 +66,13 @@ 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)+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.sleft_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)+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.sright_slice h)  -- More to follow... 

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.VersionNumber--- Copyright   :  (c) Stephen Tetley 2010-2011+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -23,7 +23,7 @@  -- | Version number ----- > (0,7,0)+-- > (0,9,0) -- wumpus_drawing_version :: (Int,Int,Int)-wumpus_drawing_version = (0,7,0)+wumpus_drawing_version = (0,9,0)

@@ -1,5 +1,5 @@ name:             wumpus-drawing-version:          0.7.0+version:          0.9.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -38,8 +38,23 @@   .   Changelog:   .-  v0.6.0 to v0.7.0+  v0.8.0 to v0.9.0:+  . +  * Updated to work with wumpus-basic-0.24.0.    .+  * Removed monoid mappend alias @(<>)@ as it is now defined by+    Data.Monoid. +  .+  v0.7.0 to v0.8.0:+  .+  * Changed API to make Connectors.+  .+  * Added InclineTrails to Drawing.Basis.+  . +  * Reworked @Extras.Loop@.+  .+  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 @@ -53,7 +68,7 @@   .   * Added a tube box connector.   .-  v0.5.0 to v0.6.0+  v0.5.0 to v0.6.0:   .   * Removed @LocTrace@ and @RefTrace@ from @Wumpus.Drawing.Basis@,     they are superseded by @LocDrawing@ in Wumpus-Basic.@@ -91,11 +106,15 @@                       containers      >= 0.3     && <= 0.6,                       vector-space    >= 0.6     && <  1.0,                       wumpus-core     >= 0.52.0  && <  0.53.0,-                      wumpus-basic    == 0.22.0+                      wumpus-basic    == 0.24.0       exposed-modules:+    Wumpus.Drawing.Basis.BezierCurve,     Wumpus.Drawing.Basis.DrawingPrimitives,+    Wumpus.Drawing.Basis.Geometry,+    Wumpus.Drawing.Basis.InclineTrails,+    Wumpus.Drawing.Basis.ShapeTrails,     Wumpus.Drawing.Basis.Symbols,     Wumpus.Drawing.Colour.SVGColours,     Wumpus.Drawing.Colour.X11Colours,@@ -113,6 +132,8 @@     Wumpus.Drawing.Extras.Loop,     Wumpus.Drawing.Paths,     Wumpus.Drawing.Paths.Base,+    Wumpus.Drawing.Paths.Illustrate,+    Wumpus.Drawing.Paths.Intersection,     Wumpus.Drawing.Paths.PathBuilder,     Wumpus.Drawing.Paths.Vamps,     Wumpus.Drawing.Shapes,