packages feed

wumpus-drawing 0.1.0 → 0.9.0

raw patch · 80 files changed

Files

CHANGES view
@@ -1,4 +1,61 @@ +0.4.0 to 0.5.0+  +  * Re-implemented Text drawing. Some functionality moved to +    Wumpus-Basic.+  +  * Re-implemented monadic Path Builder.+  +0.3.0 to 0.4.0:+  +  * Simplified Trapezium shape so it only produces isosceles+    Trapeziums.+  +  * Added Basis modules. These are \"mid-level\" modules similar +    to ones in @Wumpus.Basic.Kernel.Objects@, however they are +    considered less general so there are put here where they can +    be imported individually (and so not pollute the namespace).+  +  * Removed the Turtle modules. The new @LocTrace@ and @RefTrace@ +    modules supercede the Turtle modules.+  +0.2.0 to 0.3.0:++  * Moved Turtle and Grids into the @Wumpus.Drawing.Extras@+    name-space. Modules here are considered sketches.++  * Re-implemented arrowheads and connectors.++  * Re-implemented monadic path construction. This is now +    essentially \"turtle drawing\" with a path trace.++  * Removed chains - a simplified implementation is now +    provided by Wumpus-Basic.++  * Re-implemented and expanded Text.  ++0.1.0 to 0.2.0:++  * Added new Shapes.++  * Move Geometry modules to Wumpus-Basic.++  * Re-implemented Chains.++  * Re-implemented LR-Text. Added CatText.+ 0.1.0: -  * Initial split from Wumpus-Basic.+  * Initial release - this is a split from @Wumpus-Basic@ making +    the (very prototypical - read sub-alpha, unstable...) modules +    in the @Drawing@ hierarchy a separate package.++  * Simplified Chains - chains are now regular lists (though often+    infinite). Drawings are made with chains using new zip-like+    functions.++  * Re-worked Shapes.++  * Re-worked Arrow and Arrow Tip types.++  * Re-worked ConnectorPaths.
demo/ArrowCircuit.hs view
@@ -5,59 +5,43 @@ -- Acknowledgment - the Arrow diagram is taken from Ross  -- Paterson\'s slides /Arrows and Computation/. +-- NOTE - this example now rather out-of-date. Wumpus-Drawing has +-- some new features to make node/connector drawing a bit easier.  module ArrowCircuit where -import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Paths +import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs -import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader -import FontLoaderUtils+import Wumpus.Core                              -- package: wumpus-core  -import Data.AffineSpace+import Data.AffineSpace                         -- package: vector-space  import System.Directory   main :: IO ()-main = do -    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help-    createDirectoryIfMissing True "./out/"-    maybe gs_failk  makeGSPicture  $ mb_gs-    maybe afm_failk makeAfmPicture $ mb_afm-  where-    gs_failk  = putStrLn "No GhostScript font path supplied..."-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."--makeGSPicture :: FilePath -> IO ()-makeGSPicture font_dir = do -    putStrLn "Using GhostScript metrics..."-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"]-    mapM_ putStrLn msgs-    let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic-    writeEPS "./out/arrow_circuit01.eps" pic1-    writeSVG "./out/arrow_circuit01.svg" pic1 +main = simpleFontLoader main1 >> return () -makeAfmPicture :: FilePath -> IO ()-makeAfmPicture font_dir = do -    putStrLn "Using AFM 4.1 metrics..."-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"]-    mapM_ putStrLn msgs+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Right times_roman_family ]+    printLoadErrors base_metrics     let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic-    writeEPS "./out/arrow_circuit02.eps" pic1-    writeSVG "./out/arrow_circuit02.svg" pic1 +    writeEPS "./out/arrow_circuit.eps" pic1+    writeSVG "./out/arrow_circuit.svg" pic1    -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace times_roman . metricsContext 11+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font times_roman . metricsContext 11   @@ -68,9 +52,12 @@  -- Note `at` currently does not work for Shapes.          -circuit_pic :: CtxPicture Double -circuit_pic = drawTracing $ do-    a1 <- drawi $ (strokedShape $ rrectangle 12 66 30) `at` P2 0 72+circuit_pic :: CtxPicture+circuit_pic = drawTracing body ++body :: TraceDrawing Double ()+body = do+    a1 <- drawi $ rrectangle 12 66 30 `at` P2 0 72     atext a1 "CONST 0"     a2 <- drawi $ (strokedShape $ circle 16) `at` P2 120 60     atext a2 "IF"@@ -78,41 +65,73 @@     atext a3 "+1"     a4 <- drawi $ (strokedShape $ rectangle 66 30) `at` P2 120 0     atext a4 "DELAY 0"-    connWith connLine (east a1) (east a1 .+^ hvec 76)-    connWith connLine (east a2) (east a2 .+^ hvec 180)-    connWith connLine (north a2 .+^ vvec 40) (north a2)-    connWith connLine (north a3 .+^ vvec 16) (north a3)  -    connWith connRightVH  (south a3) (east a4)-    connWith (connRightHVH (-30)) (west a4)  (southwest a2)+    connWith 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"     return () +    -- Note - need a variant of /bar/ that draws UDLR only. +connWith :: ( Real u, Floating u, InterpretUnit u ) +         => ArrowConnector u -> Anchor u -> Anchor u -> TraceDrawing u ()+connWith con a0 a1 = localize double_point_size $ +    drawc a0 a1 (ignoreAns con) -connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m-            , Real u, Floating u, FromPtSize u ) -         => ConnectorPath u -> Point2 u -> Point2 u -> m ()-connWith con p0 p1 = localize doublesize $ -    drawi_ $ apply2R2 (rightArrow tri45 con) p0 p1 +atext :: ( CenterAnchor (t u), u ~ DUnit (t u)+         , Real u, Floating u, InterpretUnit u)+      => t u -> String -> TraceDrawing u ()+atext ancr ss = +    draw $ textline CENTER ss `at` (center ancr) -atext :: ( CenterAnchor t, DUnit t ~ u-         , Real u, Floating u, FromPtSize u-         , TraceM m, DrawingCtxM m, u ~ MonUnit m )-      => t -> String -> m ()-atext ancr ss = let pt = center ancr in-   drawi_ $ ctrCenterLine ss `at` pt +ptext :: (Floating u, InterpretUnit u) +      => Point2 u -> String -> TraceDrawing u ()+ptext pt ss = localize (font_attr times_italic 14) $ +    draw $ textline CENTER ss `at` pt -ptext :: ( Real u, Floating u, FromPtSize u-         , TraceM m, DrawingCtxM m, u ~ MonUnit m )-      => Point2 u -> String -> m ()-ptext pt ss = localize (fontAttr times_italic 14) $ -    drawi_ $ ctrCenterLine ss `at` pt +-- Note - return type is a LocImage not a shape...+--+rrectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +           => Double -> u -> u -> LocImage u (Rectangle u)+rrectangle _r w h = strokedShape (rectangle w h)+    -- This should have round corners but they are currently+    -- disabled pending a re-think. +    {- localize (round_corner_factor r) $ -}  -rrectangle :: (Real u, Floating u, FromPtSize u) -           => u -> u -> u -> LocShape u (Rectangle u)-rrectangle r w h = localize (roundCornerFactor $ realToFrac r) (rectangle w h)+++-- Cf. Parsec\'s Token module...++conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conn_line =+    renderConnectorConfig default_connector_props $ makeSglArrConn C.conn_line++conna_orthovbar :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conna_orthovbar = +    renderConnectorConfig default_connector_props $ +      makeSglArrConn C.conna_orthovbar+++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+      }
demo/Arrowheads.hs view
@@ -2,82 +2,106 @@  module Arrowheads where --import Wumpus.Basic.Kernel-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths hiding ( length )+import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs -import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space+import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader +import Wumpus.Core                              -- package: wumpus-core++import Data.Monoid import System.Directory  main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx arrow_drawing-    writeEPS "./out/arrowheads01.eps" pic1-    writeSVG "./out/arrowheads01.svg" pic1+main = simpleFontLoader main1 >> return () -arrow_drawing :: CtxPicture Double-arrow_drawing = drawTracing $ localize (dashPattern unit_dash_pattern) -                            $ tableGraphic arrtable+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) arrow_drawing+    writeEPS "./out/arrowheads.eps" pic1+    writeSVG "./out/arrowheads.svg" pic1 -arrtable :: [(Arrowhead Double, Arrowhead Double)]++makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 14++++arrow_drawing :: CtxPicture+arrow_drawing = +    drawTracing $ localize line_thick $ tableGraphic arrtable++arrtable :: [(String, ArrowTip)] arrtable = -    [ (tri90,       tri90)-    , (tri60,       tri60)-    , (tri45,       tri45)-    , (otri90,      otri90)-    , (otri60,      otri60)-    , (otri45,      otri45)-    , (revtri90,    revtri90)-    , (revtri60,    revtri60)-    , (revtri45,    revtri45)-    , (orevtri90,   orevtri90)-    , (orevtri60,   orevtri60)-    , (orevtri45,   orevtri45)-    , (barb90,      barb90)-    , (barb60,      barb60)-    , (barb45,      barb45)-    , (revbarb90,   revbarb90)-    , (revbarb60,   revbarb60)-    , (revbarb45,   revbarb45)-    , (perp,        perp)-    , (bracket,     bracket)-    , (diskTip,     diskTip)-    , (odiskTip,    odiskTip)-    , (squareTip,   squareTip)-    , (osquareTip,  osquareTip)-    , (diamondTip,  diamondTip)-    , (odiamondTip, odiamondTip)-    , (curveTip,    curveTip)-    , (revcurveTip, revcurveTip)+    [ ("tri90",                 tri90)+    , ("tri60",                 tri60)+    , ("tri45",                 tri45)  +    , ("otri90",                otri90)+    , ("otri60",                otri60)+    , ("otri45",                otri45)+    , ("revtri90",              revtri90)+    , ("revtri60",              revtri60)+    , ("revtri45",              revtri45)+    , ("orevtri90",             orevtri90)+    , ("orevtri60",             orevtri60)+    , ("orevtri45",             orevtri45)+    , ("barb90",                barb90)+    , ("barb60",                barb60)+    , ("barb45",                barb45)+    , ("revbarb90",             revbarb90)+    , ("revbarb60",             revbarb60)+    , ("revbarb45",             revbarb45)+    , ("perp",                  perp)+    , ("bracket",               bracket)+    , ("diskTip",               diskTip)+    , ("odiskTip",              odiskTip)+    , ("squareTip",             squareTip)+    , ("osquareTip",            osquareTip)+    , ("diamondTip",            diamondTip)+    , ("odiamondTip",           odiamondTip)+    , ("diamondWideTip",        diamondWideTip)+    , ("odiamondWideTip",       odiamondWideTip)+    , ("curveTip",              curveTip)+    , ("revcurveTip",           revcurveTip)         ] -tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u ()-tableGraphic tips = zipchainWith makeArrowDrawing tips ps-  where-    ps = tableDown 20 (120,24) (P2 0 480)  +tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double ()+tableGraphic tips = +    drawl start $ distribColumnwiseTable 18 (180,24) $ map arrowGraphic tips+  where+    start   = P2 0 480+   std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18+std_ctx = fill_colour peru $ standardContext 18   -makeArrowDrawing :: (Real u, Floating u, FromPtSize u) -                 => (Arrowhead u, Arrowhead u) -> LocGraphic u-makeArrowDrawing (arrl,arrr) = -    promoteR1 $ \p0 -> forget $-      connect (leftRightArrow arrl arrr connLine) p0 (mkP1 p0)+-- Note - /null/ chain action needs a better type synonym name.+--+arrowGraphic :: (String, ArrowTip) -> LocGraphic Double+arrowGraphic (name, utip) = aconn `mappend` lbl   where-    mkP1    = (.+^ hvec 100)-    -- forget needs a better name, then adding to Wumpus-Basic.-    forget  = fmap (replaceL uNil)  +    aconn = ignoreAns $ promoteLoc $ \pt ->+              connect (mkConn_line utip) pt (displace (hvec 60) pt)++    lbl   = ignoreAns $ promoteLoc $ \pt -> +              textline WW name `at` (displace (hvec 66) pt)++++mkConn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +            => ArrowTip -> ArrowConnector u+mkConn_line = rightArrowConnector default_connector_props C.conn_line+
+ demo/Automata.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++module Automata where++import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C+import Wumpus.Drawing.Extras.Loop+import Wumpus.Drawing.Paths+import Wumpus.Drawing.Shapes+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs+import Wumpus.Drawing.Text.Base.Label+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader++import Wumpus.Core                              -- package: wumpus-core++import System.Directory++++main :: IO ()+main = simpleFontLoader main1 >> return ()++main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Right times_roman_family  ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) automata+    writeEPS "./out/automata.eps" pic1+    writeSVG "./out/automata.svg" pic1 +++makeCtx :: FontLoadResult -> DrawingContext+makeCtx = +    snap_grid_factors 60.0 60.0 . set_font times_roman . metricsContext 14+++automata :: CtxPicture+automata = udrawTracing (0::Double) $ do+    q0     <- nodei (8,0)   $ state "q0"+    q1     <- drawi $ state "q1"      `mat` above_right_of q0+    q2     <- drawi $ state "q2"      `mat` below_right_of q0+    q3     <- drawi $ stopstate "q3"  `mat` below_right_of q1++    s0     <- evalQuery $ left_of q0++    draw $ label_midway_of SE (textline `flip` "0") $ straightconn q0 q1+    draw $ label_midway_of SS (textline `flip` "0") $ arrloop (center q1) (north q1) +    draw $ label_midway_of SW (textline `flip` "1") $ straightconn q1 q3+    draw $ label_midway_of NE (textline `flip` "1") $ straightconn q0 q2+    draw $ label_midway_of NW (textline `flip` "0") $ straightconn q2 q3+    draw $ label_midway_of NN (textline `flip` "1") $ arrloop (center q2) (south q2) +    draw $ label_atstart_of EE (textline `flip` "start") $ astraightconn s0 (west q0) ++    return ()++-- Monadic at - this is a hack that needs a rethink...+-- +infixr 1 `mat`++mat :: InterpretUnit u => LocImage u a -> Query u (Point2 u) -> Image u a+mat img mq = liftQuery mq >>= \pt -> img `at` pt++state :: String -> DLocImage DCircle+state ss = +    localize (set_font times_italic) $ +        label_center_of (textline `flip` ss) $ strokedShape $ circle 20+++stopstate :: String -> DLocImage DCircle +stopstate ss = +    localize (set_font times_italic) $ +        label_center_of (textline `flip` ss) $ dblStrokedShape $ circle 20++++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 conn_line p0 p1+++astraightconn :: ( Real u, Floating u, InterpretUnit u, Tolerance u)+              => Anchor u -> Anchor u -> Image u (AbsPath u)+astraightconn p0 p1 = connect conn_line p0 p1+++-- Note - there is a problem with @rightArrow@ as @loop@+-- manufactures the start and end points...+--+arrloop :: ( Real u, Floating u, InterpretUnit u, Tolerance u)+        => Anchor u -> Anchor u -> Image u (AbsPath u)+arrloop ctr p1 = +    rightArrowPath $ loopPath zradius ctr zincl+  where+    v1      = pvec ctr p1+    zradius = vlength v1+    zincl   = vdirection v1+++-- Cf. Parsec\'s Token module...++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)
demo/ClipPic.hs view
@@ -12,93 +12,132 @@  module ClipPic where -import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Extras.Clip import Wumpus.Drawing.Paths-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Text.StandardFontDefs +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space +import Data.Monoid import System.Directory   main :: IO () main = do      createDirectoryIfMissing True "./out/"-    let pic = runCtxPictureU pic_drawing_ctx big_pic-    writeEPS "./out/clip_pic.eps" pic-    writeSVG "./out/clip_pic.svg" pic+    let pic1 = runCtxPictureU std_ctx clip_pic+    writeEPS "./out/clip_pic.eps" pic1+    writeSVG "./out/clip_pic.svg" pic1  -pic_drawing_ctx :: DrawingContext-pic_drawing_ctx = standardContext 14+std_ctx :: DrawingContext+std_ctx = standardContext 14  -big_pic :: DCtxPicture-big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4]+-- Note - currently the code is quite messy, path drawing needs +-- some convenience combinators. -fillPath :: Num u => Path u -> Graphic u-fillPath = filledPath . toPrimPath+clip_pic :: CtxPicture+clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do+    drawl (P2   0 320) $ runPathSpec_ CFILL path01+    drawl (P2 112 320) $ localize (fill_colour powder_blue) $ +                           runPathSpec_ CFILL path02+    drawl (P2 384 416) $ runPathSpec_ CFILL path03+    drawl (P2 328 512) $ runPathSpec_ CFILL path04+    drawl (P2   0   0) $ clip1+    drawl (P2 112   0) $ clip2+    drawl (P2 384  96) $ clip3+    drawl (P2 328 192) $ clip4 -pic1 :: DCtxPicture-pic1 = drawTracing $-         localize (fillColour medium_slate_blue) $ do-            draw $ fillPath path01-            localize (fillColour powder_blue) $ -                     draw $ fillPath path02-            draw $ fillPath path03-            draw $ fillPath path04 +-- PathSpec is overkill here...+--+extrPathSpec :: InterpretUnit u +             => PathSpec u a -> LocQuery u (AbsPath u)+extrPathSpec spec = qpromoteLoc $ \pt ->+    fmap post $ qapplyLoc (stripGenPathSpec () CSTROKE spec) pt+  where+    post (_,_,c) = c -background :: RGBi -> DCtxPicture-background rgb = drawTracing $ -    localize (strokeColour rgb) $ -        unchain 112 iheartHaskell $ tableDown 18 (86,16) (P2 0 288)+background :: RGBi -> LocGraphic Double+background rgb = promoteLoc $ \_ -> +    ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288+  where+    ihh = distribColumnwiseTable 18 (86,16) $ replicate 112 iheartHaskell+                    -cpic1 :: DCtxPicture -cpic1 = clipCtxPicture (toPrimPath path01) (background black)+-- | This is one for Wumpus-Basic - the set of combinators to +-- shift between Images and Queries needs sorting out+--++zapLocQ :: InterpretUnit u => LocQuery u a-> LocImage u a+zapLocQ ma = promoteLoc $ \pt -> +   askDC >>= \ctx ->+   let a = runLocQuery ctx pt ma in return a++clip1 :: LocGraphic Double+clip1 = zapLocQ (extrPathSpec path01) >>= \a -> +        locClip a (background black)   -cpic2 :: DCtxPicture-cpic2 = clipCtxPicture (toPrimPath path02) (background medium_violet_red)+clip2 :: LocGraphic Double+clip2 = zapLocQ (extrPathSpec path02) >>= \a -> +        locClip a (background medium_violet_red) -cpic3 :: DCtxPicture -cpic3 = clipCtxPicture (toPrimPath path03) (background black)+clip3 :: LocGraphic Double+clip3 = zapLocQ (extrPathSpec path03) >>= \a -> locClip a (background black) -cpic4 :: DCtxPicture -cpic4 = clipCtxPicture (toPrimPath path04) (background black)+clip4 :: LocGraphic Double+clip4 = zapLocQ (extrPathSpec path04) >>= \a -> locClip a (background black)  -iheartHaskell :: Num u => FromPtSize u => LocGraphic u-iheartHaskell = promoteR1 $ \pt -> -    let body  = textline "I Haskell" `at` pt-        heart = localize (fontFace symbol) $ -                  textline "&heart;" `at` (pt .+^ hvec 7)-    in body `oplus` heart+iheartHaskell :: LocGraphic Double+iheartHaskell = promoteLoc $ \pt -> +    let body  = dcTextlabel "I Haskell" `at` pt+        heart = localize (set_font symbol) $ +                  dcTextlabel "&heart;" `at` (pt .+^ hvec 7)+    in body `mappend` heart +-- Note - this needs a more uniform name. In Wumpus an object +-- that produces a @UNil@ is called a __Graphic but that +-- convention seems misleading here.+--+type UPathSpec u = PathSpec u (UNil u) -path01 :: Floating u => Path u-path01 = execPath zeroPt $ hline 80 >> rlineto (vec 112 160) -                                    >> rlineto (vec (-112) 160)-                                    >> hline (-80)-                                    >> rlineto (vec 112 (-160))-                                    >> rlineto (vec (-112) (-160))- +-- zeroPt+path01 :: UPathSpec Double+path01 = do +    hpenline 80 +    penline (vec 112 160) +    penline (vec (-112) 160)+    hpenline (-80)+    penline (vec 112 (-160))+    penline (vec (-112) (-160))+    ureturn -path02 :: Floating u => Path u-path02 = execPath (P2 112 0) $ hline 80 >> rlineto (vec 72 112)-                                        >> rlineto (vec 72 (-112))-                                        >> hline 80-                                        >> rlineto (vec (-224) 320)-                                        >> hline (-80)-                                        >> rlineto (vec 112 (-160))-                                        >> rlineto (vec (-112) (-160)) -path03 :: Floating u => Path u-path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) +-- (P2 112 0)+path02 :: UPathSpec Double+path02 = do +    hpenline 80 +    penline (vec 72 112)+    penline (vec 72 (-112))+    hpenline 80+    penline (vec (-224) 320)+    hpenline (-80)+    penline (vec 112 (-160))+    penline (vec (-112) (-160))+    ureturn -path04 :: Floating u => Path u-path04 = execPath (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) +-- (P2 384 96) +path03 :: UPathSpec Double+path03 = hpenline 96 >> vpenline 56 >> hpenline (-136) >> ureturn++-- (P2 328 192)+path04 :: UPathSpec Double+path04 = hpenline 152 >> vpenline 56 >> hpenline (-192) >> ureturn
demo/ColourCharts.hs view
@@ -4,11 +4,13 @@  import ColourChartUtils -import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains+import Wumpus.Drawing.Basis.DrawingPrimitives +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core +import Data.Monoid import System.Directory  @@ -21,37 +23,37 @@     writeSVG "./out/SVGcolours.svg" svg_pic     --     let x11_p = runCtxPictureU draw_ctx x11_portrait-    writeEPS "./out/X11colours.eps" $ uniformScale 0.75 x11_p+    writeEPS "./out/X11colours.eps" $ scale 0.75 0.75 x11_p     let x11_l = runCtxPictureU draw_ctx x11_landscape     writeSVG "./out/X11colours.svg" x11_l  draw_ctx :: DrawingContext draw_ctx = (standardContext 9) -svg :: CtxPicture Double+svg :: CtxPicture svg = makeDrawing 52 all_svg_colours -x11_landscape :: CtxPicture Double+x11_landscape :: CtxPicture x11_landscape = makeDrawing 52 all_x11_colours -x11_portrait :: CtxPicture Double+x11_portrait :: CtxPicture x11_portrait = makeDrawing 72 all_x11_colours      -makeDrawing :: Int -> [(String,RGBi)] -> DCtxPicture+makeDrawing :: Int -> [(String,RGBi)] -> CtxPicture makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs  tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double () tableGraphic row_count xs = -    zipchainWith (\(name,rgb) -> colourSample name rgb) xs ps+    drawl pt $ distribColumnwiseTable row_count (152,11) gs   where-    ps = tableDown row_count (152,11) pt-    pt = displaceV (fromIntegral $ 11 * row_count) zeroPt -+    pt   = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt +    gs   = map (uncurry colourSample) xs+     colourSample :: String -> RGBi -> LocGraphic Double-colourSample name rgb = localize (fillColour rgb) $ -    promoteR1 $ \pt ->  -      oplus (borderedRectangle 15 10 `at` pt)-            (textline name `at` displace 20 2 pt)+colourSample name rgb = localize (fill_colour rgb) $ +    promoteLoc $ \pt ->  +      mappend (blRectangle DRAW_FILL_STROKE 15 10 `at` pt)+              (dcTextlabel name `at` displace (vec 20 2) pt)
demo/Connectors.hs view
@@ -2,71 +2,110 @@  module Connectors where --import Wumpus.Basic.Kernel-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths hiding ( length )+import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader+ import Wumpus.Core                              -- package: wumpus-core ++import Data.Monoid import System.Directory + main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx conn_pic-    writeEPS "./out/connectors01.eps" pic1-    writeSVG "./out/connectors01.svg" pic1+main = simpleFontLoader main1 >> return () +main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) conn_pic+    writeEPS "./out/connectors.eps" pic1+    writeSVG "./out/connectors.svg" pic1 +           +makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 11 -conn_pic :: CtxPicture Double-conn_pic = drawTracing $ tableGraphic $ conntable+conn_pic :: CtxPicture +conn_pic = drawTracing $ tableGraphic conntable -conntable :: [ConnectorPath Double]++conntable :: [(String, ConnectorPathSpec Double)] conntable = -    [ connLine-    , connRightVH-    , connRightHV-    , connRightVHV 15-    , connRightHVH 15-    , connIsosceles 25-    , connIsosceles (-25)-    , connIsosceles2 15-    , connIsosceles2 (-15)-    , connLightningBolt 15-    , connLightningBolt (-15)-    , connIsoscelesCurve 25-    , connIsoscelesCurve (-25)-    , connSquareCurve-    , connUSquareCurve-    , connTrapezoidCurve 40 0.5-    , connTrapezoidCurve (-40) 0.5-    , connZSquareCurve   -    , connUZSquareCurve   +    [ ("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)     ] -tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [ConnectorPath u] -> TraceDrawing u ()-tableGraphic conns = zipchainWith makeConnDrawing conns ps-  where-    ps = tableDown 10 (120,52) (displaceV 520 zeroPt)+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, ConnectorPathSpec Double)] -> TraceDrawing Double ()+tableGraphic conns = +    drawl start $ distribColumnwiseTable 6 (200,80) $ map makeConnDrawing conns+  where+    start = P2 0 520 +   std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18+std_ctx = fill_colour peru $ standardContext 18   -makeConnDrawing :: (Real u, Floating u, FromPtSize u) -                 => ConnectorPath u -> LocGraphic u-makeConnDrawing conn = -    promoteR1 $ \p0 -> fmap (replaceL uNil) $ -        connect (uniformArrow curveTip conn) p0 (mkP1 p0)+makeConnDrawing :: (String, ConnectorPathSpec Double) -> DLocGraphic +makeConnDrawing (ss,conn) = +    promoteLoc $ \p0 -> fn p0 (displace (vec 72 42) p0)    where-    mkP1 = displace 100 40-  +    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 biarrow p0 p1++    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+                                 }++
demo/DotPic.hs view
@@ -2,122 +2,103 @@  module DotPic where --import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.AnchorDots-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Paths+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs -import FontLoaderUtils+import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space-+import Data.Monoid import System.Directory -- main :: IO ()-main = do -    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help-    createDirectoryIfMissing True "./out/"-    maybe gs_failk  makeGSPicture  $ mb_gs-    maybe afm_failk makeAfmPicture $ mb_afm-  where-    gs_failk  = putStrLn "No GhostScript font path supplied..."-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."-+main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO ()-makeGSPicture font_dir = do -    putStrLn "Using GhostScript metrics..."-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics     let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic-    writeEPS "./out/dot_pic01_gs.eps" pic1-    writeSVG "./out/dot_pic01_gs.svg" pic1+    writeEPS "./out/dot_pic.eps" pic1+    writeSVG "./out/dot_pic.svg" pic1   --makeAfmPicture :: FilePath -> IO ()-makeAfmPicture font_dir = do -    putStrLn "Using AFM 4.1 metrics..."-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs-    let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic-    writeEPS "./out/dot_pic01_afm.eps" pic1-    writeSVG "./out/dot_pic01_afm.svg" pic1-  -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fillColour peru . fontFace helvetica . metricsContext 24+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = fill_colour peru . set_font helvetica . metricsContext 14  -dot_pic :: CtxPicture Double-dot_pic = drawTracing $ tableGraphic $ -    [ dotHLine-    , dotVLine-    , dotX-    , dotPlus-    , dotCross-    , dotDiamond-    , dotDisk-    , dotSquare-    , dotCircle-    , dotPentagon-    , dotStar-    , dotAsterisk-    , dotOPlus-    , dotOCross-    , dotFOCross-    , dotFDiamond-    , dotText "%" -    , dotTriangle-    ]+dot_pic :: CtxPicture+dot_pic = drawTracing $ tableGraphic dottable  -tableGraphic :: (Real u, Floating u, FromPtSize u) -             => [DotLocImage u] -> TraceDrawing u ()-tableGraphic imgs = zipchainWith makeDotDrawing imgs ps-  where-    row_count   = length imgs-    ps          = tableDown row_count (1,36) pt-    pt          = displaceV (fromIntegral $ 36 * row_count) zeroPt +-- Note - dots should probably have lower_case_with_underscore +-- names. +dottable :: [(String, DotLocImage Double)]+dottable =   +    [ ("smallDisk",     smallDisk)+    , ("largeDisk",     largeDisk)+    , ("smallCirc",     smallCirc)+    , ("largeCirc",     largeCirc)+    , ("dotNone",       dotNone)+    , ("dotHBar",       dotHBar)+    , ("dotVBar",       dotVBar)+    , ("dotX",          dotX)+    , ("dotPlus",       dotPlus)+    , ("dotCross",      dotCross)+    , ("dotDiamond",    dotDiamond)+    , ("dotDisk",       dotDisk)+    , ("dotSquare",     dotSquare)+    , ("dotCircle",     dotCircle)+    , ("dotPentagon",   dotPentagon)+    , ("dotStar",       dotStar)+    , ("dotAsterisk",   dotAsterisk)+    , ("dotOPlus",      dotOPlus)+    , ("dotOCross",     dotOCross)+    , ("dotFOCross",    dotFOCross)+    , ("dotFDiamond",   dotFDiamond)+    , ("dotText" ,      dotText "%")+    , ("dotTriangle",   dotTriangle) +    ]  --- This is a bit convoluted - maybe there should be chain-run --- functions for TraceDrawings as well as LocGraphics? -makeDotDrawing :: (Real u, Floating u, FromPtSize u) -               => DotLocImage u -> LocGraphic u-makeDotDrawing dotF = -    promoteR1 $ \pt -> -        let all_points = map (pt .+^) displacements-        in oconcat (dashline all_points)-                   (map (\p1 -> ignoreL $ dotF `at` p1) all_points)+tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double ()+tableGraphic imgs = +    drawl pt $ distribColumnwiseTable row_count (180,36) +             $ map makeDotDrawing imgs   where-    dashline = \ps -> localize attrUpd (openStroke $ vertexPath ps)+    row_count   = 18+    pt          = displace (vvec $ fromIntegral $ 36 * row_count) zeroPt  -    attrUpd  :: DrawingContext -> DrawingContext-    attrUpd  =  dashPattern (evenDashes 1) . strokeColour cadet_blue -    ignoreL  = fmap (replaceL uNil)  -displacements :: Num u => [Vec2 u]-displacements = [V2 0 0, V2 64 20, V2 128 0, V2 192 20] +makeDotDrawing :: (String, DotLocImage Double) -> DLocGraphic +makeDotDrawing (name,df) = +    drawing `mappend` moveStart (vec 86 14) lbl+  where+    drawing     = runPathSpec_ OSTROKE path_spec --- Should these produce a DashPattern or a StrokeAttr?+    path_spec   = updatePen path_style >>+                  insertl dot >> +                  mapM (\v -> penline v >> insertl dot) steps >>+                  ureturn+                                +                            -evenDashes :: Int -> DashPattern -evenDashes n = Dash 0 [(n,n)]+    lbl         = ignoreAns $ promoteLoc $ \pt -> +                    textline WW name `at` pt -dashOffset :: Int -> DashPattern -> DashPattern-dashOffset _ Solid       = Solid-dashOffset n (Dash _ xs) = Dash n xs+    steps       = [V2 25 15, V2 25 (-15), V2 25 15]+    dot         = ignoreAns df+    path_style  = packed_dotted . stroke_colour cadet_blue+
demo/FeatureModel.hs view
@@ -1,66 +1,46 @@-{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}    module FeatureModel where -import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Arrows-import Wumpus.Drawing.Paths +import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C+import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts--import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs -import FontLoaderUtils+import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader +import Wumpus.Core                              -- package: wumpus-core  import System.Directory   main :: IO ()-main = do -    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help-    createDirectoryIfMissing True "./out/"-    putStrLn "Note - text centering does not seem to be working well at present..."-    maybe gs_failk  makeGSPicture  $ mb_gs-    maybe afm_failk makeAfmPicture $ mb_afm-  where-    gs_failk  = putStrLn "No GhostScript font path supplied..."-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."+main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO ()-makeGSPicture font_dir = do -    putStrLn "Using GhostScript metrics..."-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Courier-Bold"]-    mapM_ putStrLn msgs+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left courier_bold ]+    printLoadErrors base_metrics     let pic1 = runCtxPictureU (makeCtx base_metrics) feature_model      writeEPS "./out/feature_model01.eps" pic1     writeSVG "./out/feature_model01.svg" pic1  -makeAfmPicture :: FilePath -> IO ()-makeAfmPicture font_dir = do -    putStrLn "Using AFM 4.1 metrics..."-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Courier-Bold"]-    mapM_ putStrLn msgs-    let pic1 = runCtxPictureU (makeCtx base_metrics) feature_model -    writeEPS "./out/feature_model02.eps" pic1-    writeSVG "./out/feature_model02.svg" pic1 --makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace courier_bold . metricsContext 18+makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font courier_bold . metricsContext 18   -- Note - I haven't worked out how to do @alternative@, @or@ and -- @repetitions@ yet. --          -feature_model :: CtxPicture Double -feature_model = drawTracing $ do+feature_model :: CtxPicture+feature_model = udrawTracing (0::Double) $ do     lea <- widebox "e" $ P2 150 160         lra <- widebox "r" $ P2  60  80     lsa <- widebox "s" $ P2 240  80@@ -91,46 +71,51 @@  -- Note - ctrCenterLine does not seem to be working well... -makeBox :: (Real u, Floating u, FromPtSize u) +makeBox :: (Real u, Floating u, InterpretUnit u, Tolerance u)          => u -> String -> Point2 u -> TraceDrawing u (Box u) makeBox w ss pt = do      a <- drawi $ (strokedShape $ rectangle w 20) `at` pt-    drawi_ $ ctrCenterLine ss `at` center a-    -- draw  $ filledDisk 2 `at` center a+    drawl (center a) $ textline CENTER ss     return a -box :: (Real u, Floating u, FromPtSize u) +box :: (Real u, Floating u, InterpretUnit u, Tolerance u)      => String -> Point2 u -> TraceDrawing u (Box u) box = makeBox 40 -widebox :: (Real u, Floating u, FromPtSize u) +widebox :: (Real u, Floating u, InterpretUnit u, Tolerance u)          => String -> Point2 u -> TraceDrawing u (Box u) widebox = makeBox 60  -connWith :: ( Real u, Floating u, FromPtSize u ) -         => Arrowhead u -> Box u -> Box u -> TraceDrawing u (Path u)+connWith :: ( Real u, Floating u, InterpretUnit u, Tolerance u) +         => ArrowTip -> Box u -> Box u -> TraceDrawing u (AbsPath u) connWith arrh b0 b1 = do    lw <- getLineWidth    let p0 = south b0-   let p1 = northwards (realToFrac lw) b1-   drawi $ apply2R2 (rightArrow arrh connLine) p0 p1+   let p1 = projectAnchor north (realToFrac lw) b1+   drawi $ connect (mkConn_line arrh) p0 p1  infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` -cmandatory :: ( Real u, Floating u, FromPtSize u ) -           => Box u -> Box u -> TraceDrawing u (Path u)+cmandatory :: ( Real u, Floating u, InterpretUnit u, Tolerance u) +           => Box u -> Box u -> TraceDrawing u (AbsPath u) cmandatory = connWith diskTip -coptional :: ( Real u, Floating u, FromPtSize u ) -          => Box u -> Box u -> TraceDrawing u (Path u)+coptional :: ( Real u, Floating u, InterpretUnit u, Tolerance u) +          => Box u -> Box u -> TraceDrawing u (AbsPath u) coptional = connWith odiskTip  -cmandatory_ :: ( Real u, Floating u, FromPtSize u ) +cmandatory_ :: ( Real u, Floating u, InterpretUnit u, Tolerance u)              => Box u -> Box u -> TraceDrawing u () cmandatory_ p0 p1 = connWith diskTip p0 p1 >> return () -coptional_ :: ( Real u, Floating u, FromPtSize u ) +coptional_ :: ( Real u, Floating u, InterpretUnit u, Tolerance u)             => Box u -> Box u -> TraceDrawing u () coptional_ p0 p1 = connWith odiskTip p0 p1 >> return ()++++mkConn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +            => ArrowTip -> ArrowConnector u+mkConn_line = rightArrowConnector default_connector_props C.conn_line
− demo/FontLoaderUtils.hs 
@@ -1,95 +0,0 @@-{-# OPTIONS -Wall #-}---module FontLoaderUtils-  (-    processCmdLine-  , default_font_loader_help-  ) where---import Control.Applicative-import Control.Monad-import System.Directory-import System.Console.GetOpt-import System.Environment-import System.IO.Error---wumpus_gs_font_dir :: String-wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR"--wumpus_afm_font_dir :: String-wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR"---default_font_loader_help :: String-default_font_loader_help = unlines $ -    [ "This example uses glyph metrics loaded at runtime."-    , "It can use either the metrics files supplied with GhostScript,"-    , "or the AFM v4.1 metrics for the Core 14 fonts available from"-    , "Adobe's website."-    , "" -    , "To use GhostScripts font metrics set the environemt variable"-    , wumpus_gs_font_dir ++ " to point to the GhostScript fonts"-    , "directory (e.g. /usr/share/ghostscript/fonts) or use the command"-    , "line flag --gs=PATH_TO_GHOSTSCRIPT_FONTS"-    , ""-    , "To use the Adode Core 14 font metrics download the archive from"-    , "the Adobe website and set the environment variable "-    , wumpus_afm_font_dir ++ " to point to it, or use the command line"-    , "flag -- afm=PATH_TO_AFM_CORE14_FONTS"-    ]---data CmdLineFlag = Help-                 | GS_FontDir  String-                 | AFM_FontDir String-  deriving (Eq,Ord,Show)--processCmdLine :: String -> IO (Maybe FilePath, Maybe FilePath)-processCmdLine help_message = -    let options = makeCmdLineOptions help_message in do-        args <- getArgs-        let (opts, _, _) = getOpt Permute options args-        if Help `elem` opts then failk help_message-                            else succk opts-  where-    failk msg   = putStr msg >> return (Nothing,Nothing) -    succk flags = (,) <$> gsFontDirectory flags <*> afmFontDirectory flags -       --makeCmdLineOptions :: String -> [OptDescr CmdLineFlag]-makeCmdLineOptions help_message =-    [ Option ['h'] ["help"]   (NoArg Help)                help_message-    , Option []    ["afm"]    (ReqArg AFM_FontDir "DIR")  "AFM v4.1 metrics dir"-    , Option []    ["gs"]     (ReqArg GS_FontDir  "DIR")  "GhoshScript font dir"-    ]---gsFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath)-gsFontDirectory = step -  where-    step (GS_FontDir p:xs)  = doesDirectoryExist p >>= \check -> -                              if check then return (Just p) else step xs--    step (_:xs)             = step xs-    step []                 = envLookup wumpus_gs_font_dir- --afmFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath)-afmFontDirectory = step -  where-    step (AFM_FontDir p:xs) = doesDirectoryExist p >>= \check -> -                              if check then return (Just p) else step xs--    step (_:xs)             = step xs-    step []                 = envLookup wumpus_afm_font_dir---envLookup :: String -> IO (Maybe String)-envLookup name = liftM fn $ try $ getEnv name-  where-    fn (Left _)  = Nothing-    fn (Right a) = Just a-
demo/FontPic.hs view
@@ -2,12 +2,12 @@  module FontPic where -import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours ( steel_blue ) import Wumpus.Drawing.Colour.X11Colours ( indian_red1 )-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Text.StandardFontDefs +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  @@ -34,16 +34,17 @@     writeSVG "./out/font_symbol.svg"    symbol_pic  -fontMsg :: FontFace -> Int -> String-fontMsg ff sz = msgF []+fontMsg :: FontDef -> Int -> String+fontMsg ft sz = msgF []   where-    msgF = showString (ps_font_name ff) . showChar ' ' . shows sz . showString "pt"+    msgF = showString name . showChar ' ' . shows sz . showString "pt"+    name = ps_font_name $ font_def_face ft   -makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic-makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz)+makeLabel :: RGBi -> FontDef -> Int -> DLocGraphic+makeLabel rgb ft sz = localize upd (dcTextlabel $ fontMsg ft sz)   where-    upd = fillColour rgb . fontAttr ff sz +    upd = text_colour rgb . font_attr ft sz   -- indian_red1 -- steel_blue@@ -54,32 +55,42 @@ positions :: [Int] positions = [0, 12, 27, 49, 78, 122]  +-- Note - this chain has grown a bit crufty as the implementation +-- of chains has changed...+--+pointChain :: (Int -> DLocGraphic) -> DLocGraphic+pointChain fn = runChain_ chn_alg $ mapM (chain1 . fn) point_sizes+  where+    chn_alg = ChainScheme start step+    start   = \pt -> (pt,point_sizes) -pointChain :: LocChain Double-pointChain = verticals $ map (fromIntegral . (+2)) point_sizes+    step _ (pt,[])     = let pnext = displace (vvec 50) pt in (pnext, (pnext, []))+    step _ (pt,(y:ys)) = let pnext = displace (vvec $ fromIntegral $ 2 + y) pt+                         in (pnext, (pnext, ys)) -fontGraphic :: RGBi -> FontFace -> DPoint2 -> TraceDrawing Double ()-fontGraphic rgb ff pt = -    let ps = pointChain pt in -      zipchainWith (\sz -> makeLabel rgb ff sz) point_sizes ps+fontGraphic :: RGBi -> FontDef -> DLocGraphic +fontGraphic rgb ft = ignoreAns $ pointChain mkGF+  where+    mkGF sz = makeLabel rgb ft sz   std_ctx :: DrawingContext std_ctx = standardContext 10  -fontDrawing :: [(RGBi,FontFace)] -> DCtxPicture+fontDrawing :: [(RGBi,FontDef)] -> CtxPicture fontDrawing xs = drawTracing $  -    zipchainWithTD (\(rgb,ff) -> fontGraphic rgb ff) xs ps+    drawl start $ runChain_ chn_alg $ mapM (chain1 . uncurry fontGraphic) xs   where-    ps = tableDown 4 (1,180) (P2 0 (4*180))+    chn_alg   = columnwiseTableScheme 4 (2,180)+    start     = P2 0 (4*180)    -------------------------------------------------------------------------------- -- Times -times_cxpic :: CtxPicture Double+times_cxpic :: CtxPicture times_cxpic =      fontDrawing [ (steel_blue,  times_roman)                 , (indian_red1, times_italic)@@ -87,7 +98,7 @@                 , (indian_red1, times_bold_italic)                 ]  -helvetica_cxpic :: CtxPicture Double+helvetica_cxpic :: CtxPicture helvetica_cxpic =      fontDrawing [ (steel_blue,  helvetica)                 , (indian_red1, helvetica_oblique)@@ -99,7 +110,7 @@  -------------------------------------------------------------------------------- -courier_cxpic :: CtxPicture Double+courier_cxpic :: CtxPicture courier_cxpic =      fontDrawing [ (steel_blue,  courier)                 , (indian_red1, courier_oblique)@@ -111,6 +122,6 @@ --------------------------------------------------------------------------------      -symbol_cxpic :: CtxPicture Double+symbol_cxpic :: CtxPicture symbol_cxpic =      fontDrawing [ (steel_blue, symbol) ]
demo/LeftRightText.hs view
@@ -1,192 +1,138 @@ {-# OPTIONS -Wall #-} --- Note - @main@ is more convoluted than would normally be --- expected as it supports both sources of glyph metrics - the --- GhostScript distribution or the Core 14 metrics from Adobe.--- --- \"Real\" applications would be expected to choose one source. ------ I-am-not-a-lawyer, but it does look as though the Adobe font--- metrics are redistributable, the GhostScript metrics are --- seemingly redistributable under the same terms as the larger--- GhostScript distribution.---    module LeftRightText where  -import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Dots.Marks-import Wumpus.Drawing.Text.LRText-import Wumpus.Drawing.Text.SafeFonts--import FontLoaderUtils+import Wumpus.Drawing.Dots.SimpleDots+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader -import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Core                              -- package: wumpus-core  import System.Directory  - main :: IO ()-main = do -    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help-    createDirectoryIfMissing True "./out/"-    maybe gs_failk  makeGSPicture  $ mb_gs-    maybe afm_failk makeAfmPicture $ mb_afm-  where-    gs_failk  = putStrLn "No GhostScript font path supplied..."-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."+main = simpleFontLoader main1 >> return () +main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) text_pic+    writeEPS "./out/left_right_text.eps" pic1+    writeSVG "./out/left_right_text.svg" pic1 -makeGSPicture :: FilePath -> IO ()-makeGSPicture font_dir = do-    putStrLn "Using GhostScript metrics..."-    (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs-    let pic1 = runCtxPictureU (makeCtx gs_metrics) text_pic-    writeEPS "./out/lr_text01.eps" pic1-    writeSVG "./out/lr_text01.svg" pic1 -makeAfmPicture :: FilePath -> IO ()-makeAfmPicture font_dir = do-    putStrLn "Using AFM 4.1 metrics..."-    (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"]-    mapM_ putStrLn msgs-    let pic2 = runCtxPictureU (makeCtx afm_metrics) text_pic-    writeEPS "./out/lr_text02.eps" pic2-    writeSVG "./out/lr_text02.svg" pic2 +makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 15  +text_pic :: CtxPicture+text_pic = udrawTracing (0::Double) $ localize text_margin_loose $ do +    draw $ (fn left_text)       `at` P2   0 400+    draw $ (fn center_text)     `at` P2 150 400+    draw $ (fn right_text)      `at` P2 300 400+    draw $ (fn blank_text)      `at` P2   0 300+    draw $ (fn ne_oneline)      `at` P2 150 300 +    draw $ (fn cc_oneline)      `at` P2 300 300 -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace helvetica . metricsContext 18 +    draw $ (fn sw_oneline)      `at` P2   0 200+    draw $ (fn ss_oneline)      `at` P2 150 200+    draw $ (fn se_oneline)      `at` P2 300 200+    draw $ (fn swr_single)      `at` P2   0 100+    draw $ (fn ssr_single)      `at` P2 150 100+    draw $ (fn ner_single)      `at` P2 300 100 -text_pic :: CtxPicture Double-text_pic = drawTracing $ do -    drawi_ $ (fn left_text)       `at` P2   0 400-    drawi_ $ (fn center_text)     `at` P2 200 400-    drawi_ $ (fn right_text)      `at` P2 400 400-    drawi_ $ (fn blank_text)      `at` P2   0 300-    drawi_ $ (fn bl_oneline)      `at` P2 200 300-    drawi_ $ (fn cc_oneline)      `at` P2 400 300-    drawi_ $ (fn newblr)          `at` P2   0 200-    drawi_ $ (fn newblc)          `at` P2 200 200-    drawi_ $ (fn newbll)          `at` P2 400 200-    drawi_ $ (fn rnewblr)         `at` P2   0 100-    drawi_ $ (fn rnewblc)         `at` P2 200 100-    drawi_ $ (fn rnewbll)         `at` P2 400 100-    drawi_ $ (fn rleft_text)      `at` P2   0 (-75)-    drawi_ $ (fn rcenter_text)    `at` P2 200 (-75)-    drawi_ $ (fn rright_text)     `at` P2 400 (-75)-      -      draw $ redPlus            `at` P2   0 400-    draw $ redPlus            `at` P2 200 400-    draw $ redPlus            `at` P2 400 400+    draw $ redPlus            `at` P2 150 400+    draw $ redPlus            `at` P2 300 400     draw $ redPlus            `at` P2   0 300  -    draw $ redPlus            `at` P2 200 300 -    draw $ redPlus            `at` P2 400 300 +    draw $ redPlus            `at` P2 150 300 +    draw $ redPlus            `at` P2 300 300      draw $ redPlus            `at` P2   0 200  -    draw $ redPlus            `at` P2 200 200 -    draw $ redPlus            `at` P2 400 200  +    draw $ redPlus            `at` P2 150 200 +    draw $ redPlus            `at` P2 300 200       draw $ redPlus            `at` P2   0 100  -    draw $ redPlus            `at` P2 200 100 -    draw $ redPlus            `at` P2 400 100 +    draw $ redPlus            `at` P2 150 100 +    draw $ redPlus            `at` P2 300 100      draw $ redPlus            `at` P2   0 (-75)-    draw $ redPlus            `at` P2 200 (-75)-    draw $ redPlus            `at` P2 400 (-75)+    draw $ redPlus            `at` P2 150 (-75)+    draw $ redPlus            `at` P2 300 (-75)          where     fn = illustrateBoundedLocGraphic    -redPlus :: (Fractional u, FromPtSize u) => LocGraphic u-redPlus = localize (strokeColour red) markPlus+redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u+redPlus = localize (stroke_colour red) dotPlus  -newblc :: BoundedLocGraphic Double-newblc = -    localize (strokeColour dark_slate_gray) $ -        baseCenterLine "new baseline center" -newbll :: BoundedLocGraphic Double-newbll = -    localize (strokeColour dark_slate_gray) $ -        baseLeftLine "new baseline left"+-- single line+--+ne_oneline :: BoundedLocGraphic Double+ne_oneline = textline NE "north east" -newblr :: BoundedLocGraphic Double-newblr = -    localize (strokeColour dark_slate_gray) $ -        baseRightLine "new baseline right" +-- single line+--+se_oneline :: BoundedLocGraphic Double+se_oneline = textline SE "south east" -rnewblc :: BoundedLocGraphic Double-rnewblc = -    localize (strokeColour dark_slate_gray) $ -        rbaseCenterLine "baseline center" `rot` (0.25*pi)+-- single line+--+ss_oneline :: BoundedLocGraphic Double+ss_oneline = textline SS "south" -rnewbll :: BoundedLocGraphic Double-rnewbll = -    localize (strokeColour dark_slate_gray) $ -        rbaseLeftLine "baseline left" `rot` (0.25*pi)+-- single line+--+sw_oneline :: BoundedLocGraphic Double+sw_oneline = textline SW "south west" -rnewblr :: BoundedLocGraphic Double-rnewblr = -    localize (strokeColour dark_slate_gray) $ -        rbaseRightLine "baseline right" `rot` (0.25 * pi)  -bl_oneline :: BoundedLocGraphic Double-bl_oneline = -    localize (strokeColour dark_slate_gray) $ baseLeftLine "Baseline-left..."+-- single line rot+--+ssr_single :: BoundedLocGraphic Double+ssr_single = rtextline (0.25*pi) SS "south rot45" +-- single line rot+--+swr_single :: BoundedLocGraphic Double+swr_single = rtextline (0.25*pi) SW "south west rot45" +-- single line rot+--+ner_single :: BoundedLocGraphic Double+ner_single = rtextline (0.25*pi) NE "north east rot45"++ cc_oneline :: BoundedLocGraphic Double-cc_oneline = -    localize (strokeColour dark_slate_gray) $ ctrCenterLine "Center-center..."+cc_oneline = textline CENTER "Center-center..." + blank_text :: BoundedLocGraphic Double-blank_text = -    localize (strokeColour dark_slate_gray) $ multiAlignCenter ""+blank_text = textline BLC ""   left_text :: BoundedLocGraphic Double-left_text = -    localize (strokeColour dark_slate_gray) $ multiAlignLeft dummy_text+left_text = multilineText VALIGN_LEFT CENTER dummy_text   right_text :: BoundedLocGraphic Double-right_text = -    localize (strokeColour dark_slate_gray) $ multiAlignRight dummy_text+right_text = multilineText VALIGN_RIGHT CENTER dummy_text  center_text :: BoundedLocGraphic Double-center_text = -    localize (strokeColour dark_slate_gray) $ multiAlignCenter dummy_text---rleft_text :: BoundedLocGraphic Double-rleft_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignLeft dummy_text `rot`   (0.25*pi)---rright_text :: BoundedLocGraphic Double-rright_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignRight dummy_text `rot`  (0.25*pi)--rcenter_text :: BoundedLocGraphic Double-rcenter_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignCenter dummy_text `rot` (0.25*pi)-+center_text = multilineText VALIGN_CENTER CENTER dummy_text  dummy_text :: String  dummy_text = unlines $ [ "The quick brown"
demo/PetriNet.hs view
@@ -7,17 +7,15 @@  module PetriNet where -import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Afm-import Wumpus.Basic.System.FontLoader.GhostScript-import Wumpus.Drawing.Arrows import Wumpus.Drawing.Colour.SVGColours-import Wumpus.Drawing.Paths+import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Shapes-import Wumpus.Drawing.Text.SafeFonts-import Wumpus.Drawing.Text.LRText+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs -import FontLoaderUtils+import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core @@ -25,134 +23,149 @@ import System.Directory  -- main :: IO ()-main = do -    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help-    createDirectoryIfMissing True "./out/"-    maybe gs_failk  makeGSPicture  $ mb_gs-    maybe afm_failk makeAfmPicture $ mb_afm-  where-    gs_failk  = putStrLn "No GhostScript font path supplied..."-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."+main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO ()-makeGSPicture font_dir = do -    putStrLn "Using GhostScript metrics..."-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica", "Helvetica-Bold"]-    mapM_ putStrLn msgs+main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Right helvetica_family ]+    printLoadErrors base_metrics     let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net-    writeEPS "./out/petri_net01.eps" pic1-    writeSVG "./out/petri_net01.svg" pic1 +    writeEPS "./out/petri_net.eps" pic1+    writeSVG "./out/petri_net.svg" pic1  -makeAfmPicture :: FilePath -> IO ()-makeAfmPicture font_dir = do -    putStrLn "Using AFM 4.1 metrics..."-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica", "Helvetica-Bold"]-    mapM_ putStrLn msgs-    let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net-    writeEPS "./out/petri_net02.eps" pic1-    writeSVG "./out/petri_net02.svg" pic1 +makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 14  -makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace helvetica . metricsContext 14-+petri_net :: CtxPicture+petri_net = udrawTracing (0::Double) $ do+    pw     <- drawi $ place         `at` (P2 0 140)+    tu1    <- drawi $ transition    `at` (P2 70 140)  +    rtw    <- drawi $ place         `at` (P2 140 140)+    tu2    <- drawi $ transition    `at` (P2 210 140)+    w      <- drawi $ place         `at` (P2 280 140)+    tu3    <- drawi $ transition    `at` (P2 350 140)+    res    <- drawi $ place         `at` (P2 280 70)+    pr     <- drawi $ place         `at` (P2 0 0)+    tl1    <- drawi $ transition    `at` (P2 70 0)+    rtr    <- drawi $ place         `at` (P2 140 0)+    tl2    <- drawi $ transition    `at` (P2 210 0)+    r      <- drawi $ place         `at` (P2 280 0)+    tl3    <- drawi $ transition    `at` (P2 350 0) -petri_net :: DCtxPicture-petri_net = drawTracing $ do-    pw     <- place 0 140-    tu1    <- transition 70 140-    rtw    <- place 140 140-    tu2    <- transition 210 140-    w      <- place 280 140-    tu3    <- transition 350 140-    res    <- place 280 70-    pr     <- place 0 0-    tl1    <- transition 70 0-    rtr    <- place 140 0-    tl2    <- transition 210 0-    r      <- place 280 0-    tl3    <- transition 350 0-    connector' (east pw)  (west tu1)              -    connector' (east tu1) (west rtw)-    connector' (east rtw) (west tu2)-    connector' (east tu2) (west w)-    connector' (east w)   (west tu3)-    connectorC 32 (north tu3) (north pw)-    connector' (east pr)  (west tl1)              -    connector' (east tl1) (west rtr)-    connector' (east rtr) (west tl2)-    connector' (east tl2) (west r)-    connector' (east r)   (west tl3)-    connectorC (-32) (south tl3) (south pr)-    connector' (southwest res) (northeast tl2)-    connector' (northwest tl3) (southeast res)-    connectorD 6    (southwest tu3) (northeast res)-    connectorD (-6) (southwest tu3) (northeast res) -    connectorD 6    (northwest res) (southeast tu2)-    connectorD (-6) (northwest res) (southeast tu2) +    drawc (east pw)  (west tu1)   $ straightconn+    drawc (east tu1) (west rtw)   $ straightconn+    drawc (east rtw) (west tu2)   $ straightconn+    drawc (east tu2) (west w)     $ straightconn+    drawc (east w)   (west tu3)   $ straightconn+    drawc (north tu3) (north pw)  $ connectorC +    drawc (east pr)  (west tl1)   $ straightconn+    drawc (east tl1) (west rtr)   $ straightconn+    drawc (east rtr) (west tl2)   $ straightconn+    drawc (east tl2) (west r)     $ straightconn+    drawc (east r)   (west tl3)   $ straightconn+    drawc (south tl3) (south pr)  $ connectorC'+    drawc (southwest res) (northeast tl2) $ straightconn+    drawc (northwest tl3) (southeast res) $ straightconn+    drawc (southwest tu3) (northeast res) $ connectorD+    drawc (southwest tu3) (northeast res) $ connectorD'+    drawc (northwest res) (southeast tu2) $ connectorD+    drawc (northwest res) (southeast tu2) $ connectorD'     draw $ lblParensParens `at` (P2 (-36) 150)     draw $ lblParensParens `at` (P2 300 60)     draw $ lblParensParensParens `at` (P2 (-52) (-14))-    draw $ lblBold "processing_w"   `at` (southwards 12 pw)-    draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)-    draw $ lblBold "writing"        `at` (southwards 12 w)-    draw $ lblBold' "resource"      `at` (P2 300 72)-    draw $ lblBold "processing_r"   `at` (northwards 12 pr)-    draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)-    draw $ lblBold "reading"        `at` (northwards 12 r)+    drawl (projectAnchor south 12 pw)     $ lblBold "processing_w"+    drawl (projectAnchor south 12 rtw)    $ lblBold "ready_to_write"+    drawl (projectAnchor south 12 w)      $ lblBold "writing"+    draw $ lblBold "resource"      `at` (P2 300 72)+    drawl (projectAnchor north 12 pr)     $ lblBold "processing_r"+    drawl (projectAnchor north 12 rtr)    $ lblBold "ready_to_read"+    drawl (projectAnchor north 12 r)      $ lblBold "reading"+     return () -greenFill :: DrawingCtxM m => m a -> m a-greenFill = localize (fillColour lime_green)+greenFill :: LocImage u a -> LocImage u a+greenFill = localize (fill_colour lime_green) -place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) -      => u -> u -> m (Circle u)-place x y = greenFill $ drawi $ (borderedShape $ circle 14) `at` P2 x y -transition :: ( Real u, Floating u, FromPtSize u-              , DrawingCtxM m, TraceM m, u ~ MonUnit m ) -           => u -> u -> m (Rectangle u)-transition x y = -    greenFill $ drawi $ (borderedShape $ rectangle 32 22) `at` P2 x y+place :: DLocImage (Circle Double)+place = greenFill $ borderedShape $ circle 14  +transition :: DLocImage (Rectangle Double)+transition = greenFill $ borderedShape $ rectangle 32 22  -connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m-         , Real u, Floating u, FromPtSize u ) -      => Point2 u -> Point2 u -> m ()-connector' p0 p1 = -    drawi_ $ apply2R2 (rightArrow tri45 connLine) p0 p1 +makeSglArrConn :: ConnectorPathSpec u -> ConnectorConfig u+makeSglArrConn cspec = +    ConnectorConfig+      { conn_arrowl     = Nothing+      , conn_arrowr     = Just tri45+      , conn_path_spec  = cspec+      } -connectorC :: ( Real u, Floating u, FromPtSize u-             , DrawingCtxM m, TraceM m, u ~ MonUnit m )-           => u -> Point2 u -> Point2 u -> m ()-connectorC v p0 p1 = -    drawi_ $ apply2R2 (rightArrow tri45 (connRightVHV v)) p0 p1+straightconn :: ConnectorGraphic Double+straightconn = ignoreAns conn_line -connectorD :: ( Real u, Floating u, FromPtSize u-             , DrawingCtxM m, TraceM m, u ~ MonUnit m )-           => u -> Point2 u -> Point2 u -> m ()-connectorD u p0 p1 = -    drawi_ $ apply2R2 (rightArrow tri45 (connIsosceles u)) p0 p1 +connectorC :: ConnectorGraphic Double+connectorC = ignoreAns conna_bar -lblParensParens :: Num u => LocGraphic u-lblParensParens = localize (fontFace helvetica) $ textline "(),()"+connectorC' :: ConnectorGraphic Double+connectorC' = ignoreAns connb_bar -lblParensParensParens :: Num u => LocGraphic u-lblParensParensParens = localize (fontFace helvetica) $ textline "(),(),()"+connectorD :: ConnectorGraphic Double+connectorD = ignoreAns conna_arc +connectorD' :: ConnectorGraphic Double+connectorD' = ignoreAns connb_arc -lblBold' :: Num u => String -> LocGraphic u-lblBold' ss = localize (fontFace helvetica_bold) $ textline ss +lblParensParens :: DLocGraphic+lblParensParens = +    ignoreAns $ localize (set_font helvetica) $ textline CENTER "(),()" -lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u-lblBold ss = localize (fontFace helvetica_bold) $ post $ ctrCenterLine ss-  where-    post = fmap (replaceL uNil)+lblParensParensParens :: DLocGraphic+lblParensParensParens = +    ignoreAns $ localize (set_font helvetica) $ textline CENTER "(),(),()"++++lblBold :: String -> DLocGraphic+lblBold ss = +    ignoreAns $ localize (set_font helvetica_bold) $ textline CENTER ss++++-- Cf. Parsec\'s Token module...++conn_props :: ConnectorProps+conn_props = (default_connector_props { conn_src_arm = 2+                                      , conn_dst_arm = 2 +                                      , conn_arc_ang =  negate $ pi / 12 })++conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conn_line = renderConnectorConfig conn_props $ makeSglArrConn C.conn_line+++conna_bar :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conna_bar = renderConnectorConfig conn_props $ makeSglArrConn C.conna_bar+++connb_bar :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+connb_bar = renderConnectorConfig conn_props $ makeSglArrConn C.connb_bar+++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
− demo/PictureCompo.hs 
@@ -1,151 +0,0 @@-{-# OPTIONS -Wall #-}--module PictureCompo where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Colour.SVGColours--import Wumpus.Core                              -- package: wumpus-core--import System.Directory---main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let out1 = runCtxPictureU pic_drawing_ctx pictures-    writeEPS "./out/picture_composition.eps" out1-    writeSVG "./out/picture_composition.svg" out1---pic_drawing_ctx :: DrawingContext-pic_drawing_ctx = standardContext 14---pictures :: DCtxPicture-pictures = vsep 12 [ pic1,  pic2,  pic3,  pic4-                   , pic5,  pic6,  pic7,  pic8-                   , pic9,  pic10, pic11, pic12 ]---drawBlueBounds :: (Real u, Floating u, FromPtSize u) -               => CtxPicture u -> CtxPicture u-drawBlueBounds = mapCtxPicture (illustrateBounds blue)--pic1 :: DCtxPicture-pic1 = picAnno pic "red `over` green `over` blue"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ rect_red `over` rect_green `over` rect_blue--pic2 :: DCtxPicture-pic2 = picAnno pic "red `under` green `under` blue"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ rect_red `under` rect_green `under` rect_blue---pic3 :: DCtxPicture -pic3 = picAnno pic "red `centric` green `centric` blue"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            rect_red `centric` rect_green `centric` rect_blue---- Note - nextToH only moves pictures in the horizontal.----pic4 :: DCtxPicture -pic4 = picAnno pic "red `nextToH` green `nextToH` blue"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            rect_red `nextToH` rect_green `nextToH` rect_blue---- Note - nextToV only moves pictures in the vertical.----pic5 :: DCtxPicture -pic5 = picAnno pic "red `nextToV` green `nextToV` blue"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            rect_red `nextToV` rect_green `nextToV` rect_blue---pic6 :: DCtxPicture-pic6 = picAnno pic "zconcat [red, green, blue]"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            zconcat [rect_red, rect_green, rect_blue]---pic7 :: DCtxPicture-pic7 = picAnno pic "hcat [red, green, blue]"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            hcat [rect_red, rect_green, rect_blue]--pic8 :: DCtxPicture-pic8 = picAnno pic "vcat [red, green, blue]"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            vcat [rect_red, rect_green, rect_blue]--pic9 :: DCtxPicture-pic9 = picAnno pic "hsep 20 [red, green, blue]"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            hsep 20 [rect_red, rect_green, rect_blue]--pic10 :: DCtxPicture-pic10 = picAnno pic "vsep 20 [red, green, blue]"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            vsep 20 [rect_red, rect_green, rect_blue]---pic11 :: DCtxPicture-pic11 = picAnno pic "hcatA HTop [red, green, blue]"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            hcatA HTop [rect_red, rect_green, rect_blue]---pic12 :: DCtxPicture-pic12 = picAnno pic "vcatA VCenter [red, green, blue]"-  where-    pic :: DCtxPicture-    pic = drawBlueBounds $ -            vcatA VCenter [rect_red, rect_green, rect_blue]--------------------------------------------------------------------------------------picAnno :: DCtxPicture -> String -> DCtxPicture-picAnno pic msg = alignHSep HCenter 30 pic lbl-  where-    lbl = drawTracing $ draw $ textline msg `at` zeroPt---rect_red :: DCtxPicture-rect_red = drawTracing $ -    localize (fillColour indian_red)-             (draw $ borderedRectangle 30 10 `at` (P2 0 10))-                 -rect_green :: DCtxPicture-rect_green = drawTracing $ -    localize (fillColour olive_drab)-             (draw $ borderedRectangle 15 15 `at` (P2 10 10))---rect_blue :: DCtxPicture-rect_blue = drawTracing $ -    localize (fillColour powder_blue)-             (draw $ borderedRectangle 20 30 `at` (P2 10 0))-
+ demo/SampleShapes.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}+++module SampleShapes where+++import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Dots.SimpleDots+import Wumpus.Drawing.Shapes+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader++import Wumpus.Core                              -- package: wumpus-core++import Control.Monad+import Data.Monoid+import System.Directory++main :: IO ()+main = simpleFontLoader main1 >> return ()++main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/shapes/" +    base_metrics <- loader [ Left courier ]+    printLoadErrors base_metrics+    let ctx = makeCtx base_metrics+    mapM_ (out1 ctx) shape_list+  where+    out1 ctx (name, shape_pic) = do +       let pic1 = runCtxPictureU ctx $ shape_pic name+       writeEPS ("./out/shapes/" ++ name ++ "01.eps") pic1+       writeSVG ("./out/shapes/" ++ name ++ "01.svg") pic1+++type ShapeList = [(String, (String -> CtxPicture))]+++shape_list :: ShapeList+shape_list = +    [ ( "circle"+      , shapePic voidExtra $ circle 150)+    , ( "diamond"+      ,  shapePic (apexAnchor >=> midPoints 4) $ diamond 150 100)+    , ( "ellipse"+      , shapePic voidExtra $ ellipse 150 100)+    , ( "invsemicircle"+      , shapePic (apexAnchor >=> topCorners) $ invsemicircle 150)+    , ( "invsemiellipse"+      , shapePic (apexAnchor >=> topCorners) $ invsemiellipse 100 150)+    , ( "invtriangle"+      , shapePic (apexAnchor >=> topCorners >=> midPoints 3) $ +          invtriangle 300 150)+    , ( "parallelogram"+      , shapePic (topCorners >=> bottomCorners >=> midPoints 4) $ +          zparallelogram 250 200)+    , ( "rectangle"+      , shapePic (topCorners >=> bottomCorners >=> midPoints 4) $ +          rectangle 300 175)+    , ( "semicircle"+      , shapePic (apexAnchor >=> bottomCorners) $ semicircle 150) +    , ( "semiellipse"+      , shapePic (apexAnchor >=> bottomCorners) $ semiellipse 100 150) +    , ( "trapezium"+      ,  shapePic (bottomCorners >=> topCorners >=> midPoints 4) $ +          trapezium 300 180 ang60)+    , ( "triangle"+      , shapePic (apexAnchor >=> bottomCorners >=> midPoints 3) $ +          triangle 300 150 )+    ]++makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font courier . metricsContext 16++rotate05 :: Rotate a => Image u a -> Image u a+rotate05 = rotate (d2r (5::Double))++-- Extra elaboration...++voidExtra :: a -> TraceDrawing u ()+voidExtra _ = return ()++++apexAnchor :: ( Real u, Floating u, InterpretUnit u+              , ApexAnchor a, u ~ DUnit a)+            => a -> TraceDrawing u a+apexAnchor a = do+    draw $ label EAST   "(apex)"    `at` apex  a+    return a++bottomCorners :: ( Real u, Floating u, InterpretUnit u+                 , BottomCornerAnchor a, u ~ DUnit a+                 )+            => a -> TraceDrawing u a+bottomCorners a = do+    draw $ label SOUTH_WEST   "(bottom left)"    `at` bottomLeftCorner  a+    draw $ label SOUTH_EAST   "(bottom right)"   `at` bottomRightCorner a+    return a++topCorners :: ( Real u, Floating u, InterpretUnit u+              , TopCornerAnchor a, u ~ DUnit a+              )+           => a -> TraceDrawing u a+topCorners a = do+    draw $ label NORTH_WEST   "(top left)"    `at` topLeftCorner  a+    draw $ label NORTH_EAST   "(top right)"   `at` topRightCorner a+    return a+++midPoints :: ( Real u, Floating u, InterpretUnit u+             , SideMidpointAnchor a, u ~ DUnit a+             )+          => Int -> a -> TraceDrawing u a+midPoints n a = mapM_ mf [1..n] >> return a+  where+    mf i = let msg = "(side midpt " ++ show i ++ ")"+           in draw $ label EAST  msg    `at` sideMidpoint i  a+++++shapePic :: ( Functor t+            , CenterAnchor (t Double)+            , CardinalAnchor (t Double)+            , CardinalAnchor2 (t Double)+            , RadialAnchor (t Double)+            , Scale (t Double)+            , Rotate (t Double)+            , Double ~ DUnit (t Double)+            ) +         => (t Double -> DTraceDrawing a) -> DShape t -> String -> CtxPicture+shapePic mf sh name = udrawTracing (0::Double) $ do+    a1  <- localize shapeSty $ drawi $ +              uniformScale 2 $ {- rotate05 $ -} shape `at` (P2 100 0)+    draw $ label NORTH        "(center)"      `at` center a1+    draw $ label NORTH        "(north)"       `at` north a1+    draw $ label SOUTH        "(south)"       `at` south a1+    draw $ label EAST         "(east)"        `at` east a1+    draw $ label WEST         "(west)"        `at` west a1+    draw $ label NORTH_EAST   "(northeast)"   `at` northeast a1+    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 (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++++++shapeSty :: DrawingContextF+shapeSty = stroke_colour light_steel_blue . line_ultra_thick++label :: (Real u, Floating u, InterpretUnit u) +      => Cardinal -> String -> LocGraphic u+label cpos ss = dotX `mappend` msg+  where+    (rpos,fn)     = go cpos+    msg           = ignoreAns $ moveStart (fn 10) $ +                       multilineText VALIGN_CENTER rpos ss ++    go NORTH      = (SS, go_north)+    go NORTH_EAST = (SW, go_north_east)+    go EAST       = (WW, go_east) +    go SOUTH_EAST = (NW, go_south_east)+    go SOUTH      = (NN, go_south)+    go SOUTH_WEST = (NE, go_south_west)+    go WEST       = (EE, go_west)+    go NORTH_WEST = (SE, go_north_west)+  +
+ demo/SingleChar.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS -Wall #-}+++module SingleChar where+++import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Dots.SimpleDots+import Wumpus.Drawing.Text.StandardFontDefs++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader++import Wumpus.Core                              -- package: wumpus-core++import System.Directory+++main :: IO ()+main = simpleFontLoader main1 >> return ()++main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) drawing01+    writeEPS "./out/single_char.eps" pic1+    writeSVG "./out/single_char.svg" pic1+++makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 18++++drawing01 :: CtxPicture+drawing01 = drawTracing $ localize (fill_colour red) $ mf +++-- Note - Baseline positions not meaningful for multiline text++mf :: TraceDrawing Double ()+mf = localize (text_margin 6.0 6.0)  $ do+    draw $ (fn SS $ posChar 'S') `at` zeroPt+    draw $ redPlus `at` zeroPt++    draw $ (fn NN $ posChar 'N') `at` P2 40 0+    draw $ redPlus `at` P2 40 0++    draw $ (fn EE $ posChar 'E') `at` P2 80 0+    draw $ redPlus `at` P2 80 0++    draw $ (fn WW $ posChar 'W') `at` P2 120 0+    draw $ redPlus `at` P2 120 0++    draw $ (fn CENTER $ posChar 'C') `at` P2 160 0+    draw $ redPlus `at` P2 160 0++    draw $ (fn NE $ posChar 'X') `at` P2 200 0+    draw $ redPlus `at` P2 200 0++  where+    fn addr obj = illustrateBoundedLocGraphic $ runPosObjectBBox addr obj+++redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u+redPlus = localize (stroke_colour red) dotPlus+
+ demo/SingleLine.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS -Wall #-}+++module SingleLine where++import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader++import Wumpus.Core                              -- package: wumpus-core++import Data.Monoid+import System.Directory+++main :: IO ()+main = simpleFontLoader main1 >> return ()++main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/" +    base_metrics <- loader [ Left helvetica ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) drawing01+    writeEPS "./out/single_line.eps" pic1+    writeSVG "./out/single_line.svg" pic1++++makeCtx :: FontLoadResult -> DrawingContext+makeCtx = set_font helvetica . metricsContext 12++++drawing01 :: CtxPicture+drawing01 = drawTracing $ localize (fill_colour red) $ mf +++mf :: TraceDrawing Double ()+mf = do+    draw $ testDraw NN `at` (P2   0 200)+    draw $ testDraw SS `at` (P2  75 200)+    draw $ testDraw EE `at` (P2 150 200)+    draw $ testDraw WW `at` (P2 225 200)+    draw $ testDraw NE `at` (P2   0 100)+    draw $ testDraw SE `at` (P2  75 100)+    draw $ testDraw SW `at` (P2 150 100)+    draw $ testDraw NW `at` (P2 225 100)+    draw $ testDraw CENTER    `at` (P2   0 0)+    ++testDraw :: RectAddress -> LocGraphic Double+testDraw rpos = dcDisk DRAW_FILL 2 `mappend` (ignoreAns ans)+  where+    ans = textline rpos "Qwerty"+++
demo/Symbols.hs view
@@ -2,220 +2,89 @@  module Symbols where -import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains-import Wumpus.Drawing.Text.SafeFonts+import Wumpus.Drawing.Basis.Symbols+import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Text.DirectionZero+import Wumpus.Drawing.Text.StandardFontDefs +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader  import Wumpus.Core                              -- package: wumpus-core -import Prelude hiding ( pi, product )-+import Data.Monoid import System.Directory + main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx symbols+main = simpleFontLoader main1 >> return ()++main1 :: FontLoader -> IO ()+main1 loader = do+    createDirectoryIfMissing True "./out/"    +    base_metrics <- loader [ Left times_roman ]+    printLoadErrors base_metrics+    let pic1 = runCtxPictureU (makeCtx base_metrics) symb_pic     writeEPS "./out/symbols.eps" pic1-    writeSVG "./out/symbols.svg" pic1+    writeSVG "./out/symbols.svg" pic1 +           +makeCtx :: FontLoadResult -> DrawingContext+makeCtx = fill_colour khaki . set_font times_roman . metricsContext 14 -std_ctx :: DrawingContext-std_ctx = fontFace times_roman $ standardContext 12+symb_pic :: CtxPicture +symb_pic = drawTracing $ tableGraphic symbtable  --- Because the font changes, we draw the all the symbols in one--- run and all the labels in a second run. This helps Wumpus-Core --- generate better PostScript as there are less changes to the --- /graphics state/.----symbols :: DCtxPicture-symbols = drawTracing $ do-    localize (fontFace symbol) $ zipchainWith sdraw all_letters ps-    zipchainWith ldraw all_letters ps-  where-    ps              = tableDown 30 (100,20) (P2 0 (30*20))-    sdraw (s,_)     = textline s-    ldraw (_,name)  = moveStartPoint (displaceH 16) (textline name)+symbtable :: [(String, LocGraphic Double)]+symbtable = +    [ ("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)+    , ("hbar",                  hbar 14)+    , ("vbar",                  vbar 14)+    , ("dbl_hbar",              dbl_hbar 14)+    , ("dbl_vbar",              dbl_vbar 14)+    ]  -all_letters :: [(String, String)]-all_letters = -    [ ("&Alpha;",               "Alpha") -    , ("&Beta;",                "Beta")-    , ("&Chi;",                 "Chi")-    , ("&Delta;",               "Delta")-    , ("&Epsilon;",             "Epsilon")-    , ("&Eta;",                 "Eta")-    , ("&Euro;",                "Euro")-    , ("&Gamma;",               "Gamma")-    , ("&Ifraktur;",            "Ifraktur")-    , ("&Iota;",                "Iota")-    , ("&Kappa;",               "Kappa")-    , ("&Lambda;",              "Lambda")-    , ("&Mu;",                  "Mu")-    , ("&Nu;",                  "Nu")-    , ("&Omega;",               "Omega")-    , ("&Omicron;",             "Omicron")-    , ("&Phi;",                 "Phi")-    , ("&Pi;",                  "Pi")-    , ("&Psi;",                 "Psi")-    , ("&Rfraktur;",            "Rfraktur")-    , ("&Rho;",                 "Rho")-    , ("&Sigma;",               "Sigma")-    , ("&Tau;",                 "Tau")-    , ("&Theta;",               "Theta")-    , ("&Upsilon;",             "Upsilon")-    , ("&Upsilon1;",            "Upsilon1")-    , ("&Xi;",                  "Xi")-    , ("&Zeta;",                "Zeta")-    , ("&aleph;",               "aleph")-    , ("&alpha;",               "alpha")-    , ("&ampersand;",           "ampersand")-    , ("&angle;",               "angle")-    , ("&angleleft;",           "angleleft")-    , ("&angleright;",          "angleright")-    , ("&approxequal;",         "approxequal")+tableGraphic :: [(String, LocGraphic Double)] -> TraceDrawing Double ()+tableGraphic symbs = +    drawl start $ ignoreAns $ distribColumnwiseTable 14 (180,24)+                $ map makeSymbDrawing symbs+  where+    start = P2 0 520  -    -- -    , ("&arrowboth;",           "arrowboth") -    , ("&arrowdblboth;",        "arrowdblboth")-    , ("&arrowdbldown;",        "arrowdbldown")-    , ("&arrowdblleft;",        "arrowdblleft")-    , ("&arrowdblright;",       "arrowdblright")-    , ("&arrowdblup;",          "arrowdblup")-    , ("&arrowdown;",           "arrowdown")-    , ("&arrowleft;",           "arrowleft")-    , ("&arrowright;",          "arrowright")-    , ("&arrowup;",             "arrowup")-    , ("&asteriskmath;",        "asteriskmath")-    , ("&bar;",                 "bar")-    , ("&beta;",                "beta")-    , ("&braceleft;",           "braceleft")-    , ("&braceright;",          "braceright")-    , ("&bracketleft;",         "bracketleft")-    , ("&bracketright;",        "bracketright")-    , ("&bullet;",              "bullet")-    , ("&carriagereturn;",      "carriagereturn")-    , ("&chi;",                 "chi")+ +std_ctx :: DrawingContext+std_ctx = fill_colour peru $ standardContext 18 -    ---    , ("&circlemultiply;",      "circlemultiply") -    , ("&circleplus;",          "circleplus")-    , ("&club;",                "club")-    , ("&colon;",               "colon")-    , ("&comma;",               "comma")-    , ("&congruent;",           "congruent")-    , ("&copyrightsans;",       "copyrightsans")-    , ("&copyrightserif;",      "copyrightserif")-    , ("&degree;",              "degree")-    , ("&delta;",               "delta")-    , ("&diamond;",             "diamond")-    , ("&divide;",              "divide")-    , ("&dotmath;",             "dotmath")-    , ("&eight;",               "eight")-    , ("&element;",             "element")-    , ("&ellipsis;",            "ellipsis")-    , ("&emptyset;",            "emptyset")-    , ("&epsilon;",             "epsilon")-    , ("&equal;",               "equal")-    , ("&equivalence;",         "equivalence")-    , ("&eta;",                 "eta")-    , ("&exclam;",              "exclam")-    , ("&existential;",         "existential")-    , ("&five;",                "five")-    , ("&florin;",              "florin")-    , ("&four;",                "four")-    , ("&fraction;",            "fraction")-    , ("&gamma;",               "gamma")-    , ("&gradient;",            "gradient")-    , ("&greater;",             "greater")-    , ("&greaterequal;",        "greaterequal")-    , ("&heart;",               "heart")-    , ("&infinity;",            "infinity")-    , ("&integral;",            "integral") -    -- -    , ("&intersection;",        "intersection")-    , ("&iota;",                "iota")-    , ("&kappa;",               "kappa")-    , ("&lambda;",              "lambda")-    , ("&less;",                "less")-    , ("&lessequal;",           "lessequal")-    , ("&logicaland;",          "logicaland")-    , ("&logicalnot;",          "logicalnot")-    , ("&logicalor;",           "logicalor")-    , ("&lozenge;",             "lozenge")-    , ("&minus;",               "minus")-    , ("&minute;",              "minute")-    , ("&mu;",                  "mu")-    , ("&multiply;",            "multiply")-    , ("&nine;",                "nine")-    , ("&notelement;",          "notelement")-    , ("&notequal;",            "notequal")-    , ("&notsubset;",           "notsubset")-    , ("&nu;",                  "nu")-    , ("&numbersign;",          "numbersign")-    , ("&omega;",               "omega")-    , ("&omega1;",              "omega1")-    , ("&omicron;",             "omicron")-    , ("&one;",                 "one")-    , ("&parenleft;",           "parenleft")-    , ("&parenright;",          "parenright") -    ---    , ("&partialdiff;",         "partialdiff")-    , ("&percent;",             "percent")-    , ("&period;",              "period")-    , ("&perpendicular;",       "perpendicular")-    , ("&phi;",                 "phi")-    , ("&phi1;",                "phi1")-    , ("&pi;",                  "pi")-    , ("&plus;",                "plus")-    , ("&plusminus;",           "plusminus")-    , ("&product;",             "product")-    , ("&propersubset;",        "propersubset")-    , ("&propersuperset;",      "propersuperset")-    , ("&proportional;",        "proportional")-    , ("&psi;",                 "psi")-    , ("&question;",            "question")-    , ("&radical;",             "radical")-    , ("&radicalex;",           "radicalex")-    , ("&reflexsubset;",        "reflexsubset")-    , ("&reflexsuperset;",      "reflexsuperset")-    , ("&registersans;",        "registersans")-    , ("&registerserif;",       "registerserif")-    , ("&rho;",                 "rho")-    -    -- -    , ("&second;",              "second")-    , ("&semicolon;",           "semicolon")-    , ("&seven;",               "seven")-    , ("&sigma;",               "sigma")-    , ("&sigma1;",              "sigma1")-    , ("&similar;",             "similar")-    , ("&six;",                 "six")-    , ("&slash;",               "slash")-    , ("&space;",               "space")-    , ("&spade;",               "spade")-    , ("&suchthat;",            "suchthat")-    , ("&summation;",           "summation")-    , ("&tau;",                 "tau")-    , ("&therefore;",           "therefore")-    , ("&theta;",               "theta")-    , ("&theta1;",              "theta1")-    , ("&three;",               "three")-    , ("&trademarksans;",       "trademarksans")-    , ("&trademarkserif;",      "trademarkserif")-    , ("&two;",                 "two")-    , ("&underscore;",          "underscore")-    , ("&union;",               "union")-    , ("&universal;",           "universal")-    , ("&upsilon;",             "upsilon")-    , ("&weierstrass;",         "weierstrass")-    , ("&xi;",                  "xi")-    , ("&zero;",                "zero")-    , ("&zeta;",                "zeta")-    ]+makeSymbDrawing :: (String, LocGraphic Double) -> DLocGraphic +makeSymbDrawing (ss,symb) = symb <> moveStart (hvec 20) lbl+  where+    lbl = ignoreAns $ textline WW ss+
− demo/TableChains.hs 
@@ -1,44 +0,0 @@-{-# OPTIONS -Wall #-}--module TableChains where---import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains-import Wumpus.Drawing.Colour.SVGColours--import Wumpus.Core                              -- package: wumpus-core--import System.Directory---main :: IO ()-main = do -    createDirectoryIfMissing True "./out/"-    let pic1 = runCtxPictureU std_ctx table_drawing-    writeEPS "./out/table_chains01.eps" pic1-    writeSVG "./out/table_chains01.svg" pic1--table_drawing :: CtxPicture Double-table_drawing = drawTracing $ tableGraphic---tableGraphic :: (Real u, Floating u, FromPtSize u) -             => TraceDrawing u ()-tableGraphic = do -    draw $ filledDisk 3  `at` dstart-    draw $ filledDisk 3  `at` rstart-    zipchainWith (textline . show) [1..20::Int] downs-    zipchainWith (textline . show) [1..20::Int] rights-  where-    downs   = tableDown  4 (36,24) dstart-    rights  = tableRight 5 (36,24) rstart--    dstart  = P2 0   480-    rstart  = P2 240 480-- -std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18--
− src/Wumpus/Drawing/Arrows.hs 
@@ -1,28 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Arrows--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Shim module for arrow connectors and arrowheads.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Arrows-  ( --    module Wumpus.Drawing.Arrows.Tips-  , module Wumpus.Drawing.Arrows.Connectors--  ) where--import Wumpus.Drawing.Arrows.Tips-import Wumpus.Drawing.Arrows.Connectors--
− src/Wumpus/Drawing/Arrows/Connectors.hs 
@@ -1,104 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Arrows.Connectors--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Draw arrows.--------------------------------------------------------------------------------------module Wumpus.Drawing.Arrows.Connectors-  ( --    ArrowConnector-  , leftArrow-  , rightArrow-  , leftRightArrow-  , uniformArrow--  ) where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Arrows.Tips-import Wumpus.Drawing.Paths------ An arrowhead always know how to draw itself (filled triangle, --- stroked barb, etc.)------ A Path is currently always drawn with openStroke,--- eventually there might be scope for drawing --- e.g. parallel lines  ====-------- | A connector with arrow tips. The connector is an /Image/,--- drawing it returns the path - positions can be taken on the --- path (e.g. @midpoint@) for further decoration.----type ArrowConnector u = ConnectorImage u (Path u)----- | Connector with an arrow tip at the start point \/ left.----leftArrow :: (Real u, Floating u) -           => Arrowhead u -> ConnectorPath u -> ArrowConnector u-leftArrow arrh conn = promoteR2 $ \p0 p1 -> -    connect conn p0 p1           >>= \cpath -> -    arrowhead_retract_dist arrh  >>= \dl -> -    let path1   = shortenL dl cpath-        ang     = directionL path1-        g1      = openStroke $ toPrimPath path1-        g2      = atRot (arrowhead_draw arrh) p0 ang-    in  fmap (replaceL cpath) $ g1 `oplus` g2       ---- Note - returns original path-                 ---- | Connector with an arrow tip at the end point \/ right.----rightArrow :: (Real u, Floating u) -           => Arrowhead u -> ConnectorPath u -> ArrowConnector u-rightArrow arrh conn = promoteR2 $ \p0 p1 -> -    connect conn p0 p1           >>= \cpath -> -    arrowhead_retract_dist arrh  >>= \dr -> -    let path1   = shortenR dr cpath-        ang     = directionR path1-        g1      = openStroke $ toPrimPath path1-        g2      = atRot (arrowhead_draw arrh) p1 ang-    in  fmap (replaceL cpath) $ g1 `oplus` g2------ | Connector with two arrow tips, possibly different.----leftRightArrow :: (Real u, Floating u) -               => Arrowhead u -> Arrowhead u -> ConnectorPath u -               -> ArrowConnector u-leftRightArrow arrL arrR conn = promoteR2 $ \p0 p1 -> -    connect conn p0 p1           >>= \cpath -> -    arrowhead_retract_dist arrL  >>= \dL -> -    arrowhead_retract_dist arrR  >>= \dR -> -    let path1   = shortenPath dL dR cpath-        angL    = directionL path1-        angR    = directionR path1-        g1      = openStroke $ toPrimPath path1-        gL      = atRot (arrowhead_draw arrL) p0 angL-        gR      = atRot (arrowhead_draw arrR) p1 angR-    in  fmap (replaceL cpath) $ g1 `oplus` gL `oplus` gR----- | Connector with the same arrow tip at both ends.----uniformArrow :: (Real u, Floating u) -             => Arrowhead u -> ConnectorPath u -> ArrowConnector u-uniformArrow arrh cp = leftRightArrow arrh arrh cp-
− src/Wumpus/Drawing/Arrows/Tips.hs 
@@ -1,515 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Arrows.Tips--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Anchor points on shapes.------ \*\* WARNING \*\* this module is an experiment, and may --- change significantly in future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Arrows.Tips-  ( ---    Arrowhead(..)-- -  , tri90-  , tri60-  , tri45-  , otri90-  , otri60-  , otri45--  , revtri90-  , revtri60-  , revtri45-  , orevtri90-  , orevtri60-  , orevtri45--  , barb90-  , barb60-  , barb45-  , revbarb90-  , revbarb60-  , revbarb45--  , perp--  , bracket--  , diskTip-  , odiskTip-  , squareTip-  , osquareTip-  , diamondTip-  , odiamondTip--  , curveTip-  , revcurveTip--  ) where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Paths--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space--import Control.Applicative----- | Encode an arrowhead as a Graphic and a retract distance - --- lines should be shortened for certain drawings (e.g. open--- triangles).------ The retract distance is context sensitive - usually just on--- the markHeight (or halfMarkHeight) so it has to be calculated--- w.r.t. the DrawingCtx.----data Arrowhead u = Arrowhead -      { arrowhead_retract_dist  :: DrawingInfo u-      , arrowhead_draw          :: LocThetaGraphic u -      }----- Design note - this used to be a newtype wrapper over a --- LocThetaImage that returned retract distance. But, considering --- the dataflow / evaluation, in some respects Arrowhead is not an --- ideal LocThetaImage as we want the retract distance to work out --- how to draw the image.------ Images do not inherently encode objects that should be drawn --- and evaluated at the same time (and lazy eval permits this) but --- it seems to helpful to think that Images should be evaluated as --- they are drawn.-------- | Tiplen is length of the tip \*along the line it follows\*. ------ > |\--- > | \--- > | /--- > |/--- > --- > |  |  -- tip len------- | Tip width is the distance between upper and lower --- arrow points.------ >       __--- > |\    --- > | \   tip--- > | /   width--- > |/    __--- >       ------ | This one is for triangular tips defined by their tip angle--- e.g. 90deg, 60deg, 45deg.------ The tip width will be variable (tip length should be the --- markHeight).--- -triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u)-triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower)-  where-    hypo_len     = tiplen / (fromRadian $ cos halfang)-    rtheta       = pi + theta        -- theta in the opposite direction-    vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len-    vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len ------ | This one is for triangles when the tip height and tip width--- are known.----triVecsByDist  :: (Real u, Floating u) -               => u -> u -> Radian -> (Vec2 u, Vec2 u)-triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower)-  where-    hypo_len     = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth)-    halfang      = toRadian $ atan (half_tipwidth / tiplen) -    rtheta       = pi + theta        -- theta in the opposite direction-    vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len-    vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len -----{--markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u-markHeightPlusLineWidth = -    (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth--}---markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u-markHeightLessLineWidth = -    (\h lw -> h - realToFrac lw) <$> markHeight <*> getLineWidth----- noRetract ignores both the angle and the point.------ Its common for the rectraction not to care about the angle or --- the point and only care about the DrawingCtx.----noRetract :: Num u => DrawingInfo u-noRetract = pure 0 ----- | Arrow tips are drawn with a sloid line even if the connector--- line is dashed (tips also override round corners)--solidArrTip :: DrawingCtxM m => m a -> m a-solidArrTip mf = localize (dashPattern Solid . roundCornerFactor 0) mf---solidOpenStroke :: Num  u => PrimPath u -> Graphic  u-solidOpenStroke = solidArrTip . openStroke--solidClosedStroke :: Num  u => PrimPath u -> Graphic  u-solidClosedStroke = solidArrTip . closedStroke--solidStrokedDisk :: Num  u => u -> LocGraphic  u-solidStrokedDisk = solidArrTip . strokedDisk------------------------------------------------------------------------------------tipBody :: FromPtSize u => (Point2 u -> Radian -> u -> CF a) -> LocThetaCF u a-tipBody mf = promoteR2 $ \pt theta -> markHeight >>= \h -> mf pt theta h ---- | Tripoints takes the \*tip length\* is the mark height.------ This means that the 90deg tip has a tip width greater-than the--- mark height (but that is okay - seemingly this is how TikZ --- does it).----tripointsByAngle :: (Floating u, FromPtSize u)-                 => Radian -> LocThetaCF u (Point2 u, Point2 u)-tripointsByAngle triang = -    tipBody $ \pt theta h -> -      let (vup,vlo) = triVecsByAngle h (0.5*triang) theta-      in  pure (pt .+^ vup, pt .+^ vlo)-    --revtripointsByAngle :: (Floating u, FromPtSize u)-                    => Radian -                    -> LocThetaCF u (Point2 u, Point2 u, Point2 u)-revtripointsByAngle triang = -    tipBody $ \pt theta h -> -      let theta'    = circularModulo $ pi+theta -          (vup,vlo) = triVecsByAngle h (0.5*triang) theta'-          back_tip  = pt .-^ avec theta h -      in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo)----tripointsByDist :: (Real u, Floating u, FromPtSize u)-                => LocThetaCF u (Point2 u, Point2 u)-tripointsByDist = -    tipBody $ \pt theta h -> -      let (vup,vlo) = triVecsByDist h (0.5*h) theta-      in pure (pt .+^ vup, pt .+^ vlo)-  ---revtripointsByDist :: (Real u, Floating u, FromPtSize u)-                   => LocThetaCF u (Point2 u, Point2 u, Point2 u)-revtripointsByDist = -    tipBody $ \pt theta h -> -      let theta'    = circularModulo $ pi+theta -          (vup,vlo) = triVecsByDist h (0.5*h) theta'-          back_tip  = pt .-^ avec theta h -      in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo)-------- width = xchar_height--- filled with stroke colour!--triTLG :: (Floating u, Real u, FromPtSize u)-       => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u-triTLG triang drawF = -    promoteR2 $ \pt theta ->-      localize bothStrokeColour $ -         apply2R2 (tripointsByAngle triang) pt theta >>= \(u,v) -> -           drawF $ vertexPath [pt,u,v]----tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri90 = Arrowhead markHeight (triTLG (pi/2) filledPath)---tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri60 = Arrowhead markHeight (triTLG (pi/3) filledPath)---tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri45 = Arrowhead markHeight (triTLG (pi/4) filledPath)--otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri90 = Arrowhead markHeight (triTLG (pi/2) solidClosedStroke)--otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri60 = Arrowhead markHeight (triTLG (pi/3) solidClosedStroke)--otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri45 = Arrowhead markHeight (triTLG (pi/4) solidClosedStroke)----- width = xchar_height--- filled with stroke colour!--revtriTLG :: (Floating u, Real u, FromPtSize u)-          => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u-revtriTLG triang drawF = -    promoteR2 $ \pt theta -> -      localize bothStrokeColour $ -        apply2R2 (revtripointsByAngle triang) pt theta >>= \(u,pt',v) -> -           drawF $ vertexPath [u,pt',v]----revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revtri90 = Arrowhead markHeightLessLineWidth-                     (revtriTLG (pi/2) filledPath)--revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revtri60 = Arrowhead markHeightLessLineWidth-                     (revtriTLG (pi/3) filledPath)--revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revtri45 = Arrowhead markHeightLessLineWidth-                     (revtriTLG (pi/4) filledPath)---orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri90 = Arrowhead markHeightLessLineWidth-                      (revtriTLG (pi/2) solidClosedStroke)--orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri60 = Arrowhead markHeightLessLineWidth-                      (revtriTLG (pi/3) solidClosedStroke)--orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-orevtri45 = Arrowhead markHeightLessLineWidth-                      (revtriTLG (pi/4) solidClosedStroke)----barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u-barbTLG ang =  -    promoteR2 $ \pt theta -> -      apply2R2 (tripointsByAngle ang) pt theta >>= \(u,v) -> -        solidOpenStroke $ vertexPath [u,pt,v]----barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb90 = Arrowhead noRetract (barbTLG (pi/2))--barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb60 = Arrowhead noRetract (barbTLG (pi/3))---barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb45 = Arrowhead noRetract (barbTLG (pi/4))----revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u-revbarbTLG ang = -    promoteR2 $ \pt theta -> -      apply2R2 (revtripointsByAngle ang) pt theta >>= \(u,pt',v) -> -        solidOpenStroke $ vertexPath [u,pt',v]--revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb90 = Arrowhead markHeight (revbarbTLG (pi/2))---revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb60 = Arrowhead markHeight (revbarbTLG (pi/3))--revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-revbarb45 = Arrowhead markHeight (revbarbTLG (pi/4))---perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u-perpTLG = -    tipBody $ \pt theta h -> -      let hh = 0.5*h in solidOpenStroke $ rperpPath hh pt theta---rperpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u-rperpPath hh ctr theta = primPath p0 [lineTo p1]-  where-    p0 = displacePerpendicular   hh  theta ctr-    p1 = displacePerpendicular (-hh) theta ctr -             ---perp :: (Floating u, FromPtSize u) => Arrowhead u-perp = Arrowhead noRetract perpTLG----bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u-bracketTLG = -    tipBody $ \pt theta h -> -      let hh = 0.5*h in solidOpenStroke $ rbracketPath hh pt theta---rbracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u-rbracketPath hh pt theta = vertexPath [p0,p1,p2,p3]-  where-    p1 = displacePerpendicular   hh  theta pt-    p0 = displaceParallel      (-hh) theta p1-    p2 = displacePerpendicular (-hh) theta pt-    p3 = displaceParallel      (-hh) theta p2-        ----bracket :: (Floating u, FromPtSize u) => Arrowhead u-bracket = Arrowhead noRetract bracketTLG---diskTLG :: (Floating u, FromPtSize u) -        => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u-diskTLG drawF = -    tipBody $ \pt theta h -> let hh  = 0.5*h -                                 ctr = pt .-^ avec theta hh -                             in drawF hh ctr---diskTip :: (Floating u, FromPtSize u) => Arrowhead u-diskTip = Arrowhead markHeight (diskTLG drawF)-  where-    drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt---odiskTip :: (Floating u, FromPtSize u) => Arrowhead u-odiskTip = Arrowhead markHeight (diskTLG drawF)-  where-    drawF r pt = solidStrokedDisk r `at` pt---squareTLG :: (Floating u, FromPtSize u) -        => (PrimPath u -> Graphic u) -> LocThetaGraphic u-squareTLG drawF = -    tipBody $ \pt theta h -> drawF $ rsquarePath pt theta (0.5*h)---rsquarePath :: Floating u => Point2 u -> Radian -> u -> PrimPath u-rsquarePath pt theta hh = vertexPath [p0,p1,p2,p3]-  where-    p0 = displacePerpendicular     hh  theta pt-    p3 = displacePerpendicular   (-hh) theta pt-    p1 = displaceParallel      (-2*hh) theta p0-    p2 = displaceParallel      (-2*hh) theta p3-    --squareTip :: (Floating u, FromPtSize u) => Arrowhead u-squareTip = Arrowhead markHeight (squareTLG drawF)-  where-    drawF = localize bothStrokeColour . filledPath---osquareTip :: (Floating u, FromPtSize u) => Arrowhead u-osquareTip = Arrowhead markHeight (squareTLG solidClosedStroke)---diamondTLG :: (Floating u, FromPtSize u) -           => (PrimPath u -> Graphic u) -> LocThetaGraphic u-diamondTLG drawF = -    tipBody $ \pt theta h -> drawF $ rdiamondPath pt theta (0.5*h)- --rdiamondPath :: Floating u => Point2 u -> Radian -> u -> PrimPath u-rdiamondPath pt theta hh = vertexPath [pt,p1,p2,p3]-  where-    ctr = displaceParallel       (-2*hh) theta pt-    p1  = displacePerpendicular     hh   theta ctr-    p3  = displacePerpendicular   (-hh)  theta ctr-    p2  = displaceParallel       (-4*hh) theta pt-         ---diamondTip :: (Floating u, FromPtSize u) => Arrowhead u-diamondTip = Arrowhead (fmap (2*) markHeightLessLineWidth) -                       (diamondTLG drawF)-  where-    drawF = localize bothStrokeColour . filledPath---odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u-odiamondTip = Arrowhead (fmap (2*) markHeight) (diamondTLG solidClosedStroke)------- Note - points flipped to get the second trapezium to --- draw /underneath/.----curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u-curveTLG = -    tipBody $ \pt theta h -> -      cxCurvePath pt theta (0.5*h) >>= \path ->-        localize (joinRound . capRound) (solidOpenStroke path)---cxCurvePath :: (Real u, Floating u, FromPtSize u) -            => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u)-cxCurvePath pt theta hh =-     apply2R2 tripointsByDist pt theta >>= \(tup,tlo) -> -          let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup-              (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt -          in pure $ toPrimPath $ curve tup u2 u1 pt `append` curve pt l1 l2 tlo-----curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u-curveTip = Arrowhead (fmap realToFrac getLineWidth) curveTLG----- Note - points flipped to get the second trapezium to --- draw /underneath/.----revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u-revcurveTLG = -    tipBody $ \pt theta h ->-      cxRevcurvePath pt theta (0.5*h) >>= \path ->-        localize (joinRound . capRound) (solidOpenStroke path)--cxRevcurvePath :: (Real u, Floating u, FromPtSize u) -               => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u)-cxRevcurvePath pt theta hh = -    apply2R2 revtripointsByDist pt theta >>= \(tup,p1,tlo) -> -      let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup-          (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1-      in pure $ toPrimPath $ curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo---revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u-revcurveTip = Arrowhead markHeight revcurveTLG-
+ src/Wumpus/Drawing/Basis/BezierCurve.hs view
@@ -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++
+ src/Wumpus/Drawing/Basis/DrawingPrimitives.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.DrawingPrimitives+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Alternative to the @DrawingPrimitives@ module in Wumpus-Basic.+-- +-- The drawing primitives here are either slightly higher level or+-- less general (more quirky).+--+-- This module is expected to be imported qualified - other modules+-- (e.g. shapes and paths) are likely to export conflicting names.+-- +-- \*\* WARNING \*\* - much of this module is probably obsolete +-- (except wedge).+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.DrawingPrimitives+  (+++  -- * Lines++    horizontalLine+  , verticalLine+  , pivotLine+++  -- * Rectangles+  , blRectangle+  , ctrRectangle+++  -- * Wedge+  , wedge++  )++  where++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++import Data.Monoid+++--------------------------------------------------------------------------------+-- Lines+++-- | Draw a vertical line.+-- +verticalLine :: InterpretUnit u => u -> LocGraphic u +verticalLine len = locStraightLine $ vvec len++-- | Draw a horizontal line.+-- +horizontalLine :: InterpretUnit u => u -> LocGraphic u +horizontalLine len = locStraightLine $ hvec len++++-- | @pivotLine@ : @ left_length * right_length * incline -> LocGraphic @+--+-- Draw a /pivot/ line. The start point is a pivot along the line, +-- not the end. The left and right distances are the extension of+-- the line from the pivot. +--+pivotLine :: (Floating u, InterpretUnit u) => u -> u -> Radian -> LocGraphic u+pivotLine lu ru ang = promoteLoc $ \pt -> +    straightLine (pt .+^ avec (ang+pi) lu) (pt .+^ avec ang ru)+++++--------------------------------------------------------------------------------+-- Rectangles++++-- | Draw a rectangle, start point is bottom left.+--+blRectangle :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u+blRectangle = dcRectangle+++-- | Draw a rectangle, start point is bottom left.+--+ctrRectangle :: (Fractional u, InterpretUnit u) +             => DrawMode -> u -> u -> LocGraphic u+ctrRectangle mode w h = +    moveStart (vec (-hw) (-hh)) $ dcRectangle mode w h+  where+    hw = 0.5 * w+    hh = 0.5 * h+++++--------------------------------------------------------------------------------+-- Wedge++++-- | wedge : mode * radius * apex_angle+-- +-- Wedge is drawn at the apex.+--+wedge :: (Real u, Floating u, InterpretUnit u) +       => DrawMode -> u -> Radian -> LocThetaGraphic u+wedge mode radius ang = promoteLocTheta $ \pt inclin -> +    let half_ang = 0.5 * ang +        line_in  = catline $ avec (inclin + half_ang)   radius+        line_out = catline $ avec (inclin - half_ang) (-radius)+        w_arc    = circularArc CW ang radius (inclin - half_pi)+        ct       = line_in `mappend` w_arc `mappend` line_out+    in supplyLoc pt $ renderCatTrail (closedMode mode) ct+        +
+ src/Wumpus/Drawing/Basis/Geometry.hs view
@@ -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
+ src/Wumpus/Drawing/Basis/InclineTrails.hs view
@@ -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) +
+ src/Wumpus/Drawing/Basis/ShapeTrails.hs view
@@ -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 ]++
+ src/Wumpus/Drawing/Basis/Symbols.hs view
@@ -0,0 +1,369 @@+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Basis.Symbols+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Symbols - many symbols expected to be re-defined as Dots or+-- character size PosObjects for DocText.+--+-- \*\* WARNING \*\* - naming conventention is to be determined...+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Basis.Symbols+  (++    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++  , empty_box++  , hbar+  , vbar+  , dbl_hbar+  , dbl_vbar++  )+  where++import Wumpus.Drawing.Basis.DrawingPrimitives++import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++-- import Data.AffineSpace                         -- package: vector-space++import Data.Monoid++--+-- DESIGN NOTE +--+-- Should names follow the /function scheme/ (camelCase), or the+-- /data scheme/ (underscore_separators).+--+-- Objects here are functions as they take size param, but they+-- expected to be redefined elsewhere (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++++-- | 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+ochar esc = char1 <> circ1+  where+    char1 = runPosObject CENTER $ posEscChar esc+    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 -> scircle (0.85 * h)++ocharDescender :: (Fractional u, InterpretUnit u) +             => EscapedChar -> LocGraphic u+ocharDescender esc = char1 <> circ1+  where+    char1 = fmap abs descender >>= \dy -> +            moveStart (go_up dy) $ runPosObject CENTER $ posEscCharUpright esc+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (0.85 * h)+++ocurrency :: (Floating u, InterpretUnit u) +          => u -> LocGraphic u +ocurrency ra = scircle ra <> lne <> lnw <> lsw <> lse+  where+    ra3 = 0.33 * ra+    lne = moveStart (go_north_east ra) $ locStraightLine $ go_north_east ra3+    lnw = moveStart (go_north_west ra) $ locStraightLine $ go_north_west ra3+    lsw = moveStart (go_south_west ra) $ locStraightLine $ go_south_west ra3+    lse = moveStart (go_south_east ra) $ locStraightLine $ go_south_east ra3++++empty_box :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+empty_box w = renderAnaTrail CSTROKE $ rectangleTrail w w++hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+hbar u = +    renderAnaTrail OSTROKE $ anaCatTrail (go_left $ 0.5 * u) $ trail_right u++vbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+vbar 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+  where+    line1 = moveStart (go_up $ 0.1 * u) $ hbar u+    line2 = moveStart (go_down $ 0.1 * u) $ hbar u+++dbl_vbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u+dbl_vbar u = line1 <> line2+  where+    line1 = moveStart (go_left $ 0.1 * u) $ vbar u+    line2 = moveStart (go_right $ 0.1 * u) $ vbar u
− src/Wumpus/Drawing/Chains.hs 
@@ -1,29 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Chains--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Shim module.------ WARNING - very unstable.--------------------------------------------------------------------------------------module Wumpus.Drawing.Chains-  (-    module Wumpus.Drawing.Chains.Base-  , module Wumpus.Drawing.Chains.Derived-  --  ) where---import Wumpus.Drawing.Chains.Base-import Wumpus.Drawing.Chains.Derived
− src/Wumpus/Drawing/Chains/Base.hs 
@@ -1,117 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Chains.Base--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Generate points in an iterated chain.------ \*\* WARNING \*\* - unstable. Names are not so good, also --- Wumpus-Basic has a @chain1@ operator...--------------------------------------------------------------------------------------module Wumpus.Drawing.Chains.Base-  (--    Chain-  , LocChain-  , unchain-  , zipchain-  , zipchainWith--  , unchainTD-  , zipchainTD-  , zipchainWithTD----  ) where--import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core------ | A 'Chain' is a list of points. The list is often expected to --- be inifinte, but if it was a Stream  it would loose the ability--- to use list comprehensions.--- -type Chain u = [Point2 u]----- | A LocChain is a function from a starting point to a 'Chain'.--- -type LocChain u = Point2 u -> Chain u----- | Note - commonly a 'Chain' may be infinite, so it is only --- unrolled a finite number of times.----unchain :: Int -> LocGraphic u -> Chain u -> TraceDrawing u ()-unchain i op chn = go i chn-  where-    go n _      | n <= 0 = return ()-    go _ []              = return () -    go n (x:xs)          = draw (op `at` x) >> go (n-1) xs-------zipchain :: [LocGraphic u] -> Chain u -> TraceDrawing u ()-zipchain (g:gs) (p:ps)   = draw (g `at` p) >> zipchain gs ps-zipchain _      _        = return ()---zipchainWith :: (a -> LocGraphic u) -> [a] -> Chain u -> TraceDrawing u ()-zipchainWith op xs chn = go xs chn -  where-    go (a:as) (p:ps)   = draw (op a `at` p) >> go as ps-    go _      _        = return ()------ | Variant of 'unchain' where the drawing argument is a --- @TraceDrawing@ not a @LocGraphic@. ----unchainTD :: Int -> (Point2 u -> TraceDrawing u ()) -> Chain u -> TraceDrawing u ()-unchainTD i op chn = go i chn-  where-    go n _      | n <= 0 = return ()-    go _ []              = return () -    go n (x:xs)          = (op x) >> go (n-1) xs---zipchainTD :: [Point2 u -> TraceDrawing u ()] -> Chain u -> TraceDrawing u ()-zipchainTD (g:gs) (p:ps)   = g p >> zipchainTD gs ps-zipchainTD _      _        = return ()----zipchainWithTD :: (a -> Point2 u -> TraceDrawing u ()) -> [a] -> Chain u -> TraceDrawing u ()-zipchainWithTD op xs chn = go xs chn -  where-    go (a:as) (p:ps)   = op a p >> go as ps-    go _      _        = return ()------ Notes - something like TikZ\'s chains could possibly be --- achieved with a Reader monad (@local@ initially seems better --- for \"state change\" than @set@ as local models a stack). ------ It\'s almost tempting to put point-supply directly in the--- Trace monad so that TikZ style chaining is transparent.--- (The argument against is: how compatible this would be with--- the Turtle monad for example?).----
− src/Wumpus/Drawing/Chains/Derived.hs 
@@ -1,126 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Chains.Derived--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Generate points in an iterated chain.------ WARNING - very unstable.--------------------------------------------------------------------------------------module Wumpus.Drawing.Chains.Derived-  (-    -    tableDown-  , tableRight--  , horizontal-  , vertical--  , horizontals-  , verticals--  ) where--import Wumpus.Drawing.Chains.Base--import Wumpus.Basic.Kernel                      -- package: wumpus-basic------------------------------------------------------------------------------------- Tables---- Note - for the minor runtime cost, pairing the row_width and --- row_height should make the API more /memorable/...----- | 'tableDown' : @ num_rows * (row_width, row_height) -> LocChain @------ The table grows down and right, the implicit initial point is --- @top-left@.----tableDown :: Num u => Int -> (u,u) -> LocChain u-tableDown n (rw,rh) pt = map fn ints-  where-    ints = iterate (+1) 0-    fn i = let (x,y) = i `divMod` n -           in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt----- | 'tableRight' : @ num_cols * row_width * row_height -> LocChain @------ The table grows right and down, the implicit initial point is --- @top-left@.------ This chain is infinite.----tableRight :: Num u => Int -> (u,u) -> LocChain u-tableRight n (rw,rh) pt = map fn ints-  where-    ints = iterate (+1) 0-    fn i = let (y,x) = i `divMod` n -           in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt-------- | 'horizontal' : @ horizontal_dist -> LocChain @------ The chain grows right by the supplied increment.------ This chain is infinite.------ \*\* WARNING \*\* - name due to be changed. Current name is --- too general for this function. ----horizontal :: Num u => u -> LocChain u-horizontal dx = iterate (displaceH dx)----- | 'vertical' : @ vertical_dist -> LocChain @------ The chain grows up by the supplied increment.------ This chain is infinite.------ \*\* WARNING \*\* - name due to be changed. Current name is --- too general for this function. ----vertical :: Num u => u -> LocChain u-vertical dy = iterate (displaceV dy) ----- | 'horizontals' : @ [horizontal_dist] -> LocChain @------ This is a @scanl@ successive displacing the start point.------ This chain is finite (for finite input list).------ \*\* WARNING \*\* - name due to be changed. Current name is --- too general for this function. ----horizontals :: Num u => [u] -> LocChain u-horizontals xs = \pt -> scanl (flip displaceH) pt xs ----- | 'verticals' : @ [vertical_dist] -> LocChain @------ This is a @scanl@ successive displacing the start point.------ This chain is finite (for finite input list).------ \*\* WARNING \*\* - name due to be changed. Current name is --- too general for this function. ----verticals :: Num u => [u] -> LocChain u-verticals ys = \pt -> scanl (flip displaceV) pt ys--
+ src/Wumpus/Drawing/Connectors.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Shim module for Connectors.+-- +-- \*\* WARNING \*\* - this is due to change...+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors+  ( +    module Wumpus.Drawing.Connectors.Arrowheads+  , module Wumpus.Drawing.Connectors.Base+  , module Wumpus.Drawing.Connectors.ConnectorProps++  ) where++import Wumpus.Drawing.Connectors.Arrowheads+import Wumpus.Drawing.Connectors.Base+import Wumpus.Drawing.Connectors.ConnectorProps
+ src/Wumpus/Drawing/Connectors/Arrowheads.hs view
@@ -0,0 +1,453 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.Arrowheads+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Arrowheads.+--+-- \*\* WARNING \*\* - naming scheme due to change.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.Arrowheads+  (++    tri90+  , tri60+  , tri45+  , otri90+  , otri60+  , otri45++  , revtri90+  , revtri60+  , revtri45+  , orevtri90+  , orevtri60+  , orevtri45++  , barb90+  , barb60+  , barb45+  , revbarb90+  , revbarb60+  , revbarb45++  , perp+  , bracket++  , diskTip+  , odiskTip++  , squareTip+  , osquareTip++  , diamondTip+  , odiamondTip++  , diamondWideTip+  , odiamondWideTip++  , curveTip+  , revcurveTip++  ) where+++import Wumpus.Drawing.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.VectorSpace++import Data.Monoid+++++++-- | 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 = solid_line -- reset_drawing_metrics++++type TrailGen = Radian -> AnaTrail En+++fillTrailTip :: TrailGen -> LocThetaGraphic En+fillTrailTip gen_pt = +    localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta ->+      supplyLoc pt $ renderAnaTrail CFILL $ gen_pt theta++closedTrailTip :: TrailGen -> LocThetaGraphic En+closedTrailTip gen_pt = +    localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->+      supplyLoc pt $ renderAnaTrail CSTROKE $ gen_pt theta+++openTrailTip :: TrailGen -> LocThetaGraphic En+openTrailTip gen_pt = +    localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->+      supplyLoc pt $ renderAnaTrail OSTROKE $ gen_pt theta++++++-- | All three lines are stated.+--+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 = 1+      , tip_half_len     = 0.5+      , tip_deco         = fillTrailTip $ closedTriTrail ang+      }++--+-- 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+tri90 = filledTri ang90++-- | Filled triangle - apex is 60 deg.+--+tri60 :: ArrowTip+tri60 = filledTri ang60++-- | Filled triangle - apex is 45 deg.+--+tri45 :: ArrowTip+tri45 = filledTri ang45+++strokedClosedTri :: Radian -> ArrowTip+strokedClosedTri ang = +    ArrowTip+      { retract_distance = 1+      , tip_half_len     = 0.5+      , tip_deco         = closedTrailTip $ closedTriTrail ang+      }+++otri90 :: ArrowTip+otri90 = strokedClosedTri ang90++otri60 :: ArrowTip+otri60 = strokedClosedTri ang60++otri45 :: ArrowTip+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 = 0.5+      , tip_half_len     = 0.5+      , tip_deco         = fillTrailTip $ revClosedTriSpec ang+      }+++revtri90 :: ArrowTip+revtri90 = filledRevTri ang90++revtri60 :: ArrowTip+revtri60 = filledRevTri ang60++revtri45 :: ArrowTip+revtri45 = filledRevTri ang45+++strokedClosedRevTri :: Radian -> ArrowTip+strokedClosedRevTri ang = +    ArrowTip+      { retract_distance = 1+      , tip_half_len     = 0.5+      , tip_deco         = closedTrailTip $ revClosedTriSpec ang+      }++orevtri90 :: ArrowTip+orevtri90 = strokedClosedRevTri ang90++orevtri60 :: ArrowTip+orevtri60 = strokedClosedRevTri ang60++orevtri45 :: ArrowTip+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 = 0+      , tip_half_len     = 0.5+      , tip_deco         = openTrailTip $ barbSpec ang+      }++barb90 :: ArrowTip+barb90 = strokedBarb ang90++barb60 :: ArrowTip+barb60 = strokedBarb ang60++barb45 :: ArrowTip+barb45 = strokedBarb ang45+++revBarbSpec :: Radian -> TrailGen+revBarbSpec ang = \theta -> incline_barb ang (avec theta (-1))++strokedRevBarb :: Radian -> ArrowTip+strokedRevBarb ang = +    ArrowTip+      { retract_distance = 1+      , tip_half_len     = 0.5+      , tip_deco         = openTrailTip $ revBarbSpec ang +      }+++revbarb90 :: ArrowTip+revbarb90 = strokedRevBarb ang90++revbarb60 :: ArrowTip+revbarb60 = strokedRevBarb ang60++revbarb45 :: ArrowTip+revbarb45 = strokedRevBarb ang45+++perpSpec :: TrailGen+perpSpec ang = +    anaCatTrail (theta_up 0.5 ang) $ trail_theta_down 1 ang++perp :: ArrowTip+perp = +    ArrowTip+      { retract_distance = 0+      , tip_half_len     = 0+      , tip_deco         = openTrailTip perpSpec+      }+++bracketSpec :: TrailGen+bracketSpec ang = anaCatTrail (orthoVec (-0.5) 0.5 ang) catt+  where+    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 = 0.0+      , tip_half_len     = 0.5+      , tip_deco         = openTrailTip bracketSpec+      }++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 = 0.5+      , tip_half_len     = 0.5+      , tip_deco         = promoteLocTheta $ \pt theta -> +                             diskBody DRAW_FILL theta `at` pt+      }+++odiskTip :: ArrowTip+odiskTip = +    ArrowTip+      { retract_distance = 1+      , tip_half_len     = 0.5+      , tip_deco         = promoteLocTheta $ \pt theta -> +                             diskBody DRAW_STROKE theta `at` pt+      }+++-- | Note - need to draw square East-West rather than West-East+-- hence the base_width is negative.+--+squareSpec :: TrailGen+squareSpec theta = incline_square $ avec theta (-1)+++squareTip :: ArrowTip+squareTip = +    ArrowTip+      { retract_distance = 1+      , tip_half_len     = 0.5+      , tip_deco         = fillTrailTip squareSpec+      }+    ++osquareTip :: ArrowTip+osquareTip = +    ArrowTip+      { retract_distance = 1+      , tip_half_len     = 0.5+      , tip_deco         = closedTrailTip squareSpec+      }+++-- | squareSpec:+--+-- > +-- >       a+-- >     /   \+-- > ...w..v..o+-- >     \   / +-- >       b+--+diamondSpec :: En -> TrailGen+diamondSpec w theta = incline_diamond 1 $ avec theta (-w)++diamondTip :: ArrowTip+diamondTip = +    ArrowTip+      { retract_distance = 0.5+      , tip_half_len     = 0.5+      , tip_deco         = fillTrailTip $ diamondSpec 1+      }++odiamondTip :: ArrowTip+odiamondTip = +    ArrowTip+      { retract_distance = 1+      , tip_half_len     = 0.5+      , tip_deco         = closedTrailTip $ diamondSpec 1+      }+++diamondWideTip :: ArrowTip+diamondWideTip = +    ArrowTip+      { retract_distance = 1.0+      , tip_half_len     = 1.0+      , tip_deco         = fillTrailTip $ diamondSpec 2+      }++odiamondWideTip :: ArrowTip+odiamondWideTip = +    ArrowTip+      { retract_distance = 2.0+      , tip_half_len     = 1.0+      , tip_deco         = closedTrailTip $ diamondSpec 2+      }+++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+    v2  = orthoVec (-1.0) (-0.75) theta     -- back and down+++vectrapCW :: (Real u, Floating u) => Vec2 u -> CatTrail u+vectrapCW v1 = trapCurve CW w h quarter_pi ang+  where+    w   = vlength v1+    h   = w / 4+    ang = vdirection v1+++vectrapCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u+vectrapCCW v1 = trapCurve CCW w h quarter_pi ang+  where+    w   = vlength v1+    h   = w / 4+    ang = vdirection v1+++curveTip :: ArrowTip+curveTip = +    ArrowTip+      { retract_distance = 0+      , tip_half_len     = 0.5+      , tip_deco         = body+      }+  where+    body = localize (cap_round . join_round . solid_stroke_tip) $ +             openTrailTip curveTipSpec++++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+    v2  = orthoVec   1.0  (-0.75) theta     -- fwd and down++++revcurveTip :: ArrowTip+revcurveTip = +    ArrowTip+      { retract_distance = 1+      , tip_half_len     = 0.5+      , tip_deco         = body+      }+  where+    body = localize (cap_round . join_round . solid_stroke_tip) $ +             openTrailTip curveTipRevSpec++
+ src/Wumpus/Drawing/Connectors/Base.hs view
@@ -0,0 +1,168 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.Base+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Connectors...+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.Base+  ( +++    ConnectorPathQuery+  , SpacingProjection++  , ArrowTip(..)+  , ArrowConnector++  , ConnectorConfig(..)+  , ConnectorPathSpec(..)+  , renderConnectorConfig++  , arrowDecoratePath++  , leftArrowConnector+  , rightArrowConnector+  , uniformArrowConnector++  ) where++import Wumpus.Drawing.Connectors.ConnectorProps+import Wumpus.Drawing.Paths++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.Monoid+++++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 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 :: En+      , tip_half_len     :: En+      , tip_deco         :: LocThetaGraphic En+      }+++newtype ConnectorPathSpec u = ConnectorPathSpec { +      getConnectorPathSpec :: ConnectorProps -> ConnectorPathQuery u }++-- | total_path is the path before accounting for arrow +-- retract distances.+--+data ConnectorConfig u = ConnectorConfig+      { conn_arrowl     :: Maybe ArrowTip+      , conn_arrowr     :: Maybe ArrowTip+      , conn_path_spec  :: ConnectorPathSpec u +      }++++-- Ideally there should be a plus operation to combine tips +-- allowing double tips.+-- ++type ArrowConnector u = ConnectorImage u (AbsPath u)+++++-- | NOTE - the prefix /render/ needs (re-) consideration...+-- +-- If it is a good prefix other functions e.g. drawPath should +-- use render rather than draw.+--+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)+++-- | Shorthand...+--+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 }+    +
+ src/Wumpus/Drawing/Connectors/BoxConnectors.hs view
@@ -0,0 +1,116 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.BoxConnectors+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Box connectors+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.BoxConnectors+  ( +    ConnectorBox+  , ConnectorBoxSpec(..)+  , renderConnectorBoxSpec++  , conn_box+  , conn_tube+  , conn_chamf_box +++  ) where++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+++-- NOTE - boxes seem to only support stroke otherwise+-- they would obliterate what they connect.++++-- | The type of BoxConnectors - a query from start and end point +-- to a Path. +-- +-- Note - unlike a @Connector@, a BoxConnnector is expected to be +-- closed, then filled, stroked or bordered.+--+type ConnectorBox u = ConnectorGraphic u++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.+--++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 +++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 ->+    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)+    +++-- | Draw a stroked, rectangular box around the connector points.+--+-- 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))+++-- | Draw a stroked, tube around the connector points.+--+-- 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))+
+ src/Wumpus/Drawing/Connectors/ConnectorPaths.hs view
@@ -0,0 +1,563 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.ConnectorPaths+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Primitive connectors+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.ConnectorPaths+  ( ++    conn_line++  , conna_arc+  , connb_arc++  , conn_hdiagh+  , conn_vdiagv+  +  , conn_diagh+  , conn_diagv++  , conn_hdiag+  , conn_vdiag++  , conna_bar+  , connb_bar+  +  , conna_flam+  , connb_flam++  , conna_orthohbar+  , connb_orthohbar++  , conna_orthovbar+  , connb_orthovbar++  , conna_right+  , connb_right++  , 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.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative+++++-- | Build as Path as a CatTrail between two points.+--+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.+--+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ConnectorPathSpec u+conn_line = catConnector $ \_ p0 p1 -> pure $ catline $ pvec p0 p1+++++-- | Form an arc connector.+-- +-- If the conn_arc_angle in the Drawing context is positive the arc+-- will be formed /above/ the straight line joining the points. +-- If the angle is negative it will be drawn below. +-- +-- The notion of /above/ is respective to the line direction, of +-- course.+-- +-- TODO - above and below versions...+--+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+        h       = (0.5 * vlength v1) * (fromRadian $ tan arc_ang)+    in return $ horizontally (rightf h) (leftf h) v1 +++++-- | Horizontal-diagonal-horizontal connector.+--+-- >      --@+-- >     /+-- >  o--+-- +-- Horizontal /arms/ are drawn from the start and end points, a+-- diagonal segment joins the arms. +-- +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.+--+-- >  @+-- >  |+-- >   \+-- >    |+-- >    o+--+-- Vertical /arms/ are drawn from the start and end points, a+-- diagonal segment joins the arms. +-- +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.+--+-- >    --@+-- >   /+-- >  o+-- +-- Restricted variant of 'hconndiag' - a diagonal segment is drawn +-- from the start point joining a horizontal arm drawn from the +-- end point+-- +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.+--+-- >    @+-- >    |+-- >   /+-- >  o+--+-- Restricted variant of 'vconndiag' - a diagonal segment is drawn +-- from the start point joining a vertical arm drawn from the end +-- point.+-- +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++++-- | Horizontal-diagonal connector.+--+-- >      @+-- >     /+-- >  o--+--+-- Restricted variant of 'hconndiag' - a horizontal arm is drawn+-- from the start point joining a diagonal segment drawn from the +-- end point.+-- +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.+--+-- >    @+-- >   /+-- >  |+-- >  o+--+-- Restricted variant of 'vconndiag' - a horizontal arm is drawn+-- from the start point joining a vertical segment drawn from the +-- end point.+-- +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 +-- ClockDirection instead?+--+++-- | Bar connector.+--+-- >  ,----, +-- >  |    |+-- >  o    @  +--+-- The bar is drawn /above/ the points.+--+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.+-- +-- >  o    @ +-- >  |    |+-- >  '----'  +--+-- The bar is drawn /below/ the points.+--+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.+-- +-- >  ,----@ +-- >  | +-- >  o   +--+-- The bar is drawn /above/ the points.+--+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.+-- +-- >       @ +-- >       |+-- >  o----'  +--+-- The bar is drawn /below/ the points.+--+connb_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) +            => ConnectorPathSpec u+connb_right = catConnector $ \_ p0 p1 -> +    return $ trail_hright $ pvec p0 p1+++++-- | Connector with two horizontal segments and a joining +-- vertical segment.+--+-- >       ,--@+-- >       |+-- >  o----'  +--+-- The length of the first horizontal segment is the source arm +-- length. The length of the final segment is the remaining +-- horizontal distance. +--+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 +-- vertical segment.+--+-- >     ,----@+-- >     |+-- >  o--'  +--+-- The length of the final horizontal segment is the destination +-- arm length. The length of the initial segment is the remaining+-- horizontal distance. +--+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...+--+-- >       @+-- >       |+-- >  ,----'+-- >  |+-- >  o  +--+-- 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...+--+-- >       @+-- >       |+-- >  ,----'+-- >  |+-- >  o  +--+-- 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++++-- | Loop connector.+--+-- >  ,---------, +-- >  |         |+-- >  '-o    @--'+--+-- The loop is drawn /above/ the points.+--+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.+--+-- >  ,-o    @--, +-- >  |         |+-- >  '---------'+--+-- The loop is drawn /below/ the points.+--+connb_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) +           => ConnectorPathSpec u+connb_loop = connLoopBody (trail_rect_loop CCW) (trail_rect_loop CW)+++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.+--+-- >  *--@ +-- >    .  +-- >   . +-- >  o--*  +--+-- Note - the source and dest arm lengths are doubled, generally +-- this produces nicer curves.+-- +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 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++    left  p0 p1 h0 h1 = return $ curve1 p0 (p0 .-^ hvec h0) (p1 .+^ hvec h1) p1+++-- | Bezier curve connector - the control points are positioned +-- vertically respective to the source and dest.+--+-- >        @ +-- >       .|  +-- >  *  .  *+-- >  |.+-- >  o+--+-- Note - the source and dest arm lengths are doubled, generally +-- this produces nicer curves.+--+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 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+++
+ src/Wumpus/Drawing/Connectors/ConnectorProps.hs view
@@ -0,0 +1,158 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Connectors.ConnectorProps+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Connectors...+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Connectors.ConnectorProps+  ( ++    -- * Data types+    ConnectorProps(..)+  , default_connector_props++  -- * Queries+  , connectorSrcSpace+  , connectorDstSpace+  , connectorArms+  , connectorLegs+  , connectorLoopSize+  , connectorBoxHalfSize ++  ) where+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative++++-- | ConnectorProps control the drawing of connectors in +-- Wumpus-Drawing.+--+-- > conn_src_space     :: Em+-- > conn_dst_space     :: Em+--+-- Source and destination offsets - these offset the drawing of+-- the connector perpendicular to the direction of line formed +-- between the connector points (a positive offset is drawn above, +-- a negative offset below). The main use of offsets is to draw+-- parallel line connectors.+--+-- > conn_arc_ang       :: Radian +--+-- Control the /bend/ of an arc connector.+-- +-- > conn_src_arm       :: Em+-- > conn_dst_arm       :: Em +--+-- Control the /arm/ length of a jointed connector - arms are the +-- initial segments of the connector. +--+-- > conn_loop_size     :: Em+--+-- Control the /height/ of a loop connector. +--+-- > conn_box_halfsize  :: Em+-- +-- Control the size of a connector box. Connector boxes are +-- drawn with the exterior lines projected out from the connector+-- points a halfsize above and below.+-- +data ConnectorProps = ConnectorProps+      { conn_src_space       :: !Em+      , conn_dst_space       :: !Em+      , conn_arc_ang         :: !Radian+      , conn_src_arm         :: !Em+      , conn_dst_arm         :: !Em+      , conn_loop_size       :: !Em+      , conn_box_halfsize    :: !Em+      }+  deriving (Eq,Show)+++-- | Default connector properties.+--+-- > conn_src_sep:        0+-- > conn_dst_sep:        0+-- > conn_arc_ang:        pi / 12+-- > conn_src_arm:        1+-- > conn_dst_arm:        1+-- > conn_loop_size:      2 +-- > conn_box_half_size:  2+--+-- Arc angle is 15deg - quite shallow.+--+default_connector_props :: ConnectorProps+default_connector_props = +    ConnectorProps { conn_src_space    = 0+                   , conn_dst_space    = 0+                   , conn_arc_ang      = pi / 12+                   , conn_src_arm      = 1+                   , conn_dst_arm      = 1+                   , conn_loop_size    = 2 +                   , conn_box_halfsize = 1+                   }+++++--------------------------------------------------------------------------------+-- Queries+++connectorSrcSpace :: (DrawingCtxM m, InterpretUnit u) +                  => ConnectorProps -> m u+connectorSrcSpace props = +    (\sz -> uconvert1 sz $ conn_src_space props) <$> pointSize+++connectorDstSpace :: (DrawingCtxM m, InterpretUnit u) +                  => ConnectorProps -> m u+connectorDstSpace props = +    (\sz -> uconvert1 sz $ conn_dst_space props) <$> pointSize+++connectorArms :: (DrawingCtxM m, InterpretUnit u) +              => ConnectorProps -> m (u,u)+connectorArms props = +    (\sz -> ( uconvert1 sz $ conn_src_arm props+            , uconvert1 sz $ conn_dst_arm props) )+        <$> pointSize++-- | /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++++connectorLoopSize :: (DrawingCtxM m, InterpretUnit u) +                  => ConnectorProps -> m u+connectorLoopSize props = +    (\sz -> uconvert1 sz $ conn_loop_size props) <$> pointSize+++connectorBoxHalfSize :: (DrawingCtxM m, InterpretUnit u) +                  => ConnectorProps -> m u+connectorBoxHalfSize props = +    (\sz -> uconvert1 sz $ conn_box_halfsize props) <$> pointSize+
src/Wumpus/Drawing/Dots/AnchorDots.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -31,10 +29,18 @@   , DDotLocImage    -- * Dots with anchor points+  , smallDisk+  , largeDisk++  , smallCirc+  , largeCirc+++  , dotNone   , dotChar   , dotText-  , dotHLine-  , dotVLine+  , dotHBar+  , dotVBar   , dotX   , dotPlus   , dotCross@@ -57,12 +63,11 @@   ) where  -import Wumpus.Drawing.Geometry.Intersection-import Wumpus.Drawing.Geometry.Paths-import Wumpus.Drawing.Dots.Marks-import Wumpus.Drawing.Text.LRText+import Wumpus.Drawing.Dots.SimpleDots ( MarkSize )+import qualified Wumpus.Drawing.Dots.SimpleDots as SD+import Wumpus.Drawing.Paths.Intersection -import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Kernel                      -- package: wumpus-basic            import Wumpus.Core                              -- package: wumpus-core @@ -71,23 +76,26 @@  import Control.Applicative --- An existential thing that supports anchors.--- This means any dot can retun the same (opaque) structure------ But it does mean that which anchor class are supported is --- fixed - the datatype needs a field for each one.--- Supporting north, southeast etc. will also be tedious...----data DotAnchor u = forall s.  -                    DotAnchor { center_anchor   :: Point2 u-                              , radial_anchor   :: Radian   -> Point2 u-                              , cardinal_anchor :: Cardinal -> Point2 u } -data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW-  deriving (Eq,Show) +-- | All dots return the same thing a 'DotAnchor' which supports +-- the same (limited) see of anchors.+--+data DotAnchor u = DotAnchor +      { center_anchor   :: Point2 u+      , radial_anchor   :: Radian   -> Point2 u+      , cardinal_anchor :: Cardinal -> Point2 u +      }  type instance DUnit (DotAnchor u) = u +instance Num u => Translate (DotAnchor u) where+  translate x y (DotAnchor ctr radialF cardinalF) = +      DotAnchor { center_anchor   = translate x y ctr+                , radial_anchor   = translate x y . radialF +                , cardinal_anchor = translate x y . cardinalF +                }++ instance CenterAnchor (DotAnchor u) where   center (DotAnchor ca _ _) = ca @@ -95,117 +103,153 @@    radialAnchor theta (DotAnchor _ ra _) = ra theta  instance CardinalAnchor (DotAnchor u) where-   north (DotAnchor _ _ c1) = c1 NN-   south (DotAnchor _ _ c1) = c1 SS-   east  (DotAnchor _ _ c1) = c1 EE-   west  (DotAnchor _ _ c1) = c1 WW+   north (DotAnchor _ _ c1) = c1 NORTH+   south (DotAnchor _ _ c1) = c1 SOUTH+   east  (DotAnchor _ _ c1) = c1 EAST+   west  (DotAnchor _ _ c1) = c1 WEST    instance CardinalAnchor2 (DotAnchor u) where-   northeast (DotAnchor _ _ c1) = c1 NE-   southeast (DotAnchor _ _ c1) = c1 SE-   southwest (DotAnchor _ _ c1) = c1 SW-   northwest (DotAnchor _ _ c1) = c1 NW+   northeast (DotAnchor _ _ c1) = c1 NORTH_EAST+   southeast (DotAnchor _ _ c1) = c1 SOUTH_EAST+   southwest (DotAnchor _ _ c1) = c1 SOUTH_WEST+   northwest (DotAnchor _ _ c1) = c1 NORTH_WEST   radialCardinal :: Floating u => u -> Point2 u -> Cardinal -> Point2 u-radialCardinal rad ctr NN = ctr .+^ (avec (pi/2)     rad) -radialCardinal rad ctr NE = ctr .+^ (avec (pi/4)     rad) -radialCardinal rad ctr EE = ctr .+^ (avec  0         rad) -radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) -radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) -radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) -radialCardinal rad ctr WW = ctr .+^ (avec  pi        rad) -radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad) +radialCardinal rad ctr NORTH        = ctr .+^ (avec (pi/2)     rad) +radialCardinal rad ctr NORTH_EAST   = ctr .+^ (avec (pi/4)     rad) +radialCardinal rad ctr EAST         = ctr .+^ (avec  0         rad) +radialCardinal rad ctr SOUTH_EAST   = ctr .+^ (avec (7/4 * pi) rad) +radialCardinal rad ctr SOUTH        = ctr .+^ (avec (6/4 * pi) rad) +radialCardinal rad ctr SOUTH_WEST   = ctr .+^ (avec (5/4 * pi) rad) +radialCardinal rad ctr WEST         = ctr .+^ (avec  pi        rad) +radialCardinal rad ctr NORTH_WEST   = ctr .+^ (avec (3/4 * pi) rad)    -- Rectangle cardinal points are at \"middles and corners\". --  rectCardinal :: Floating u => u ->  u -> Point2 u -> Cardinal -> Point2 u-rectCardinal _  hh ctr NN = ctr .+^ (vvec hh) -rectCardinal hw hh ctr NE = ctr .+^ (vec  hw     hh) -rectCardinal hw _  ctr EE = ctr .+^ (hvec hw) -rectCardinal hw hh ctr SE = ctr .+^ (vec  hw    (-hh)) -rectCardinal _  hh ctr SS = ctr .+^ (vvec (-hh)) -rectCardinal hw hh ctr SW = ctr .+^ (vec  (-hw) (-hh) )-rectCardinal hw _  ctr WW = ctr .+^ (hvec (-hw)) -rectCardinal hw hh ctr NW = ctr .+^ (vec  (-hw)  hh) +rectCardinal _  hh ctr NORTH        = ctr .+^ (vvec hh) +rectCardinal hw hh ctr NORTH_EAST   = ctr .+^ (vec  hw     hh) +rectCardinal hw _  ctr EAST         = ctr .+^ (hvec hw) +rectCardinal hw hh ctr SOUTH_EAST   = ctr .+^ (vec  hw    (-hh)) +rectCardinal _  hh ctr SOUTH        = ctr .+^ (vvec (-hh)) +rectCardinal hw hh ctr SOUTH_WEST   = ctr .+^ (vec  (-hw) (-hh) )+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 NN = f (0.5  * pi)-polyCardinal f NE = f (0.25 * pi) -polyCardinal f EE = f 0 -polyCardinal f SE = f (1.75 * pi) -polyCardinal f SS = f (1.5  * pi) -polyCardinal f SW = f (1.25 * pi)-polyCardinal f WW = f pi -polyCardinal f NW = f (0.75 * pi)  +-- | All anchors are the center!+--+zeroAnchor :: Point2 u -> DotAnchor u+zeroAnchor ctr = +    DotAnchor { center_anchor   = ctr+              , radial_anchor   = const ctr +              , cardinal_anchor = const ctr }  -rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u+rectangleAnchor :: (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 =  maybe ctr id $ findIntersect ctr theta -                             $ rectangleLines ctr hw hh-+    fn theta = let mb_v1 = rectangleRadialIntersect (2*hw) (2*hh) theta+               in displace (maybe zeroVec id  mb_v1) ctr -polygonAnchor :: (Real u, Floating u) => [Point2 u] -> Point2 u -> DotAnchor u-polygonAnchor ps 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 = polyCardinal fn }+              , cardinal_anchor = radialCardinal hh ctr }   where-    fn theta =  maybe ctr id $ findIntersect ctr theta $ polygonLines ps+    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+              , radial_anchor   = fn +              , cardinal_anchor = radialCardinal rad ctr }+  where+    fn theta = displace (avec theta rad) ctr -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)    in rectangleAnchor hw hh (bl .+^ vec hw hh) -rectangleLDO :: (Real u, Floating u) -             => u -> u -> LocDrawingInfo u (DotAnchor u)-rectangleLDO w h = -    promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt +zeroLDO :: InterpretUnit u => LocQuery u (DotAnchor u)+zeroLDO = qpromoteLoc $ \pt -> return $ zeroAnchor pt -circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u-circleAnchor rad ctr = DotAnchor ctr -                                 (\theta -> ctr .+^ (avec theta rad))-                                 (radialCardinal rad ctr)+rectangleLDO :: (Real u, Floating u, InterpretUnit u, Tolerance u) +             => MarkSize -> MarkSize -> LocQuery u (DotAnchor u)+rectangleLDO w h = qpromoteLoc $ \pt -> +    (\uw uh -> rectangleAnchor (uw*0.5) (uh*0.5) pt) +      <$> uconvertCtx1 w <*> uconvertCtx1 h -circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u)-circleLDO = -    promoteR1 $ \pt -> -      markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt  --- This might be better taking a function: ctr -> poly_points--- ...----polygonLDO :: (Real u, Floating u, FromPtSize u) -           => (u -> Point2 u -> [Point2 u]) -> LocDrawingInfo u (DotAnchor u)-polygonLDO mk = -    promoteR1 $ \ctr -> -      markHeight >>= \h -> let ps = mk h ctr in pure $ polygonAnchor ps ctr+circleLDO :: (Floating u, InterpretUnit u) +          => MarkSize -> LocQuery u (DotAnchor u)+circleLDO rad = qpromoteLoc $ \pt -> +    uconvertCtx1 rad >>= \urad ->  pure $ circleAnchor urad pt  +-- Probably better just using bounding circle for polygons +-- If you really care about anchors use shapes+-- ++-- Triangle probably benefits proper calculation...++triangleLDO :: (Real u, Floating u, Tolerance u, InterpretUnit u) +            => MarkSize -> LocQuery u (DotAnchor u)+triangleLDO h = qpromoteLoc $ \pt -> +    (\uh -> triangleAnchor (uh*0.5) pt) +      <$> uconvertCtx1 h++ --------------------------------------------------------------------------------  -type DotLocImage u = LocImage u (DotAnchor u) +type DotLocImage u = LocImage u (DotAnchor u)  type DDotLocImage = DotLocImage Double  -dotChar :: (Floating u, Real u, FromPtSize u) => Char -> DotLocImage u++dotNone :: InterpretUnit u => DotLocImage u+dotNone = intoLocImage zeroLDO SD.dotNone++++smallDisk :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+smallDisk = intoLocImage (circleLDO 0.25) SD.smallDisk+++largeDisk :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+largeDisk = intoLocImage (circleLDO 1.00) SD.largeDisk++smallCirc :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+smallCirc = intoLocImage (circleLDO 0.25) SD.smallCirc+++largeCirc :: (Floating u, Real u, InterpretUnit u) => DotLocImage u+largeCirc = intoLocImage (circleLDO 1.00) SD.largeCirc+++dotChar :: (Floating u, Real u, InterpretUnit u, Tolerance u) +        => Char -> DotLocImage u dotChar ch = dotText [ch]  @@ -216,71 +260,83 @@ --  -dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u -dotText ss = fmap (bimapL bboxRectAnchor) (ctrCenterLine ss)+dotText :: (Floating u, Real u, InterpretUnit u, Tolerance u) +        => String -> DotLocImage u +dotText ss = +    fmap bboxRectAnchor $ runPosObjectBBox CENTER $ posText ss +-- Note - maybe Wumpus-Basic should have a @swapAns@ function? -dotHLine :: (Floating u, FromPtSize u) => DotLocImage u-dotHLine = intoLocImage circleLDO markHLine +dotHBar :: (Floating u, InterpretUnit u) => DotLocImage u+dotHBar = intoLocImage (circleLDO 0.5) SD.dotHBar -dotVLine :: (Floating u, FromPtSize u) => DotLocImage u-dotVLine = intoLocImage circleLDO markVLine +dotVBar :: (Floating u, InterpretUnit u) => DotLocImage u+dotVBar = intoLocImage (circleLDO 0.5) SD.dotVBar -dotX :: (Floating u, FromPtSize u) => DotLocImage u-dotX = intoLocImage circleLDO markX -dotPlus :: (Floating u, FromPtSize u) => DotLocImage u-dotPlus = intoLocImage circleLDO markPlus+dotX :: (Floating u, InterpretUnit u) => DotLocImage u+dotX = intoLocImage (circleLDO 0.5) SD.dotX -dotCross :: (Floating u, FromPtSize u) => DotLocImage u-dotCross = intoLocImage circleLDO markCross+dotPlus :: (Floating u, InterpretUnit u) => DotLocImage u+dotPlus = intoLocImage (circleLDO 0.5) SD.dotPlus -dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u-dotDiamond = intoLocImage circleLDO markDiamond+dotCross :: (Floating u, InterpretUnit u) => DotLocImage u+dotCross = intoLocImage (circleLDO 0.5) SD.dotCross -dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u-dotFDiamond = intoLocImage circleLDO markFDiamond+dotDiamond :: (Floating u, InterpretUnit u) => DotLocImage u+dotDiamond = intoLocImage (circleLDO 0.5) SD.dotDiamond +dotFDiamond :: (Floating u, InterpretUnit u) => DotLocImage u+dotFDiamond = intoLocImage (circleLDO 0.5) SD.dotFDiamond  -dotDisk :: (Floating u, FromPtSize u) => DotLocImage u-dotDisk = intoLocImage circleLDO markDisk +dotDisk :: (Floating u, InterpretUnit u) => DotLocImage u+dotDisk = intoLocImage (circleLDO 0.5) SD.dotDisk -dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u-dotSquare = -    lift0R1 markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare +dotSquare :: (Floating u, Real u, InterpretUnit u, Tolerance u) +          => DotLocImage u+dotSquare = intoLocImage (rectangleLDO 1 1) SD.dotSquare   -dotCircle :: (Floating u, FromPtSize u) => DotLocImage u-dotCircle = intoLocImage circleLDO markCircle +dotCircle :: (Floating u, InterpretUnit u) => DotLocImage u+dotCircle = intoLocImage (circleLDO 0.5) SD.dotCircle -dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u-dotPentagon = intoLocImage circleLDO markPentagon -dotStar :: (Floating u, FromPtSize u) => DotLocImage u-dotStar = intoLocImage circleLDO markStar+dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u+dotPentagon = intoLocImage (circleLDO 0.5) SD.dotPentagon +dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance u) +        => DotLocImage u+dotStar = intoLocImage (circleLDO 0.5) SD.dotStar -dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u-dotAsterisk = intoLocImage circleLDO markAsterisk -dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u-dotOPlus = intoLocImage circleLDO markOPlus+dotAsterisk :: (Floating u, InterpretUnit u) => DotLocImage u+dotAsterisk = intoLocImage (circleLDO 0.5) SD.dotAsterisk -dotOCross :: (Floating u, FromPtSize u) => DotLocImage u-dotOCross = intoLocImage circleLDO markOCross+dotOPlus :: (Floating u, InterpretUnit u) => DotLocImage u+dotOPlus = intoLocImage (circleLDO 0.5) SD.dotOPlus -dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u-dotFOCross = intoLocImage circleLDO markFOCross+dotOCross :: (Floating u, InterpretUnit u) => DotLocImage u+dotOCross = intoLocImage (circleLDO 0.5) SD.dotOCross +dotFOCross :: (Floating u, InterpretUnit u) => DotLocImage u+dotFOCross = intoLocImage (circleLDO 0.5) SD.dotFOCross -dotTriangle :: (Real u, Floating u, FromPtSize u) => DotLocImage u-dotTriangle = intoLocImage (polygonLDO fn) markTriangle-  where -    fn h ctr = let (bl,br,top) = equilateralTrianglePoints h ctr in [bl,br,top]++dotTriangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +            => DotLocImage u+dotTriangle = intoLocImage (triangleLDO 1) SD.dotTriangle+++intoLocImage :: InterpretUnit u +             => LocQuery u a -> LocImage u z -> LocImage u a+intoLocImage ma gf = promoteLoc $ \pt -> +                     askDC >>= \ctx -> +                     let ans = runLocQuery ctx pt ma+                     in replaceAns ans $ applyLoc gf pt
− src/Wumpus/Drawing/Dots/Marks.hs 
@@ -1,243 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Dots.Marks--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Marks - dots without anchor handles.------ The text and char marks need loaded glyph metrics for proper --- centering. ------ \*\* WARNING \*\* - names are expected to change - filled and--- background-filled marks need a naming convention.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Dots.Marks-  ( ---  -- * Marks-    markChar-  , markText--  , markHLine-  , markVLine-  , markX-  , markPlus-  , markCross-  , markDiamond-  , markFDiamond-  , markBDiamond -  , markDisk-  , markSquare-  , markCircle  -  , markPentagon-  , markStar-  , markAsterisk-  , markOPlus-  , markOCross-  , markFOCross-  , markTriangle--  ) where---import Wumpus.Drawing.Geometry.Paths-import Wumpus.Drawing.Text.LRText--import Wumpus.Basic.Kernel                      -- package: wumpus-basic--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace--import Control.Applicative---- Marks should be the height of a lower-case letter...---- NOTES------ TikZ has both stroked and bordered (filled and outline-stroked)--- marks e.g. square and square*--------infixr 9 `renderPathWith`--renderPathWith :: LocDrawingInfo u (PrimPath u) -               -> (PrimPath u -> Graphic u) -               -> LocGraphic u-renderPathWith m k = m >>= (lift0R1 . k)----markChar :: (Real u, Floating u, FromPtSize u) => Char -> LocGraphic u-markChar ch = markText [ch]-----markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u-markText ss = fmap (replaceL uNil) $ ctrCenterLine ss------- | Supplied point is the center.----axialLine :: Fractional u => Vec2 u -> LocGraphic u-axialLine v = moveStartPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)---markHLine :: (Fractional u, FromPtSize u) => LocGraphic u -markHLine = lift0R1 markHeight >>= \h -> axialLine (hvec h)---markVLine :: (Fractional u, FromPtSize u) => LocGraphic u -markVLine = lift0R1 markHeight >>= \h -> axialLine (vvec h) ---markX :: (Fractional u, FromPtSize u) => LocGraphic u-markX = lift0R1 markHeight >>= mkX -  where-    mkX h = let w = 0.75 * h-              in axialLine (vec w h) `oplus` axialLine (vec (-w) h)----markPlus :: (Fractional u, FromPtSize u) =>  LocGraphic u-markPlus = markVLine `oplus` markHLine---markCross :: (Floating u, FromPtSize u) =>  LocGraphic u-markCross = markHeight >>= mkCross-  where-    mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (-ang) h)-    ang       = pi*0.25  ---- Note - height is extended slightly to look good...--pathDiamond :: (Fractional u, FromPtSize u) -            => LocDrawingInfo u (PrimPath u)-pathDiamond = -    promoteR1 $ \pt -> -      markHeight >>= \h -> let cp = diamondCoordPath (0.5*h) (0.66*h) -                           in return $ coordinatePrimPath pt cp------ closedStroke :: (a -> ctx -> prim) --- pathDiamond  :: (ctx -> pt -> a)--- ans          :: (ctx -> pt -> prim)--markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markDiamond = pathDiamond `renderPathWith` closedStroke--markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markFDiamond = pathDiamond `renderPathWith` filledPath----- Note - the (const . fn) composition doesn\'t /tell/ much about--- what is going on - though obviously it can be decoded - make --- the function obvious to the second argument. --- --- A named combinator might be better.-----markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markBDiamond = pathDiamond `renderPathWith` borderedPath----- | Note disk is filled.----markDisk :: (Fractional u, FromPtSize u) => LocGraphic u-markDisk = lift0R1 markHalfHeight >>= filledDisk ----markSquare :: (Fractional u, FromPtSize u) => LocGraphic u-markSquare = -    lift0R1 markHeight >>= \h -> -    let d = 0.5*(-h) in moveStartPoint (displace d d) $ strokedRectangle h h-    ---markCircle :: (Fractional u, FromPtSize u) => LocGraphic u-markCircle = lift0R1 markHalfHeight >>= strokedDisk ---markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u-markBCircle = lift0R1 markHalfHeight >>= borderedDisk ----markPentagon :: (Floating u, FromPtSize u) => LocGraphic u-markPentagon = -    promoteR1 $ \pt -> -      markHeight >>= \h -> closedStroke $ pentagonPath pt (0.5*h)-  where-    pentagonPath pt hh = coordinatePrimPath pt $ polygonCoordPath 5 hh-- ---markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar = lift0R1 markHeight >>= \h -> starLines (0.5*h)--starLines :: Floating u => u -> LocGraphic u-starLines hh = -    promoteR1 $ \ctr -> let cp = polygonCoordPath 5 hh-                        in step $ map (fn ctr) $ cp ctr-  where-    fn p0 p1    = openStroke $ primPath p0 [lineTo p1]-    step (x:xs) = oconcat x xs-    step _      = error "starLines - unreachable"---markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u-markAsterisk = lift0R1 markHeight >>= asteriskLines--asteriskLines :: Floating u => u -> LocGraphic u-asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3-  where-    ang     = (pi*2) / 6-    lineF1  = axialLine (vvec h)-    lineF2  = axialLine (avec ((pi*0.5) + ang)    h)-    lineF3  = axialLine (avec ((pi*0.5) + ang + ang) h)---markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u-markOPlus = markCircle `oplus` markPlus---markOCross :: (Floating u, FromPtSize u) => LocGraphic u-markOCross = markCircle `oplus` markCross---markFOCross :: (Floating u, FromPtSize u) => LocGraphic u-markFOCross = markCross `oplus` markBCircle ----- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u--- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) ----markTriangle :: (Floating u, FromPtSize u) => LocGraphic u-markTriangle = tripath `renderPathWith` closedStroke-  where-    tripath = promoteR1 $ \pt -> -                markHeight >>= \h -> let cp = equilateralTriangleCoordPath h -                                     in pure $ coordinatePrimPath pt cp-
+ src/Wumpus/Drawing/Dots/SimpleDots.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Dots.SimpleDots+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Simple dots - no anchor handles.+-- +-- Use these where you just want to draw Dots, and do not need+-- connectors between them. +--+-- The text and char marks need loaded glyph metrics for proper +-- centering. +--+-- \*\* WARNING \*\* - names are expected to change - filled and+-- background-filled marks need a naming convention.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Dots.SimpleDots+  ( ++  -- * Unit for marks (0.75 the font size)+    MarkSize++  , smallDisk+  , largeDisk+  , smallCirc+  , largeCirc  ++++  -- * Dots+  , dotNone++  , dotChar+  , dotText+  , dotEscChar+  , dotEscText+++  , dotHBar+  , dotVBar+  , dotX+  , dotPlus+  , dotCross+  , dotDiamond+  , dotFDiamond+  , dotBDiamond +  , dotDisk+  , dotSquare+  , dotCircle  +  , dotPentagon+  , dotStar+  , dotAsterisk+  , dotOPlus+  , dotOCross+  , dotFOCross+  , dotTriangle++  ) where++import Wumpus.Drawing.Basis.ShapeTrails+import Wumpus.Drawing.Basis.Symbols++import Wumpus.Basic.Kernel        ++import Wumpus.Core                              -- package: wumpus-core++import Data.VectorSpace                         -- package: vector-space++import Data.Monoid++-- Marks should be the height of a lower-case letter...++-- NOTES+--+-- TikZ has both stroked and bordered (filled and outline-stroked)+-- marks e.g. square and square*+--++-- Cap height is a good size for Dots.+++-- | MarkUnit is a contextual unit like 'Em' and 'En'.+-- +-- It is 3\/4 of the current font size.+--+newtype MarkSize = MarkSize { getMarkSize :: Double }+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)++instance Show MarkSize where+  showsPrec p d = showsPrec p (getMarkSize d)+++instance InterpretUnit MarkSize where+  normalize sz a = (realToFrac  a) * 0.75 * fromIntegral sz+  dinterp sz d   = (4/3) * (realToFrac d) / (fromIntegral sz)++instance Tolerance MarkSize where +  eq_tolerance     = 0.001+  length_tolerance = 0.01+++umark :: InterpretUnit u => LocGraphic MarkSize -> LocGraphic u+umark = uconvF+++-- | Filled disk - radius 0.25 MarkSize.+--+smallDisk :: InterpretUnit u => LocGraphic u+smallDisk = umark $ dcDisk DRAW_FILL 0.25+++-- | Filled disk - radius 1.0 MarkSize.+--+largeDisk :: InterpretUnit u => LocGraphic u+largeDisk = umark $ dcDisk DRAW_FILL 1+++-- | Stroked disk (circle) - radius 0.25 MarkSize.+--+smallCirc :: InterpretUnit u => LocGraphic u+smallCirc = umark $ scircle 0.25+++-- | Stroked disk (circle) - radius 1.0 MarkSize.+--+largeCirc :: InterpretUnit u => LocGraphic u+largeCirc = umark $ scircle 1+++-- possibly:+-- szCirc :: u -> LocGraphic u++dotNone :: InterpretUnit u => LocGraphic u+dotNone = emptyLocImage++dotChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u+dotChar ch = dotText [ch]++++dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u+dotText ss = ignoreAns $ runPosObject CENTER $ posText ss++dotEscChar :: (Real u, Floating u, InterpretUnit u) +           => EscapedChar -> LocGraphic u+dotEscChar = dotEscText . wrapEscChar++dotEscText :: (Real u, Floating u, InterpretUnit u) +           => EscapedText -> LocGraphic u+dotEscText esc = ignoreAns $ runPosObject CENTER $ posEscText esc++-- TODO - need Upright versions of dots...++++-- | Supplied point is the center.+--+axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u+axialLine v = moveStart (negateV (0.5 *^ v)) (locStraightLine v)+++dotHBar :: (Fractional u, InterpretUnit u) => LocGraphic u +dotHBar = umark $ hbar 1+++dotVBar :: (Fractional u, InterpretUnit u) => LocGraphic u +dotVBar = umark $ vbar 1 +++dotX :: (Fractional u, InterpretUnit u) => LocGraphic u+dotX = umark $ axialLine (vec 0.75 1) `mappend` axialLine (vec (-0.75) 1)++++dotPlus :: (Fractional u, InterpretUnit u) =>  LocGraphic u+dotPlus = dotVBar `mappend` dotHBar+++dotCross :: (Floating u, InterpretUnit u) =>  LocGraphic u+dotCross = +    umark $ axialLine (avec ang 1) `mappend` axialLine (avec (-ang) 1)+  where +    ang = pi*0.25  ++++++dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u+dotDiamond = umark $ renderAnaTrail CSTROKE (diamondTrail 0.5 0.66)++dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u+dotFDiamond = umark $ renderAnaTrail CFILL (diamondTrail 0.5 0.66)++++dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u+dotBDiamond = umark $ renderAnaTrail CFILL_STROKE (diamondTrail 0.5 0.66)+++-- | Note disk is filled.+--+dotDisk :: (Fractional u, InterpretUnit u) => LocGraphic u+dotDisk = umark $ dcDisk DRAW_FILL 0.5++++dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u+dotSquare = umark $ renderAnaTrail CSTROKE (rectangleTrail 1 1)+++dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u+dotCircle = umark $ scircle 0.5+++dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u+dotBCircle = umark $ dcDisk DRAW_FILL_STROKE 0.5++++dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u+dotPentagon = umark $ renderAnaTrail CSTROKE (polygonTrail 5 0.5)+ +++dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance u) +        => LocGraphic u +dotStar = umark $ starLines 0.5++starLines :: (Floating u, Ord u, InterpretUnit u, Tolerance u) +          => u -> LocGraphic u+starLines hh = promoteLoc $ \ctr ->+    let alg = polygonTrail 5 hh+    in liftQuery (qapplyLoc (anaTrailPoints alg) ctr) >>= \ps -> +       step $ map (fn ctr) ps+  where+    fn p0 p1    = straightLine p0 p1+    step (x:xs) = mconcat $ x:xs+    step _      = error "starLines - unreachable"++dotAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u+dotAsterisk = umark $ asteriskLines 1++asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u+asteriskLines h = lineF1 `mappend` lineF2 `mappend` lineF3+  where+    ang     = (pi*2) / 6+    lineF1  = axialLine (vvec h)+    lineF2  = axialLine (avec ((pi*0.5) + ang)    h)+    lineF3  = axialLine (avec ((pi*0.5) + ang + ang) h)+++dotOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u+dotOPlus = dotCircle `mappend` dotPlus+++dotOCross :: (Floating u, InterpretUnit u) => LocGraphic u+dotOCross = dotCircle `mappend` dotCross+++dotFOCross :: (Floating u, InterpretUnit u) => LocGraphic u+dotFOCross = dotBCircle `mappend` dotCross+++-- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u+-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) ++++dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u+dotTriangle = umark $ renderAnaTrail CSTROKE $ isosceles_triangle_trail 1 1
+ src/Wumpus/Drawing/Extras/Axes.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Axes+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Drawing grids+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Axes+  ( +   +    orthontAxes+ +  , horizontalLabels+  , verticalLabels++  ) where++import Wumpus.Drawing.Connectors+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Core                              -- package: wumpus-core++import Data.Monoid++-- Note - axes need labels working out...+++-- | Simple orthonormal axes using snap grid units.+--+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 = ignoreAns conn_line+        xPtl  = P2 (x - (uw * fromIntegral xl)) y+        xPtr  = P2 (x + (uw * fromIntegral xr)) y+        yPtl  = P2 x (y - (uh * fromIntegral yl))+        yPtr  = P2 x (y + (uh * fromIntegral yr))+    in  localize cap_square $           ignoreAns (connect conn1 xPtl xPtr) +                              `mappend` ignoreAns (connect conn1 yPtl yPtr)++++horizontalLabels :: (Num a, Show a, Fractional u, InterpretUnit u) +                 => RectAddress -> [a] -> LocGraphic u +horizontalLabels addr ns = +    snapmove (1,1) >>= \(V2 uw _) -> ignoreAns (distribH uw $ map mf ns)+  where+    mf n = runPosObject addr $ posTextUpright $ show n+++verticalLabels :: (Num a, Show a, Fractional u, InterpretUnit u) +               => RectAddress -> [a] -> LocGraphic u +verticalLabels addr ns = +    snapmove (1,1) >>= \(V2 _ uh) -> ignoreAns (distribV uh $ map mf ns)+  where+    mf n = runPosObject addr $ posTextUpright $ show n++++-- Cf. Parsec\'s Token module - remake with same name...+--+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => ArrowConnector u+conn_line = rightArrowConnector default_connector_props C.conn_line barb45
+ src/Wumpus/Drawing/Extras/Clip.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Clip+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Clipping paths.+--+-- Note - at the moment there is nothing much to this module.+-- Ideally, clipping would be defined in Wumpus-Basic, but clipping+-- needs a higher level path object than Wumpus-Basic provides.+-- +-- \*\* WARNING \*\* names need improving.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Clip+  ( +   +    locClip++  ) where+++import Wumpus.Drawing.Paths++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++++-- | Clip a LocGraphic.+-- +-- \*\* WARNING \*\* - AbsPath (coordinate-specific) is the wrong +-- object to clip a LocGraphic (coordinate-free). +--+locClip :: InterpretUnit u => AbsPath u -> LocGraphic u -> LocGraphic u+locClip absp gf = promoteLoc $ \pt -> +    liftQuery (toPrimPath absp) >>= \pp -> clipImage pp (gf `at` pt)++
+ src/Wumpus/Drawing/Extras/Grids.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Grids+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Drawing grids+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Grids+  ( +   +    GridContextF+  , grid+  , standard_grid+  , dotted_major_grid++  , grid_major_colour+  , grid_major_line_width+  , grid_major_dotnum+  , grid_minor_subdivisions+  , grid_minor_colour+  , grid_minor_line_width+  , grid_minor_dotnum+  , grid_point_size+  , grid_label_colour++  ) where+++import Wumpus.Drawing.Basis.DrawingPrimitives++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Colour ( black )++import Data.Monoid+++type GridContextF = GridProps -> GridProps++-- | GridProps control the drawing of grids.+-- +data GridProps = GridProps+      { gp_major_colour   :: RGBi+      , gp_major_lnwidth  :: Double+      , gp_major_dotnum   :: Int+      , gp_minor_subdivs  :: Int+      , gp_minor_colour   :: RGBi+      , gp_minor_lnwidth  :: Double+      , gp_minor_dotnum   :: Int+      , gp_point_size     :: FontSize+      , gp_label_colour   :: RGBi+      }++default_grid_props :: GridProps+default_grid_props = +    GridProps { gp_major_colour     = grey1+              , gp_major_lnwidth    = 1+              , gp_major_dotnum     = 0+              , gp_minor_subdivs    = 5+              , gp_minor_colour     = grey2+              , gp_minor_lnwidth    = 0.5+              , gp_minor_dotnum     = 0+              , gp_point_size       = 10+              , gp_label_colour     = black+              }+  where+    grey1 = RGBi 100 100 100+    grey2 = RGBi 150 150 150 +++++standard_grid :: GridContextF+standard_grid = id++dotted_major_grid :: GridContextF+dotted_major_grid = +    grid_minor_subdivisions 0 . grid_major_dotnum 2++-- Setters for client code.++grid_major_colour :: RGBi -> GridContextF+grid_major_colour rgb = (\s -> s { gp_major_colour = rgb })++grid_major_line_width :: Double -> GridContextF+grid_major_line_width lw = (\s -> s { gp_major_lnwidth = lw })++grid_major_dotnum :: Int -> GridContextF+grid_major_dotnum n = (\s -> s { gp_major_dotnum = n })++grid_minor_subdivisions :: Int -> GridContextF+grid_minor_subdivisions n = (\s -> s { gp_minor_subdivs = n })++grid_minor_colour :: RGBi -> GridContextF+grid_minor_colour rgb = (\s -> s { gp_minor_colour = rgb })++grid_minor_line_width :: Double -> GridContextF+grid_minor_line_width lw = (\s -> s { gp_minor_lnwidth = lw })++grid_minor_dotnum :: Int -> GridContextF+grid_minor_dotnum n = (\s -> s { gp_minor_dotnum = n })+++grid_point_size :: FontSize -> GridContextF+grid_point_size i = (\s -> s { gp_point_size = i })+++grid_label_colour :: RGBi -> GridContextF+grid_label_colour rgb = (\s -> s { gp_label_colour = rgb })+++++-- Drawing context updaters...++major_line_update :: GridProps -> DrawingContextF+major_line_update (GridProps { gp_major_colour  = rgb+                             , gp_major_lnwidth = lnwidth+                             , gp_major_dotnum  = dotnum }) = +    lineProps rgb lnwidth dotnum ++minor_line_update :: GridProps -> DrawingContextF+minor_line_update (GridProps { gp_minor_colour  = rgb+                             , gp_minor_lnwidth = lnwidth+                             , gp_minor_dotnum  = dotnum }) = +    lineProps rgb lnwidth dotnum +++lineProps :: RGBi -> Double -> Int -> DrawingContextF+lineProps rgb lw n +    | n < 1     = stroke_colour rgb . set_line_width lw . solid_line +    | otherwise = stroke_colour rgb . set_line_width lw . dashesF +  where+    dashesF = set_dash_pattern $ Dash 0 [(1,n)]++++--------------------------------------------------------------------------------+++grid :: (Fractional u, InterpretUnit u) +     => GridContextF -> Int -> Int -> LocGraphic u  +grid upd nx ny = +    snapmove (1,1) >>= \(V2 uw uh) ->+    let props  = upd default_grid_props+        width  = uw * fromIntegral nx+        height = uh * fromIntegral ny+        intrr  = gridInterior nx width uw ny height uh props+        rect   = localize (major_line_update props) $ +                   blRectangle DRAW_STROKE width height+    in intrr `mappend` rect++                 ++gridInterior :: (Fractional u, InterpretUnit u) +             => Int -> u -> u -> Int -> u -> u -> GridProps -> LocGraphic u+gridInterior nx w uw ny h uh props = hlines `mappend` vlines+  where+    hlines = horizontalLines ny w uh props+    vlines = verticalLines   nx h uw props+++horizontalLines :: (Fractional u, InterpretUnit u) +                => Int -> u -> u -> GridProps -> LocGraphic u+horizontalLines numh w uh props@(GridProps { gp_minor_subdivs = subs })+    | subs > 0  = let dy = uh / (fromIntegral subs)+                      n  = (numh * subs) - 1+                  in moveStart (vvec dy) $ minorMajor n subs (vvec dy) mnr mjr+    | otherwise = moveStart (vvec uh) $ duplicate numh (vvec uh) mjr+  where+    mnr  = localize (minor_line_update props) $ horizontalLine w+    mjr  = localize (major_line_update props) $ horizontalLine w++++verticalLines :: (Fractional u, InterpretUnit u) +              => Int -> u -> u -> GridProps -> LocGraphic u+verticalLines numv h uw props@(GridProps { gp_minor_subdivs = subs })+    | subs > 0  = let dx = uw / (fromIntegral subs)+                      n  = (numv * subs) - 1+                  in moveStart (hvec dx) $ minorMajor n subs (hvec dx) mnr mjr+    | otherwise = moveStart (hvec uw) $ duplicate numv (hvec uw) mjr+  where+    mnr  = localize (minor_line_update props) $ verticalLine h+    mjr  = localize (major_line_update props) $ verticalLine h+++++minorMajor :: InterpretUnit u +           => Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u +           -> LocGraphic u+minorMajor count alt mv mnr mjr = runLocTrace (step count)+  where+    step n | n <= 0           = ureturn+           | n `mod` alt == 0 = insertl mjr >> moveby mv >> step (n-1)+           | otherwise        = insertl mnr >> moveby mv >> step (n-1)+ ++
+ src/Wumpus/Drawing/Extras/Loop.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Extras.Loop+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Open loop for a circle (useful for automata diagrams).+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Extras.Loop+  ( ++    loopPath+  , loopTrail++  ) where+++import Wumpus.Drawing.Paths++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++import Data.AffineSpace                         -- package: vector-space+++import Data.Monoid++++loopPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) +      => u -> Point2 u -> Radian -> AbsPath u+loopPath zradius ctr incl = anaTrailPath ctr $ loopTrail zradius incl+++++-- This is a legacy definition updated to use Trails, hence it is +-- not so clear.++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+    hminor      = 2.72  * circ_radius+    hbase       = circ_radius / 3+    theta       = toRadian $ asin $ hbase / circ_radius+    start_vec   = avec (circularModulo $ incl - quarter_pi) (0.26 * circ_radius)+    end_vec     = avec (circularModulo $ incl + quarter_pi) (0.26 * circ_radius)    +    minor_down  = negate $ 0.8 * circ_radius +    major_up    = 0.52 * circ_radius+    top_right   = negate $ 0.8 * circ_radius+    top_left    = 0.8 * circ_radius++    top         = dispParallel height incl zeroPt+    kiter       = dispOrtho hminor (-hw) incl zeroPt+    kitel       = dispOrtho hminor   hw  incl zeroPt+    +    startr      = zeroPt .+^ avec (circularModulo $ incl - theta) circ_radius+    startl      = zeroPt .+^ avec (circularModulo $ incl + theta) circ_radius++    -- quadrant III+    cp1         = startl .+^ end_vec +    cp2         = dispParallel minor_down incl kitel++    -- quadrant II +    cp3         = dispParallel major_up incl kitel+    cp4         = dispPerpendicular top_left incl top++    -- quadrant I+    cp5         = dispPerpendicular top_right incl top+    cp6         = dispParallel major_up incl kiter++    -- quadrant IV +    cp7         = dispParallel minor_down incl kiter+    cp8         = startr .+^ start_vec+
− src/Wumpus/Drawing/Geometry/Intersection.hs 
@@ -1,173 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Geometry.Intersection--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Intersection of line to line and line to plane--- --- \*\* - WARNING \*\* - half baked. --------------------------------------------------------------------------------------module Wumpus.Drawing.Geometry.Intersection-  ( -    LineSegment(..)-  , PointSlope-  , pointSlope-  , LineEqn-  , lineEqn-  , toLineEqn-  , findIntersect-  , intersection--  , rectangleLines-  , polygonLines-  , langle--  ) -  where--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace----- WARNING - This module is not very good (neither particularly --- robust, nor efficient).--- --- I really need to find an algorithm that does this properly.-----data LineSegment u = LS (Point2 u) (Point2 u)-  deriving (Eq,Ord,Show)---data PointSlope u = PointSlope -      { _point_slope_point :: Point2 u-      , _point_slope_slope :: u-      }-  deriving (Eq,Show)--pointSlope :: Fractional u => Point2 u -> Radian -> PointSlope u -pointSlope pt theta = PointSlope pt (fromRadian $ tan theta)----- | Line in equational form, i.e. @Ax + By + C = 0@.-data LineEqn u = LineEqn -      { _line_eqn_A :: !u-      , _line_eqn_B :: !u-      , _line_eqn_C :: !u -      }-  deriving (Eq,Show)--lineEqn :: Num u => Point2 u -> Point2 u -> LineEqn u-lineEqn (P2 x1 y1) (P2 x2 y2) = LineEqn a b c -  where-    a = y1 - y2-    b = x2 - x1-    c = (x1*y2) - (x2*y1)---toLineEqn :: Num u => PointSlope u -> LineEqn u-toLineEqn (PointSlope (P2 x0 y0) m) = LineEqn m (-1) ((-m) * x0 + y0)-----data IntersectionResult u = Intersects u u | Contained | NoIntersect-  deriving (Eq,Show)----- Note the uses a /plane/ so is susceptible to picking the --- wrong quadrant...----findIntersect :: (Floating u, Real u, Ord u)-               => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u)-findIntersect ctr ang0 = step -  where-    theta       = circularModulo ang0-    eqn         = toLineEqn $ pointSlope ctr theta-    step []     = Nothing-    step (x:xs) = case intersection x eqn of -                     Just pt | quadrantCheck theta ctr pt -> Just pt-                     _       -> step xs---quadrantCheck :: (Real u, Floating u) -              => Radian -> Point2 u -> Point2 u -> Bool-quadrantCheck theta ctr pt = theta == langle ctr pt--intersection :: (Fractional u, Ord u) -             => LineSegment u -> LineEqn u -> Maybe (Point2 u)-intersection ls@(LS p q) eqn = case intersect1 ls eqn of-    Intersects fp fq -> let t = fp / (fp-fq) in Just $ affineComb p q t -    Contained        -> Just p-    NoIntersect      -> Nothing----intersect1 :: (Num u, Ord u) -           => LineSegment u -> LineEqn u -> IntersectionResult u-intersect1 (LS p q) eqn = -     if inters fp fq then Intersects fp fq-                     else if contained fp fq then Contained else NoIntersect-  where-    inters a b    = (a < 0 && b >= 0) || (a > 0 && b <= 0)-    contained a b = a == 0 && b == 0-    fp            = lineF p eqn-    fq            = lineF q eqn- -lineF :: Num u => Point2 u -> LineEqn u -> u-lineF (P2 x y) (LineEqn a b c) = a*x + b*y + c--affineComb :: Num u => Point2 u -> Point2 u -> u -> Point2 u-affineComb p q t = p .+^ t *^ (q .-. p)-----rectangleLines :: Num u => Point2 u -> u -> u -> [LineSegment u]-rectangleLines ctr hw hh = [LS br tr, LS tr tl, LS tl bl, LS bl br]-  where-    br = ctr .+^ (vec hw    (-hh))-    tr = ctr .+^ (vec hw    hh)-    tl = ctr .+^ (vec (-hw) hh)-    bl = ctr .+^ (vec (-hw) (-hh))---polygonLines :: [Point2 u] -> [LineSegment u]-polygonLines []     = error "polygonLines - emptyList"-polygonLines (x:xs) = step x xs -  where-    step a []        = [LS a x]-    step a (b:bs)    = LS a b : step b bs------ | Calculate the counter-clockwise angle between two points --- and the x-axis.----langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian-langle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1)-  where-    -- north-east quadrant -    step x y | pve x && pve y = toRadian $ atan (y/x)          -    -    -- north-west quadrant-    step x y | pve y          = pi     - (toRadian $ atan (y / abs x))--    -- south-east quadrant-    step x y | pve x          = (2*pi) - (toRadian $ atan (abs y / x)) --    -- otherwise... south-west quadrant-    step x y                  = pi     + (toRadian $ atan (y/x))--    pve a                     = signum a >= 0
− src/Wumpus/Drawing/Geometry/Paths.hs 
@@ -1,138 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Geometry.Paths--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Paths for /elementary/ shapes - rectangles...--- --- \*\* - WARNING \*\* - half baked. --------------------------------------------------------------------------------------module Wumpus.Drawing.Geometry.Paths-  ( -    LocCoordPath-  , coordinatePrimPath--  , rectangleCoordPath-  , diamondCoordPath-  , polygonCoordPath-  , isoscelesTriangleCoordPath-  , isoscelesTrianglePoints-  , equilateralTriangleCoordPath-  , equilateralTrianglePoints-  ) -  where--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space---import Data.List ( unfoldr )----- | A functional type from /initial point/ to point list.----type LocCoordPath u = Point2 u -> [Point2 u]----- Note - extraction needs a naming scheme - extractFROM or --- extractTO? - in either case this might be queuing up --- name-clash problems.------ The Path data type will also need a similar function...---- -coordinatePrimPath :: Num u => Point2 u -> LocCoordPath u -> PrimPath u-coordinatePrimPath pt fn = go (fn pt)-  where-    go ps@(_:_) = vertexPath ps-    go []       = emptyPath pt        -- fallback----- NOTE - These functions need changing to generate LocCoordPaths...---- | Supplied point is /bottom-left/, subsequenct points are --- counter-clockise so [ bl, br, tr, tl ] .----rectangleCoordPath :: Num u => u -> u -> LocCoordPath u-rectangleCoordPath w h bl = [ bl, br, tr, tl ]-  where-    br = bl .+^ hvec w-    tr = br .+^ vvec h-    tl = bl .+^ vvec h ------ | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @----diamondCoordPath :: Num u => u -> u -> LocCoordPath u-diamondCoordPath hw hh ctr = [ s,e,n,w ]-  where-    s     = ctr .+^ vvec (-hh)-    e     = ctr .+^ hvec hw-    n     = ctr .+^ vvec hh-    w     = ctr .+^ hvec (-hw)-    ---- | 'polygonCoordPath' : @ num_points * radius * center -> [point] @ ----polygonCoordPath :: Floating u => Int -> u -> LocCoordPath u-polygonCoordPath n radius ctr = unfoldr phi (0,(pi*0.5))-  where-    theta = (pi*2) / fromIntegral n-    -    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))-                | otherwise = Nothing------ | @isocelesTriangle bw h pt@------ Supplied point is the centriod of the triangle. This has a --- nicer visual balance than using half-height.----isoscelesTriangleCoordPath :: Floating u => u -> u -> LocCoordPath u-isoscelesTriangleCoordPath bw h ctr = [bl,br,top]-  where-    (bl,br,top) = isoscelesTrianglePoints bw h ctr----- | @isocelesTriangle bw h pt@------ Supplied point is the centriod of the triangle. This has a --- nicer visual balance than using half-height.----isoscelesTrianglePoints :: Floating u -                        => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u)-isoscelesTrianglePoints bw h ctr = (bl, br, top) -  where-    hw         = 0.5*bw -    theta      = atan $ h / hw-    centroid_h = hw * tan (0.5*theta)-    top        = ctr .+^ vvec (h - centroid_h)-    br         = ctr .+^ V2   hw  (-centroid_h)-    bl         = ctr .+^ V2 (-hw) (-centroid_h)----- | @ side_length * ctr -> [Points] @----equilateralTriangleCoordPath :: Floating u => u -> LocCoordPath u-equilateralTriangleCoordPath sl ctr = [bl, br, top] -  where-    (bl,br,top) = equilateralTrianglePoints sl ctr--equilateralTrianglePoints :: Floating u -                          => u -> Point2 u -> (Point2 u, Point2 u, Point2 u)-equilateralTrianglePoints sl = isoscelesTrianglePoints sl h-  where-    h = sl * sin (pi/3)-
src/Wumpus/Drawing/Paths.hs view
@@ -3,29 +3,28 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Paths--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable -- Portability :  GHC ----- Shim import module for Paths.+-- Shim import module for the Absolute Path modules.+-- --  -------------------------------------------------------------------------------- -module Wumpus.Drawing.Paths +module Wumpus.Drawing.Paths   (       module Wumpus.Drawing.Paths.Base-  , module Wumpus.Drawing.Paths.Connectors-  , module Wumpus.Drawing.Paths.ControlPoints-  , module Wumpus.Drawing.Paths.MonadicConstruction+  , module Wumpus.Drawing.Paths.PathBuilder+  , module Wumpus.Drawing.Paths.Vamps    ) where  import Wumpus.Drawing.Paths.Base-import Wumpus.Drawing.Paths.Connectors-import Wumpus.Drawing.Paths.ControlPoints-import Wumpus.Drawing.Paths.MonadicConstruction+import Wumpus.Drawing.Paths.PathBuilder+import Wumpus.Drawing.Paths.Vamps
src/Wumpus/Drawing/Paths/Base.hs view
@@ -5,646 +5,1099 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Paths.Base--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Extended path type - more amenable for complex drawings than--- the type in Wumpus-Core.------ \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths.Base-  ( --    Path-  , DPath-  , length-  , append-  , pconcat-  , line-  , curve-  , pivot-  , traceLinePoints-  , traceCurvePoints-  , curveByAngles--  , toPrimPath --  , tipL-  , tipR--  , shortenPath-  , shortenL-  , shortenR-  , directionL-  , directionR--  , midway-  , midway_-  , atstart-  , atstart_-  , atend-  , atend_--  , PathViewL(..)-  , DPathViewL-  , PathViewR(..)-  , DPathViewR-  , PathSegment(..)-  , DPathSegment-  , pathViewL-  , pathViewR---  , roundTrail-  , roundInterior--  ) where---import Wumpus.Drawing.Geometry.Intersection ( langle )---- package: wumpus-basic-import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl-                                   , ViewR(..), viewr, cons, snoc, join )-import qualified Wumpus.Basic.Utils.JoinList as JL--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace-import Data.VectorSpace--import Data.List ( foldl' ) --import Prelude hiding ( length )--data Path u = Path { _path_length   :: u -                   , _path_start    :: Point2 u-                   , _path_elements :: JoinList (PathSeg u)-                   , _path_end      :: Point2 u-                   }-  deriving (Eq,Show)--type DPath = Path Double---- Annotating each segment with length is \*\* good \*\*.--- Makes it much more efficient to find the midway point.------ But what do we do about the start point:------ a) put it in the segment - too much info in the type, allows --- consistency problems vis-a-vis gaps in the path.------ b) leave it out - too little info in the type, allows --- consistency problems with length.------ Option (a) is probably most convenient espcially as the --- constructors won\'t be exported.---- Annotation is length...--- -data PathSeg u = LineSeg  { _line_length  :: u -                          , _line_start   :: Point2 u-                          , _line_end     :: Point2 u-                          }-               | CurveSeg { _curve_length :: u -                          , _curve_start  :: Point2 u-                          , _ctrl_pt_one  :: Point2 u-                          , _ctrl_pt_two  :: Point2 u-                          , _curve_end    :: Point2 u-                          }-  deriving (Eq,Show)---type instance DUnit (Path u)    = u-type instance DUnit (PathSeg u) = u---infixr 1 `append`--length :: Num u => Path u -> u-length (Path u _ _ _) = u--append :: Floating u => Path u -> Path u -> Path u-append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2) -    | end1 == start2 = Path (len1+len2) start1 (se1 `join` se2) end2 -    | otherwise      = let joint     = lineSegment end1 start2-                           total_len = len1 + len2 + segmentLength joint-                       in Path total_len start1 (se1 `join` (cons joint se2)) end2 ---- CAUTION - @append@ is using Floating Point equality to see if--- points are equal...---pconcat :: Floating u => Path u -> [Path u] -> Path u-pconcat p0 ps = foldl' append p0 ps--segmentLength :: PathSeg u -> u-segmentLength (LineSeg u _ _)       = u-segmentLength (CurveSeg u _ _ _ _)  = u---segmentStart :: PathSeg u -> Point2 u-segmentStart (LineSeg  _ p0 _)      = p0-segmentStart (CurveSeg _ p0 _ _ _)  = p0--segmentEnd :: PathSeg u -> Point2 u-segmentEnd (LineSeg  _ _ p1)        = p1-segmentEnd (CurveSeg _ _ _ _ p3)    = p3-----lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u -lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1---pathZero :: Floating u => Point2 u -> Path u -pathZero p0 = Path 0 p0 JL.empty p0-   --line :: Floating u => Point2 u -> Point2 u -> Path u -line p0 p1 = let v = vlength $ pvec p0 p1 -             in Path v p0 (JL.one $ LineSeg v p0 p1) p1-   --curve :: (Floating u, Ord u)-      => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u -curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3-                    in Path v p0 (JL.one $ CurveSeg v p0 p1 p2 p3) p3---- | A draw a /straight line/ of length 0 at the supplied point. ------ This is /might/ be useful in concatenating curved paths--- as it introduces and extra control point.--- -pivot :: Floating u => Point2 u -> Path u -pivot p0 = Path 0 p0 (JL.one $ LineSeg 0 p0 p0) p0----- | 'traceLinePoints' throws a runtime error if the supplied list--- is empty. ----traceLinePoints :: Floating u => [Point2 u] -> Path u-traceLinePoints []       = error "traceLinePoints - empty point list."-traceLinePoints [a]      = line a a-traceLinePoints (a:b:xs) = step (line a b) b xs-  where-    step acc _ []     = acc-    step acc e (y:ys) = step (acc `append` line e y) y ys----- | 'traceCurvePoints' consumes 4 points from the list on the --- intial step (start, control1, control2, end) then steps --- through the list taking 3 points at a time thereafter--- (control1,control2, end). Leftover points are discarded.    --- --- 'traceCurvePoints' throws a runtime error if the supplied list--- is has less than 4 elements (start, control1, control2, end). ----traceCurvePoints :: (Floating u, Ord u) => [Point2 u] -> Path u-traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs-  where-    step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs-    step acc _  _          = acc--traceCurvePoints _            = error "tracePointsCurve - less than 4 elems."---curveByAngles :: (Floating u, Ord u) -              => Point2 u -> Radian -> Radian -> Point2 u -> Path u-curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end-  where-    sz     = 0.375 * (vlength $ pvec start end)-    v1     = avec cin  sz-    v2     = avec cout sz------ | Turn a Path into an ordinary PrimPath.------ Assumes path is properly formed - i.e. end point of one --- segment is the same point as the start point of the next--- segment.----toPrimPath :: Num u => Path u -> PrimPath u-toPrimPath (Path _ start segs _) = step1 $ viewl segs-  where-    step1 EmptyL                  = emptyPath start-    step1 (e :< se)               = let (p0,a) = seg1 e in -                                    primPath p0 $ a : step2 (viewl se)--    step2 EmptyL                  = []-    step2 (e :< se)               = seg2 e : step2 (viewl se)-    -    seg1 (LineSeg  _ p0 p1)       = (p0, lineTo p1)-    seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3)- -    seg2 (LineSeg  _ _  p1)       = lineTo p1-    seg2 (CurveSeg _ _  p1 p2 p3) = curveTo p1 p2 p3--------------------------------------------------------------------------------------- Curve length--data StrictCurve u = Curve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)--curveLength :: (Floating u, Ord u)      -            => Point2 u -> Point2 u -> Point2 u -> Point2 u -> u-curveLength p0 p1 p2 p3 = gravesenLength 0.1 $ Curve p0 p1 p2 p3----- | Jens Gravesen\'s bezier arc-length approximation. ------ Note this implementation is parametrized on error tolerance.----gravesenLength :: (Floating u, Ord u) => u -> StrictCurve 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---ctrlPolyLength :: Floating u => StrictCurve u -> u-ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3-  where-    len pa pb = vlength $ pvec pa pb--cordLength :: Floating u => StrictCurve u -> u-cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3----- | mid-point between two points----pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u-pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0----- | Curve subdivision via de Casteljau\'s algorithm.----subdivide :: Fractional u -          => StrictCurve u -> (StrictCurve u, StrictCurve u)-subdivide (Curve p0 p1 p2 p3) =-    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)-  where-    p01   = pointMidpoint p0    p1-    p12   = pointMidpoint p1    p2-    p23   = pointMidpoint p2    p3-    p012  = pointMidpoint p01   p12-    p123  = pointMidpoint p12   p23-    p0123 = pointMidpoint p012  p123---- | subdivide with an affine weight along the line...----subdividet :: Real u-           => u -> StrictCurve u -> (StrictCurve u, StrictCurve u)-subdividet t (Curve p0 p1 p2 p3) = -    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)-  where-    p01   = affineCombination t p0    p1-    p12   = affineCombination t p1    p2-    p23   = affineCombination t p2    p3-    p012  = affineCombination t p01   p12-    p123  = affineCombination t p12   p23-    p0123 = affineCombination t p012  p123--affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u-affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1)------------------------------------------------------------------------------------- tips --tipL :: Path u -> Point2 u-tipL (Path _ sp _ _) = sp---tipR :: Path u -> Point2 u-tipR (Path _ _ _ ep) = ep------- | 'sortenPath' : @ left_dist * right_dist * path -> Path @----shortenPath :: (Real u , Floating u) => u  -> u -> Path u -> Path u-shortenPath l r = shortenL l .  shortenR r -------------------------------------------------------------------------------------- shorten from the left...---- | Note - shortening a line from the left by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the end point.----shortenL :: (Real u, Floating u) => u -> Path u -> Path u-shortenL n (Path u _ segs ep) -    | n >= u                  = line ep ep-    | otherwise               = step n (viewl segs)-  where-    step _ EmptyL     = line ep ep      -- should be unreachable-    step d (e :< se)  = let z  = segmentLength e in-                        case compare d z of-                          GT -> step (d-z) (viewl se)-                          EQ -> makeLeftPath (u-n) se ep-                          LT -> let e1 = shortenSegL d e-                                in Path (u-n) (segmentStart e1) (e1 `cons` se) ep---makeLeftPath :: Floating u => u -> JoinList (PathSeg u) -> Point2 u -> Path u-makeLeftPath u se ep = -    case viewl se of-      EmptyL   -> line ep ep-      (e :< _) -> Path u (segmentStart e) se ep---shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u-shortenSegL n (LineSeg  u p0 p1)        = -    LineSeg  (u-n) (shortenLineL n p0 p1) p1--shortenSegL n (CurveSeg u p0 p1 p2 p3)  = -    let (Curve p0' p1' p2' p3') = snd $ subdividet (n/u) (Curve p0 p1 p2 p3)-    in CurveSeg (u-n) p0' p1' p2' p3'---shortenLineL :: (Real u, Floating u) -             => u -> Point2 u -> Point2 u -> Point2 u-shortenLineL n p0 p1 = p0 .+^ v-  where-    v0 = p1 .-. p0-    v  = avec (vdirection v0) n--------------------------------------------------------------------------------------- shorten from the right ...- --- | Note - shortening a line from the right by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the start point.----shortenR :: (Real u, Floating u) => u -> Path u -> Path u-shortenR n (Path u sp segs _) -    | n >= u                  = line sp sp-    | otherwise               = step n (viewr segs)-  where-    step _ EmptyR     = line sp sp      -- should be unreachable-    step d (se :> e)  = let z = segmentLength e in-                        case compare d z of-                          GT -> step (d-z) (viewr se)-                          EQ -> makeRightPath n sp se-                          LT -> let e1 = shortenSegR d e-                                in Path (u-n) sp (se `snoc` e1) (segmentEnd e1)-                         --makeRightPath :: Floating u => u -> Point2 u -> JoinList (PathSeg u) -> Path u-makeRightPath u sp se = -    case viewr se of-      EmptyR   -> line sp sp-      (_ :> e) -> Path u sp se (segmentEnd e)----shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u-shortenSegR n (LineSeg  u p0 p1)        = -    LineSeg  (u-n) p0 (shortenLineR n p0 p1) --shortenSegR n (CurveSeg u p0 p1 p2 p3)  = -    let (Curve p0' p1' p2' p3') = fst $ subdividet ((u-n)/u) (Curve p0 p1 p2 p3)-    in CurveSeg (u-n) p0' p1' p2' p3'---shortenLineR :: (Real u, Floating u) -             => u -> Point2 u -> Point2 u -> Point2 u-shortenLineR n p0 p1 = p1 .+^ v-  where-    v0 = p0 .-. p1-    v  = avec (vdirection v0) n---------------------------------------------------------------------------------------- line direction---- | Direction of empty path is considered to be 0.----directionL :: (Real u, Floating u) => Path u -> Radian-directionL (Path _ _ se _)  = step $ viewl se-  where-    step (LineSeg  _ p0 p1 :< _)      = lineDirection p1 p0  -- 1-to-0-    step (CurveSeg _ p0 p1 _ _ :< _)  = lineDirection p1 p0-    step _                            = 0       -- should be unreachable----- | Direction of empty path is considered to be 0.----directionR :: (Real u, Floating u) => Path u -> Radian-directionR (Path _ _ se _) = step $ viewr se-  where-    step (_ :> LineSeg  _ p0 p1)      = lineDirection p0 p1-    step (_ :> CurveSeg _ _  _ p2 p3) = lineDirection p2 p3-    step _                            = 0       -- should be unreachable             ------------------------------------------------------------------------------------------ Return direction as well because the calculation is expensive...----midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian)-midway pa@(Path u sp _ _) -    | u == 0    = (sp,0)-    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1)---- Just the midway point.----midway_ :: (Real u, Floating u) => Path u -> Point2 u-midway_ = fst . midway---atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian)-atstart pa@(Path _ sp _ _) = (sp, directionL pa)--atstart_ :: Path u -> Point2 u-atstart_ (Path _ sp _ _) = sp---atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian)-atend pa@(Path _ _ _ ep) = (ep, directionR pa)- --atend_ :: Path u -> Point2 u-atend_ (Path _ _ _ ep) = ep----- nearstart, nearend, verynear ...-------------------------------------------------------------------------------------data PathViewL u = PathOneL (PathSegment u)-                 | PathSegment u :<< Path u-  deriving (Eq,Show) --type DPathViewL = PathViewL Double--data PathViewR u = PathOneR (PathSegment u)-                 | Path u :>> PathSegment u-  deriving (Eq,Show) --type DPathViewR = PathViewR Double---data PathSegment u = Line1  (Point2 u) (Point2 u)-                   | Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u)-  deriving (Eq,Show) --type DPathSegment = PathSegment Double--type instance DUnit (PathViewL u)   = u-type instance DUnit (PathViewR u)   = u-type instance DUnit (PathSegment u) = u--pathViewL :: Num u => Path u -> PathViewL u-pathViewL (Path u _ segs ep) = go (viewl segs)-  where-    go EmptyL                   = error "pathViewL - (not) unreachable."-     -    go (LineSeg v p0 p1 :< se)-        | JL.null se            = PathOneL (Line1 p0 p1)-        | otherwise             = Line1 p0 p1 :<< Path (u-v) p1 se ep--    go (CurveSeg v p0 p1 p2 p3 :< se) -        | JL.null se            = PathOneL (Curve1 p0 p1 p2 p3)-        | otherwise             = Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep---pathViewR :: Num u => Path u -> PathViewR u-pathViewR (Path u _ segs ep) = go (viewr segs)-  where-    go EmptyR                   = error "pathViewR - (not) unreachable."--    go (se :> LineSeg v p0 p1) -        | JL.null se            = PathOneR (Line1 p0 p1)-        | otherwise             = Path (u-v) p1 se ep :>> Line1 p0 p1--    go (se :> CurveSeg v p0 p1 p2 p3) -        | JL.null se            = PathOneR (Curve1 p0 p1 p2 p3)-        | otherwise             = Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3---------------------------------------------------------------------------------------- Round corners---- | The length of the control-point vector wants to be slighly --- longer than half of /d/ (d - being the distance between the --- /truncated/ points and the corner).----cornerCurve :: (Real u, Floating u) -            => Point2 u -> Point2 u -> Point2 u -> Path u-cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3-  where-    len1 = 0.6 *  (vlength $ pvec p1 p2)-    len2 = 0.6 *  (vlength $ pvec p3 p2)-    cp1  = p1 .+^ (avec (langle p1 p2) len1)-    cp2  = p3 .+^ (avec (langle p3 p2) len2)----- | 'roundTrail' : @ rounding_distance * [point] -> Path @------ Build a path from the list of vertices, all the interior --- corners are rounded by the rounding distance \*and\* final --- round corner is created \"incorporating\" the start point (as --- the start point becomes a rounded corner the actual path will --- not intersect it). --- --- It is expected that this function will be used to create round --- cornered shapes.--- --- 'roundTrail' throws a runtime error if the input list is empty. --- If the list has one element /the null path/ is built, if the --- list has two elements a straight line is built.----roundTrail :: (Real u, Floating u) -           => u -> [Point2 u] -> Path u -roundTrail _ []             = error "roundTrail - empty list."-roundTrail _ [a]            = pathZero a-roundTrail _ [a,b]          = line a b-roundTrail u (start:b:c:xs) = step (lineCurveTrail u start b c) (b:c:xs)-  where-    step acc (m:n:o:ps)     = step (acc `append` lineCurveTrail u m n o) (n:o:ps)-    step acc [n,o]          = acc `append` lineCurveTrail u n o start-                                  `append` lineCurveTrail u o start b -    step acc _              = acc------ | Two parts - line and corner curve...------ Note - the starting point is moved, this function is for --- closed, rounded paths.----lineCurveTrail :: (Real u, Floating u) -               => u -> Point2 u -> Point2 u -> Point2 u -> Path u-lineCurveTrail u a b c = line p1 p2 `append` cornerCurve p2 b p3-  where-    p1 = a .+^ (avec (vdirection $ pvec a b) u)-    p2 = b .+^ (avec (vdirection $ pvec b a) u)-    p3 = b .+^ (avec (vdirection $ pvec b c) u)----- | 'roundInterior' : @ rounding_distance * [point] -> Path @------ Build a path from the list of vertices, all the interior --- corners are rounded by the rounding distance. Unlike --- 'roundTrail' there is no /loop around/ to the start point,--- and start path will begin exactly on the start point and end --- exactly on the end point. --- --- 'roundInterior' throws a runtime error if the input list is --- empty. If the list has one element /the null path/ is built, --- if the list has two elements a straight line is built.----roundInterior :: (Real u, Floating u) -           => u -> [Point2 u] -> Path u -roundInterior _ []             = error "roundEveryInterior - empty list."-roundInterior _ [a]            = pathZero a-roundInterior _ [a,b]          = line a b-roundInterior u (start:b:c:xs) = let (path1,p1) = lineCurveInter1 u start b c-                                 in step path1 (p1:c:xs)-  where-    step acc (m:n:o:ps)     = let (seg2,p1) = lineCurveInter1 u m n o-                              in step (acc `append` seg2) (p1:o:ps)-    step acc [n,o]          = acc `append` line n o-    step acc _              = acc------ | Two parts - line and corner curve...------ Note - draws a straight line from the starting point - this is --- the first step of an interior (non-closed) rounded path----lineCurveInter1 :: (Real u, Floating u) -                => u -> Point2 u -> Point2 u -> Point2 u -> (Path u, Point2 u)-lineCurveInter1 u a b c = -    (line a p2 `append` cornerCurve p2 b p3, p3)-  where-    p2 = b .+^ (avec (vdirection $ pvec b a) u)-    p3 = b .+^ (avec (vdirection $ pvec b c) u)- +-- Copyright   :  (c) Stephen Tetley 2010-2012+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Absolute path type - this should be more amenable for building +-- complex drawings than the PrimPath type in Wumpus-Core.+--+-- 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@.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.Base+  ( ++  -- * Absolute path type+    AbsPath+  , DAbsPath+++  -- * Construction+  , emptyPath+  , line1+  , curve1+  , vertexPath+  , curvePath+  , controlCurve++  , vectorPath+  , vectorPathTheta++  , anaTrailPath+  , catTrailPath++  -- * Queries+  , null+  , length++  -- * Concat and extension+  , snocLine+  , snocLineTo+  , snocCurve+  , snocCurveTo+++  -- * Conversion+  , toPrimPath++  , renderPath+  , renderPath_++  -- * Shortening+  , shortenPath+  , shortenL+  , shortenR++  -- * Tips and inclination+  , tipL+  , tipR+  , inclinationL+  , inclinationR++  , isBezierL+  , isBezierR+++  -- * Path anchors+  , midway+  , midway_+  , atstart+  , atstart_+  , atend+  , atend_+++  -- * Views+  , PathViewL(..)+  , DPathViewL+  , PathViewR(..)+  , DPathViewR+  , PathSegment(..)+  , DPathSegment+  , pathViewL+  , pathViewR++  , optimizeLines++  , roundExterior+  , roundInterior++  , deBezier+  , pathMajorPoints+  , pathAllPoints++  -- * Path division+  , pathdiv+++  ) where++import Wumpus.Drawing.Basis.BezierCurve++import Wumpus.Basic.Kernel+import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl+                                   , ViewR(..), viewr, cons, snoc )+import qualified Wumpus.Basic.Utils.JoinList as JL++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Data.Monoid+import qualified Data.Traversable as T++import Prelude hiding ( null, length )++--+-- Design Note+-- +-- Wumpus has no relative path type. An AbsPath is expected to be +-- an /answer/ from some function like an anchor point or a +-- bounding box.+--+-- Wumpus didn\'t always work on this premise, some of the code +-- below may contradict this...+--++++++-- | Absolute path data type.+--+data AbsPath u = AbsPath +      { _abs_path_length   :: u +      , _abs_path_start    :: Point2 u+      , _abs_path_elements :: JoinList (AbsPathSeg u)+      , _abs_path_end      :: Point2 u+      }+  deriving (Eq,Show)++type instance DUnit (AbsPath u) = u+++type DAbsPath = AbsPath Double++-- Annotating each segment with length is \*\* good \*\*.+-- Makes it much more efficient to find the midway point.+--+-- But what do we do about the start point:+--+-- a) put it in the segment - too much info in the type, allows +-- consistency problems vis-a-vis gaps in the path.+--+-- b) leave it out - too little info in the type, allows +-- consistency problems with length.+--+-- Option (a) is probably most convenient espcially as the +-- constructors won\'t be exported.++-- Annotation is length...+-- +data AbsPathSeg u = AbsLineSeg  u (Vec2 u)+                  | AbsCurveSeg u (Vec2 u) (Vec2 u) (Vec2 u)+  deriving (Eq,Show)+++type instance DUnit (AbsPathSeg u) = u++-- +-- DESIGN NOTE+--+-- No monoid instance. AbsPaths dont support empty or even concat +-- naturally.+--+-- Concat is troublesome because AbsPaths are always located +-- within a frame.+--+-- They can support:+--+-- a. Concat with a join between the end of the first path and the+-- start of the second.+-- +-- b. Shape preserving concat - the second path is moved so it +-- continues from the end point of the first path.+--+-- It is conceptually simpler to think about extension (adding to +-- the path tip) rather than concatenation. +--++--------------------------------------------------------------------------------++instance Functor AbsPath where+  fmap f (AbsPath u sp ls ep) = +      AbsPath (f u) (fmap f sp) (fmap (fmap f) ls) (fmap f ep)++instance Functor AbsPathSeg where+  fmap f (AbsLineSeg u v1)        = +      AbsLineSeg (f u) (fmap f v1)++  fmap f (AbsCurveSeg u v1 v2 v3) = +      AbsCurveSeg (f u) (fmap f v1) (fmap f v2) (fmap f v3)++++--------------------------------------------------------------------------------+-- Translate+++-- | 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 +-- without a start point. Figuratively, the empty path is a path+-- from the start point to the end point.+--+-- Thus AbsPath operates as a semigroup but not a monoid.+--+emptyPath :: Floating u => Point2 u -> AbsPath u+emptyPath = zeroPath+++-- | Create an absolute path as a straight line between the +-- supplied points.+--+line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u +line1 p0 p1 = AbsPath len p0 (JL.one s1) p1+  where+    s1@(AbsLineSeg len _) = absLineSeg $ pvec p0 p1++-- | Create an absolute path from a single cubic Bezier curve.+--+curve1 :: (Floating u, Ord u, Tolerance u)+      => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u +curve1 p0 p1 p2 p3 = +    AbsPath len p0 (JL.one $ AbsCurveSeg len v1 v2 v3) p3+  where+    v1  = pvec p0 p1+    v2  = pvec p1 p2+    v3  = pvec p2 p3+    len = bezierLength (BezierCurve p0 p1 p2 p3)+++-- | 'vertexPath' throws a runtime error if the supplied list+-- is empty. +--+vertexPath :: (Floating u, Ord u, Tolerance u) +           => [Point2 u] -> AbsPath u+vertexPath []       = error "traceLinePoints - empty point list."+vertexPath [a]      = line1 a a+vertexPath (a:b:xs) = step (line1 a b) xs+  where+    step acc []     = acc+    step acc (y:ys) = step (snocLineTo acc y) ys++++-- | 'curvePath' consumes 4 points from the list on the +-- intial step (start, control1, control2, end) then steps +-- through the list taking 3 points at a time thereafter+-- (control1,control2, end). Leftover points are discarded.    +-- +-- 'curvePath' throws a runtime error if the supplied list+-- is has less than 4 elements (start, control1, control2, end). +--+curvePath :: (Floating u, Ord u, Tolerance u) +          => [Point2 u] -> AbsPath u+curvePath (a:b:c:d:xs) = step (curve1 a b c d) xs+  where+    step acc (x:y:z:zs) = step (snocCurveTo acc (x,y,z)) zs+    step acc _          = acc++curvePath _            = error "curvePath - less than 4 elems."++++-- NOTE - need a proper arc path builder.++++-- | This is not an arc...+-- +controlCurve :: (Floating u, Ord u, Tolerance u) +         => Point2 u -> Radian -> Radian -> Point2 u -> AbsPath u+controlCurve start cin cout end = +    curve1 start (start .+^ v1) (end .+^ v2) end+  where+    sz     = 0.375 * (vlength $ pvec start end)+    v1     = avec cin  sz+    v2     = avec cout sz++++++vectorPath :: (Floating u, Ord u, Tolerance u) +           => [Vec2 u] -> Point2 u -> AbsPath u+vectorPath vecs p0 = vertexPath $ p0 : step p0 vecs+  where+    step _ []       = []+    step pt (v1:vs) = let p1 = pt .+^ v1 in p1 : step p1 vs +++vectorPathTheta :: (Real u, Floating u, Tolerance u) +                => [Vec2 u] -> Radian -> Point2 u -> AbsPath u +vectorPathTheta vs ang = vectorPath $ map (rotate ang) vs+++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+    step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs+  +catTrailPath :: (Floating u, Ord u, Tolerance u) +             => Point2 u -> CatTrail u -> AbsPath u+catTrailPath pt trl = step (emptyPath pt) $ destrCatTrail trl+  where+    step ac []                   = ac+    step ac (TLine v1:xs)        = step (ac `snocLine` v1) xs+    step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs+  ++--------------------------------------------------------------------------------+-- Queries++-- | Is the path empty?+--+null :: AbsPath u -> Bool+null = JL.null . _abs_path_elements++-- | Length of the Path.+--+-- Length is the length of the path as it is drawn, it is not a +-- count of the number or path segments.+--+-- Length is cached so this operation is cheap - though this puts+-- a tax on the build operations. +-- +length :: Num u => AbsPath u -> u+length (AbsPath u _ _ _) = u+++--------------------------------------------------------------------------------+-- Extension++infixl 5 `snocLine`+++-- | Extend the path with a straight line segment from the +-- end-point defined by the supplied vector.+--+-- > infixl 5 `snocLine`+--+snocLine :: Floating u => AbsPath u -> Vec2 u -> AbsPath u+snocLine (AbsPath u sp se ep) v1 = +  let u1        = vlength v1 +      tail_line = AbsLineSeg u1 v1+  in AbsPath (u + u1) sp (JL.snoc se tail_line) (ep .+^ v1)++++infixl 5 `snocLineTo`+++-- | Extend the path with a straight line segment from the +-- end-point to the supplied point.+--+-- > infixl 5 `snocLineTo`+--+snocLineTo :: Floating u => AbsPath u -> Point2 u -> AbsPath u+snocLineTo (AbsPath u sp se1 ep) p1 = AbsPath (u + len) sp (snoc se1 s1) p1+  where+    s1@(AbsLineSeg len _) = lineSegment ep p1+++infixl 5 `snocCurve`++-- | Extend the path from the end-point with a Bezier curve +-- segment formed by the supplied points.+--+-- > infixl 5 `snocCurve`+-- +snocCurve :: (Floating u, Ord u, Tolerance u)+          => AbsPath u -> (Vec2 u, Vec2 u, Vec2 u) -> AbsPath u+snocCurve absp@(AbsPath _ _ _ ep) (v1,v2,v3) = snocCurveTo absp (p1,p2,p3)+  where+    p1 = ep .+^ v1+    p2 = p1 .+^ v2+    p3 = p2 .+^ v3+ ++infixl 5 `snocCurveTo`+++-- | Extend the path from the end-point with a Bezier curve +-- segment formed by the supplied points.+--+-- > infixl 5 `snocCurveTo`+-- +snocCurveTo :: (Floating u, Ord u, Tolerance u)+            => AbsPath u -> (Point2 u, Point2 u, Point2 u) -> AbsPath u+snocCurveTo (AbsPath u sp se1 ep) (p1,p2,p3) = +    AbsPath (u + len) sp (snoc se1 s1) p3+  where+    s1@(AbsCurveSeg len _ _ _) = curveSegment ep p1 p2 p3+ ++-------------------------------------------------------------------------------- ++++segmentLength :: AbsPathSeg u -> u+segmentLength (AbsLineSeg u _)       = u+segmentLength (AbsCurveSeg u _ _ _)  = u+++segmentVector :: Num u => AbsPathSeg u -> Vec2 u+segmentVector (AbsLineSeg  _ v1)       = v1+segmentVector (AbsCurveSeg _ v1 v2 v3) = v1 ^+^ v2 ^+^ v3++++-- | Helper - construct a line segment.+-- +lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u +lineSegment p0 p1 = lineSegmentV $ pvec p0 p1++-- | Helper - construct a line segment.+-- +lineSegmentV :: Floating u => Vec2 u -> AbsPathSeg u +lineSegmentV v1 = AbsLineSeg (vlength v1) v1+++-- | Helper - construct a curve segment.+-- +curveSegment :: (Floating u, Ord u, Tolerance u) +             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPathSeg u +curveSegment p0 p1 p2 p3 = AbsCurveSeg len v1 v2 v3+  where+    len = bezierLength (BezierCurve p0 p1 p2 p3)+    v1  = pvec p0 p1+    v2  = pvec p1 p2+    v3  = pvec p2 p3+++-- | Helper - construct the /empty/ but located path.+-- +zeroPath :: Floating u => Point2 u -> AbsPath u +zeroPath p0 = AbsPath 0 p0 JL.empty p0+   +++renderPath :: InterpretUnit u +         => PathMode -> AbsPath u -> Image u (AbsPath u)+renderPath mode rp = replaceAns rp $ +    liftQuery (toPrimPath rp) >>= dcPath mode+++renderPath_ :: InterpretUnit u +          => PathMode -> AbsPath u -> Graphic u+renderPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode+++-- | Turn a Path into an ordinary PrimPath.+--+-- Assumes path is properly formed - i.e. end point of one +-- segment is the same point as the start point of the next+-- segment.+--+toPrimPath :: InterpretUnit u => AbsPath u -> Query u PrimPath+toPrimPath (AbsPath _ start segs _) = +    uconvertCtxF start       >>= \dstart -> +    T.mapM uconvertCtxF segs >>= \dsegs  ->+    return $ step1 dstart dsegs+  where+    step1 p0 se | JL.null se          = emptyPrimPath p0+                | otherwise           = absPrimPath p0 $ step2 p0 (viewl se)++    step2 _  EmptyL                   = []+    step2 pt (e :< se)                = let (p1,s) = mkSeg pt e+                                        in s : step2 p1 (viewl se)+    +    mkSeg p0 (AbsLineSeg  _ v1)       = let p1 = p0 .+^ v1+                                        in (p1, absLineTo p1)+    mkSeg p0 (AbsCurveSeg _ v1 v2 v3) = let p1 = p0 .+^ v1+                                            p2 = p1 .+^ v2+                                            p3 = p2 .+^ v3+                                        in (p3, absCurveTo p1 p2 p3)+++++++-- | 'sortenPath' : @ left_dist * right_dist * path -> Path @+--+shortenPath :: (Real u , Floating u) +            => u  -> u -> AbsPath u -> AbsPath u+shortenPath l r = shortenL l .  shortenR r +++--------------------------------------------------------------------------------+-- shorten from the left...++-- | Note - shortening a line from the left by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the end point.+--+shortenL :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u+shortenL n path1@(AbsPath u startp segs ep) +    | n <  0                  = path1+    | n >= u                  = AbsPath 0 ep mempty ep +    | otherwise               = step n startp (viewl segs)+  where+    step _ _  EmptyL    = AbsPath 0 ep mempty ep +    step d sp (e :< se) = let z     = segmentLength e+                              snext = sp .+^ segmentVector e+                          in case compare d z of+                             GT -> step (d-z) snext (viewl se)+                             EQ -> makeLeftPath (u-n) snext se ep+                             LT -> let (spart,e1) = shortenSegL d sp e+                                   in AbsPath (u-n) spart (e1 `cons` se) ep+++makeLeftPath :: Floating u +             => u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u +             -> AbsPath u+makeLeftPath u sp se ep | JL.null se = line1 sp ep+                        | otherwise  = AbsPath u sp se ep++++shortenSegL :: (Real u, Floating u) +            => u -> Point2 u -> AbsPathSeg u -> (Point2 u, AbsPathSeg u)+shortenSegL n sp (AbsLineSeg  u v1)        = +    let v2  = shortenVec n v1 +        sp' = sp .+^ avec (vdirection v1) n+    in (sp', AbsLineSeg  (u-n) v2)++shortenSegL n sp (AbsCurveSeg u v1 v2 v3)  = +    (q0, AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3))+  where+    (BezierCurve q0 q1 q2 q3) = let p1 = sp .+^ v1+                                    p2 = p1 .+^ v2+                                    p3 = p2 .+^ v3+                                in snd $ subdividet (n/u) +                                                    (BezierCurve sp p1 p2 p3)+     +++shortenVec :: (Real u, Floating u) => u -> Vec2 u -> Vec2 u+shortenVec n v0 = v0 ^-^ v+  where+    v  = avec (vdirection v0) n+++--------------------------------------------------------------------------------+-- shorten from the right ...+ +-- | Note - shortening a line from the right by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the start point.+--+shortenR :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u+shortenR n path1@(AbsPath u sp segs endpt) +    | n < 0                   = path1+    | n >= u                  = AbsPath 0 sp mempty sp +    | otherwise               = step n (viewr segs) endpt+  where+    step _ EmptyR    _  = AbsPath 0 sp mempty sp +    step d (se :> e) ep = let z     = segmentLength e +                              enext = ep .-^ segmentVector e+                          in case compare d z of+                              GT -> step (d-z) (viewr se) enext+                              EQ -> makeRightPath n sp se enext+                              LT -> let (e1,epart) = shortenSegR d e ep+                                    in AbsPath (u-n) sp (se `snoc` e1) epart+                         ++makeRightPath :: Floating u +              => u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u +              -> AbsPath u+makeRightPath u sp se ep | JL.null se = line1 sp ep+                         | otherwise  = AbsPath u sp se ep+++shortenSegR :: (Real u, Floating u) +            => u -> AbsPathSeg u -> Point2 u -> (AbsPathSeg u, Point2 u)+shortenSegR n (AbsLineSeg u v1)        ep = +    let v2  = shortenVec n v1 +        ep' = ep .-^ avec (vdirection v1) n+    in (AbsLineSeg (u-n) v2, ep')++shortenSegR n (AbsCurveSeg u v1 v2 v3) ep = +    (AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3), q3)+  where+    (BezierCurve q0 q1 q2 q3) = let p2 = ep .-^ v3+                                    p1 = p2 .-^ v2+                                    p0 = p1 .-^ v1+                                in fst $ subdividet ((u-n)/u) +                                                    (BezierCurve p0 p1 p2 ep)+     +++++--------------------------------------------------------------------------------+-- tips ++tipL :: AbsPath u -> Point2 u+tipL (AbsPath _ sp _ _) = sp+++tipR :: AbsPath u -> Point2 u+tipR (AbsPath _ _ _ ep) = ep+++--------------------------------------------------------------------------------+-- line direction++++-- | Direction of empty path is considered to be 0.+--+inclinationL :: (Real u, Floating u) => AbsPath u -> Radian+inclinationL (AbsPath _ _ se _)  = step $ viewl se+  where+    step (AbsLineSeg  _ v1 :< _)       = vdirection v1+    step (AbsCurveSeg _ v1 _  _  :< _) = vdirection v1+    step _                             = 0+++-- | Direction of empty path is considered to be 0.+--+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?+--+isBezierL :: AbsPath u -> Bool+isBezierL (AbsPath _ _ se _) = step $ viewl se+  where+    step (AbsCurveSeg _ _ _ _ :< _) = True +    step _                          = False+++ +-- | Is the right tip a Bezier curve?+-- +isBezierR :: AbsPath u -> Bool+isBezierR (AbsPath _ _ se _) = step $ viewr se+  where+    step (_ :> AbsCurveSeg _ _ _ _) = True +    step _                          = False+++--------------------------------------------------------------------------------+++-- Return direction as well because the calculation is expensive...+--+midway :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)+midway pa@(AbsPath u sp _ _) +    | u == 0    = (sp,0)+    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, inclinationR pa1)++-- Just the midway point.+--+midway_ :: (Real u, Floating u) => AbsPath u -> Point2 u+midway_ = fst . midway+++atstart :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)+atstart pa@(AbsPath _ sp _ _) = (sp, 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, inclinationR pa)+ ++atend_ :: AbsPath u -> Point2 u+atend_ (AbsPath _ _ _ ep) = ep+++-- nearstart, nearend, verynear ...+++++--------------------------------------------------------------------------------+-- Path Views cf. Data.Sequence+++infixr 5 :<<+infixl 5 :>>++data PathViewL u = EmptyPathL+                 | PathSegment u :<< AbsPath u+  deriving (Eq,Show) ++type instance DUnit (PathViewL u) = u ++type DPathViewL = PathViewL Double++data PathViewR u = EmptyPathR+                 | AbsPath u :>> PathSegment u+  deriving (Eq,Show) ++type instance DUnit (PathViewR u) = u ++type DPathViewR = PathViewR Double++++-- | PathSegments are annotated with length.+--+--+data PathSegment u = LineSeg  u (Point2 u) (Point2 u)+                   | CurveSeg u (Point2 u) (Point2 u) (Point2 u) (Point2 u)+  deriving (Eq,Show) ++type instance DUnit (PathSegment u) = u +++type DPathSegment = PathSegment Double+++--------------------------------------------------------------------------------++instance Functor PathSegment where+  fmap f (LineSeg d p0 p1)        = LineSeg (f d) (fmap f p0) (fmap f p1)+  fmap f (CurveSeg d p0 p1 p2 p3) = +      CurveSeg (f d) (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3)++instance Functor PathViewL where+  fmap _ EmptyPathL   = EmptyPathL+  fmap f (a :<< as)   = fmap f a :<< fmap f as++instance Functor PathViewR where+  fmap _ EmptyPathR   = EmptyPathR+  fmap f (as :>> a)   = fmap f as :>> fmap f a++--------------------------------------------------------------------------------++++pathViewL :: Num u => AbsPath u -> PathViewL u+pathViewL (AbsPath len sp segs ep) = go (viewl segs)+  where+    go EmptyL                           = EmptyPathL+     +    go (AbsLineSeg d v1 :< se)        =+        let p1 = sp .+^ v1 in LineSeg d sp p1 :<< AbsPath (len - d) p1 se ep++    go (AbsCurveSeg d v1 v2 v3 :< se) =+        let p1 = sp .+^ v1+            p2 = p1 .+^ v2+            p3 = p2 .+^ v3+        in CurveSeg d sp p1 p2 p3 :<< AbsPath (len - d) p3 se ep+++pathViewR :: Num u => AbsPath u -> PathViewR u+pathViewR (AbsPath len sp segs ep) = go (viewr segs)+  where+    go EmptyR                           = EmptyPathR ++    go (se :> AbsLineSeg d v1)        = +       let p0 = ep .-^ v1 in AbsPath (len - d) sp se p0 :>> LineSeg d p0 ep++    go (se :> AbsCurveSeg d v1 v2 v3) =  +       let p2 = ep .-^ v3+           p1 = p2 .-^ v2+           p0 = p1 .-^ v1+       in AbsPath (len - d) sp se p0 :>> CurveSeg d p0 p1 p2 ep++++--------------------------------------------------------------------------------+++-- Path should be same length afterwards.++optimizeLines :: (Real u, Floating u, Ord u, Tolerance u) +              => AbsPath u -> AbsPath u+optimizeLines (AbsPath _ sp0 segs _) =+    outer (zeroPath sp0) (viewl segs)+  where+    outer acc (AbsLineSeg _ v1 :< se)              = +        inner acc (vdirection v1) v1 (viewl se)++    outer acc (AbsCurveSeg u v1 v2 v3  :< se)      = +        outer (snocC acc u v1 v2 v3) (viewl se)++    outer acc EmptyL                               = acc++    inner acc d0 v0 (AbsLineSeg _ v1 :< se)        =+        let d1 = vdirection v1+        in if (d0 == vdirection v1) +          then inner acc d1 (v0 ^+^ v1) (viewl se)+          else inner (snocV acc v0) d1 v1 (viewl se)++    inner acc _  v0 (AbsCurveSeg u v1 v2 v3 :< se) = +        let acc1 = snocC (snocV acc v0) u v1 v2 v3+        in outer acc1 (viewl se)++    inner acc _  v0 EmptyL                         = snocV acc v0++    snocC (AbsPath u sp se ep) u1 v1 v2 v3         = +        let tail_curve = AbsCurveSeg u1 v1 v2 v3 +            vtotal     = v1 ^+^ v2 ^+^ v3 +        in AbsPath (u+u1) sp (JL.snoc se tail_curve) (ep .+^ vtotal)++    snocV (AbsPath u sp se ep) v1                  =+        let u1        = vlength v1+            tail_line = AbsLineSeg u1 v1+        in AbsPath (u+u1) sp (JL.snoc se tail_line) (ep .+^ v1)+++--------------------------------------------------------------------------------+-- Round corners+++segToCatTrail :: AbsPathSeg u -> CatTrail u+segToCatTrail (AbsLineSeg _ v1)        = catline v1+segToCatTrail (AbsCurveSeg _ v1 v2 v3) = catcurve v1 v2 v3++-- | Because lookahead of 2 makes the rounding algos easier we+-- decons to a list...+--+segmentListL :: AbsPath u -> (Point2 u, [AbsPathSeg u])+segmentListL (AbsPath _ sp se _) = (sp, JL.toList se)++-- | Round interior corners of a Path.+--+-- The path is treated as open - the start of the initial and end+-- of the final segments are not rounded. Only straight line to +-- straight line joins are rounded, joins to or from Bezier +-- curves are not rounded.+-- +-- Caution - all path segments are expected to be longer than+-- 2x the round corner length, though this is not checked..+--+roundInterior :: (Real u, Floating u,Tolerance u) +              => u -> AbsPath u -> AbsPath u+roundInterior du pth0 = catTrailPath pt ctrail+  where+    (pt,ss) = segmentListL pth0+    ctrail  = roundInteriorCat du ss+++roundInteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u+roundInteriorCat _  []     = mempty+roundInteriorCat du (z:zs) = step mempty z zs+  where+    step ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) = +      let (x,k) = roundAB du v1 v2 in step (ac `mappend` x) k xs++    step ac prev            (x:xs)             = +       let tprev = segToCatTrail prev in step (ac `mappend` tprev) x xs++    step ac prev            []                 = ac `mappend` segToCatTrail prev++roundAB :: (Real u, Floating u) +        => u -> Vec2 u -> Vec2 u -> (CatTrail u, AbsPathSeg u)+roundAB du v1 v2 = +    (catline v1' `mappend` tcurve, lineSegmentV v2')+  where+    v1'      = shortenVec du v1+    v2'      = shortenVec du v2++    tv1      = avec (vdirection v1) du+    tv2      = avec (vdirection v2) du+    base_vec = tv1 ^+^ tv2+    bw       = vlength base_vec+    h        = sqrt $ pow2 du - (pow2 $ 0.5 * bw)+    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...++pow2 :: Num a => a -> a+pow2 x = x ^ (2::Int)++-- Form corners inside a /triangle/ Bezier.+++-- | Round a \"closed\" path. +--+-- Caution - all path sgements are expected to be longer than+-- 2x the round corner length, though this is not checked..+--+roundExterior :: (Real u, Floating u, Tolerance u) +              => u -> AbsPath u -> AbsPath u+roundExterior du pth0 +   | isBezierR pth0 || isBezierL pth0 = roundInterior du pth0+   | otherwise                        = catTrailPath pt ctrail+  where+   (pt,ss) = segmentListL pth0+   ctrail  = roundExteriorCat du ss+++roundExteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u+roundExteriorCat _  []                        = mempty++roundExteriorCat _  (AbsCurveSeg _ _ _ _ : _) = +    error "runExteriorCat - unreachable."++roundExteriorCat du (z@(AbsLineSeg _ v0):zs)  = step0 z zs+  where+    step0 (AbsLineSeg _ v1) xs = +      let seg0 = lineSegmentV $ shortenVec du v1 in step1 mempty seg0 xs++    step0 _                 _  = error "roundExteriorCat - unreachable 1."+    +    step1 ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) = +      let (x,k) = roundAB du v1 v2 in step1 (ac `mappend` x) k xs++    step1 ac prev              (x:xs)             = +      let tprev = segToCatTrail prev in step1 (ac `mappend` tprev) x xs++    step1 ac (AbsLineSeg _ v1) []                 = +      let (t,_) = roundAB du v1 v0 in ac `mappend` t++    step1 _  _                 []                 = +      error "roundExteriorCat - unreachable 2."+++-- | 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+++-- | Divide a path returning intermediate points and direction+--+-- Args are initial-prefix, division size, trailing size.+-- +-- Generation is stopped if the remainder of the path is shorter+-- than the trailing size.+--+pathdiv :: (Real u, Floating u) +        => u -> u -> u -> AbsPath u -> [(Point2 u, Radian)]+pathdiv ana sz end = step . shortenL ana +  where+    step pth | length pth < end = []+             | otherwise         = atstart pth : step (shortenL sz pth)+
− src/Wumpus/Drawing/Paths/Connectors.hs 
@@ -1,247 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths.Connectors--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Library of connector paths...------ \*\* WARNING \*\* this module is experimental and may change --- significantly in future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths.Connectors-  ( --    ConnectorPath-  , DConnectorPath-  , sconnect--  , connLine--  , connRightVH-  , connRightHV-  , connRightVHV-  , connRightHVH--  , connIsosceles-  , connIsosceles2-  , connLightningBolt--  , connIsoscelesCurve-  , connSquareCurve-  , connUSquareCurve--  , connTrapezoidCurve-  , connZSquareCurve-  , connUZSquareCurve--  ) where--import Wumpus.Drawing.Paths.Base-import Wumpus.Drawing.Paths.ControlPoints--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Applicative-import Prelude hiding ( length )----- | Note - a ConnectorPath is not drawn automatically, it is a--- @ConnectorCF@ not a @ConnectorGraphic@ or @ConnectorImage@.----type ConnectorPath u = ConnectorCF u (Path u)--type DConnectorPath = ConnectorPath Double------ Maybe this should be ConnectorPath u -> ConnectorImage u (Path u) instead?--- This would be closer to the new shapes...----sconnect :: Num u -         => ConnectorPath u -> Point2 u -> Point2 u -> Image u (Path u)-sconnect mf p0 p1 = -    connect mf p0 p1 >>= \cpath -> -    intoImage (pure cpath) (openStroke $ toPrimPath cpath)  -                    ---- | Build the path with interior round corners.--- -roundCornerPath :: (Real u, Floating u, FromPtSize u) -                => [Point2 u] -> CF (Path u)-roundCornerPath xs = getRoundCornerSize >>= \sz -> -    if sz == 0 then return (traceLinePoints xs) -               else return (roundInterior  sz xs)---------------------------------------------------------------------------------------- | Connect with a straight line.----connLine :: Floating u => ConnectorPath u-connLine = promoteR2 $ \p0 p1 -> pure $ line p0 p1------ | Right-angled connector - go vertical, then go horizontal.----connRightVH :: (Real u, Floating u, FromPtSize u) => ConnectorPath u-connRightVH = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->-    let mid = P2 x0 y1 in roundCornerPath [p0, mid, p1]------ | Right-angled connector - go horizontal, then go vertical.----connRightHV :: (Real u, Floating u, FromPtSize u) -            => ConnectorPath u-connRightHV = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> -    let mid = P2 x1 y0 in roundCornerPath [p0, mid, p1]---- | Right-angled connector - go vertical for the supplied --- distance, go horizontal, go vertical again for the --- remaining distance.--- -connRightVHV :: (Real u, Floating u, FromPtSize u) -             => u -> ConnectorPath u-connRightVHV v = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 x1 _) ->-    let a0 = p0 .+^ vvec v-        a1 = a0 .+^ hvec (x1 - x0)-    in roundCornerPath [p0, a0, a1, p1]----- | Right-angled connector - go horizontal for the supplied --- distance, go verical, go horizontal again for the --- remaining distance.--- -connRightHVH :: (Real u, Floating u, FromPtSize u) -             => u -> ConnectorPath u-connRightHVH h = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 _ y1) -> -    let a0 = p0 .+^ hvec h-        a1 = a0 .+^ vvec (y1 - y0)-    in roundCornerPath [p0,a0,a1,p1]----- | /Triangular/ joint.--- --- @u@ is the altitude of the triangle.----connIsosceles :: (Real u, Floating u, FromPtSize u) -              => u -> ConnectorPath u -connIsosceles dy = promoteR2 $ \ p0 p1 -> -    let mid_pt  = midpointIsosceles dy p0 p1-    in roundCornerPath [p0, mid_pt, p1]- -    ------ | Double /triangular/ joint.--- --- @u@ is the altitude of the triangle.----connIsosceles2 :: (Real u, Floating u, FromPtSize u)-               => u -> ConnectorPath u -connIsosceles2 u = promoteR2 $ \ p0 p1 -> -    let (cp0,cp1) = dblpointIsosceles u p0 p1-    in roundCornerPath [ p0, cp0, cp1, p1 ]------ | /Lightning bolt/ joint - a two joint connector with an /axis/--- perpendicular to the connector direction.--- --- @u@ is the half length of the of the axis.----connLightningBolt :: (Real u, Floating u, FromPtSize u) -                  => u -> ConnectorPath u -connLightningBolt u = promoteR2 $ \ p0 p1 -> -    let cp0 = midpointIsosceles   u  p0 p1-        cp1 = midpointIsosceles (-u) p0 p1-    in roundCornerPath [ p0, cp0, cp1, p1 ]---------------------------------------------------------------------------------------- | Form a curve inside an isosceles triangle. ------ The two Bezier control points take the same point - the--- altitude of the triangle. The curve tends to be quite shallow--- relative to the altitude.------ @u@ is the altitude of the triangle.----connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u -connIsoscelesCurve u = promoteR2 $ \ p0 p1 ->-    let control_pt  = midpointIsosceles u p0 p1-    in pure $ traceCurvePoints [p0, control_pt, control_pt, p1]-   -    ---- | Form a curve inside a square. ------ The two Bezier control points take the /top/ corners. The--- curve tends to be very deep.--- -connSquareCurve :: (Real u, Floating u) => ConnectorPath u -connSquareCurve = promoteR2 $ \ p0 p1 ->-    let (cp0,cp1) = squareFromBasePoints p0 p1-    in pure $ traceCurvePoints [p0, cp0, cp1, p1]------ | Form a curve inside a square. ------ As per 'connSquareCurve' but the curve is drawn /underneath/--- the line formed between the start and end points.--- --- (Underneath is modulo the direction, of course).--- -connUSquareCurve :: (Real u, Floating u) => ConnectorPath u -connUSquareCurve = promoteR2 $ \ p0 p1 -> -    let (cp0,cp1) = usquareFromBasePoints p0 p1-    in pure $ traceCurvePoints [p0, cp0, cp1, p1]----- | altitude * ratio_to_base ------ Form a curve inside a trapeziod.--- -connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u -connTrapezoidCurve u ratio_to_base = promoteR2 $ \p0 p1 -> -    let (cp0,cp1)  = trapezoidFromBasePoints u ratio_to_base p0 p1-    in pure $ traceCurvePoints [p0, cp0, cp1, p1]----- | Make a curve within a square, following the corner points as--- a Z.----connZSquareCurve :: (Real u, Floating u) => ConnectorPath u -connZSquareCurve = promoteR2 $ \p0 p1 -> -    let (cp0,cp1)  = squareFromCornerPoints p0 p1-    in pure $ traceCurvePoints [p0,cp0,cp1,p1]---- | Make a curve within a square, following the corner points as--- a Z.------ The order of tracing flips the control points, so this is an--- /underneath/ version of 'connZSquareCurve'.--- -connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u -connUZSquareCurve = promoteR2 $ \ p0 p1 ->  -   let (cp0,cp1)  = squareFromCornerPoints p0 p1 -   in pure $ traceCurvePoints [p0,cp1,cp0,p1]-
− src/Wumpus/Drawing/Paths/ControlPoints.hs 
@@ -1,189 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths.ControlPoints--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Collection of point manufacturing functions.------ \*\* WARNING \*\* this module is experimental and may change --- significantly in future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths.ControlPoints-  ( --    midpointIsosceles-  , dblpointIsosceles--  , rectangleFromBasePoints-  , squareFromBasePoints-  , usquareFromBasePoints--  , trapezoidFromBasePoints--  , squareFromCornerPoints--  ) where--import Wumpus.Basic.Kernel--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space------- | 'midpointIsosceles' : --- @ altitude * start_pt * end_pt -> mid_pt @------ Triangular midpoint.--- --- @u@ is the altitude of the triangle - negative values of u --- form the triangle below the line.----midpointIsosceles :: (Real u, Floating u) -                  => u -> Point2 u -> Point2 u -> Point2 u-midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = -    mid_pt .+^ avec perp_ang u-  where-    mid_pt    = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1))-    perp_ang  = (pi*0.5) + vdirection (pvec p1 p2) ------ | 'dblpointIsosceles' : --- @ altitude * start_pt * end_pt * (third_pt, two_thirds_pt) @--- --- Double triangular joint - one joint at a third of the line--- length, the other at two thirds.--- -dblpointIsosceles :: (Real u, Floating u) -                      => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u)  -dblpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = -    (mid1 .+^ avec perp_ang u, mid2 .-^ avec perp_ang u)-  where-    mid1      = P2 (x1 + 0.33*(x2-x1)) (y1 + 0.33*(y2-y1))-    mid2      = P2 (x1 + 0.66*(x2-x1)) (y1 + 0.66*(y2-y1))-    perp_ang  = (pi*0.5) + vdirection (pvec p1 p2) ----------------------------------------------------------------------------------------- | 'rectangleFromBasePoints' : --- @ altitude * start_pt * end_pt * (top_left, top_right) @--- --- Control points forming a rectangle. ------ The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@.----rectangleFromBasePoints :: (Real u, Floating u) -                  => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u)-rectangleFromBasePoints u p1 p2 = (cp1, cp2)-  where-    base_vec  = pvec p1 p2-    theta     = vdirection base_vec-    cp1       = displacePerpendicular u theta p1-    cp2       = displacePerpendicular u theta p2----- | 'squareFromBasePoints' : --- @ start_pt -> end_pt -> (top_left, top_right) @--- --- Control points forming a square - side_len derived from the --- distance between start and end points.------ The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@.----squareFromBasePoints :: (Real u, Floating u) -                     => Point2 u -> Point2 u -> (Point2 u, Point2 u)-squareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2-  where-    side_len  = vlength $ pvec p1 p2----- | 'usquareFromBasePoints' : --- @ start_pt -> end_pt -> (bottom_left, bottom_right) @--- --- Control points forming a square - side_len derived from the --- distance between start and end points.------ As per 'squareFromBasePoints' but the square is drawn --- /underneath/ the line formed between the start and end points.--- (Underneath is modulo the direction, of course).------ The two manufactured control points form the /bottom/ corners, --- so the supplied points map as @start_point == top_left@ and --- @end_point == top_right@.--- -usquareFromBasePoints :: (Real u, Floating u) -                      => Point2 u -> Point2 u -> (Point2 u, Point2 u)-usquareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2-  where-    side_len  = negate $ vlength $ pvec p1 p2-------- | 'trapezoidFromBasePoints' : --- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @------ Control points form an isosceles trapezoid.------ The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@.--- -trapezoidFromBasePoints :: (Real u, Floating u) -                        => u -> u -> Point2 u -> Point2 u -                        -> (Point2 u, Point2 u) -trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2)-  where-    base_vec  = pvec p1 p2-    base_len  = vlength base_vec-    theta     = vdirection base_vec-    half_ulen = 0.5 * ratio_to_base * base_len-    base_mid  = displaceParallel (0.5 * base_len) theta p1-    ubase_mid = displacePerpendicular u theta base_mid-    cp1       = displaceParallel (-half_ulen) theta ubase_mid-    cp2       = displaceParallel   half_ulen  theta ubase_mid------- | 'squareFromCornerPoints' : --- @ altitude * start_pt * end_pt * (top_left, bottom_right) @--- --- Control points forming a square bisected by the line from --- start_pt to end_pt. ------ The two manufactured control points form the top_left and--- bottom_right corners, so the supplied points map as --- @start_point == bottom_left@ and @end_point == top_right@.----squareFromCornerPoints :: (Real u, Floating u) -                       => Point2 u -> Point2 u -> (Point2 u, Point2 u) -squareFromCornerPoints p1 p2 = (cp1, cp2)-  where-    base_vec  = pvec p1 p2-    half_len  = 0.5 * (vlength base_vec)-    theta     = vdirection base_vec-    base_mid  = displaceParallel half_len theta p1-    cp1       = displacePerpendicular   half_len  theta base_mid-    cp2       = displacePerpendicular (-half_len) theta base_mid-
+ src/Wumpus/Drawing/Paths/Illustrate.hs view
@@ -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+
+ src/Wumpus/Drawing/Paths/Intersection.hs view
@@ -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
− src/Wumpus/Drawing/Paths/MonadicConstruction.hs 
@@ -1,160 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Paths.MonadicConstruction--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Build paths monadically.------ \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Paths.MonadicConstruction-  ( --    PathM-  , runPath-  , execPath--  , tip--  , lineto-  , rlineto-  , hline-  , vline--  , bezierto-  , curveto--  , verticalHorizontal-  , horizontalVertical--  ) where--import Wumpus.Basic.Utils.HList-import Wumpus.Drawing.Paths.Base--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Applicative-import Data.List----- Are connectors and paths quite different things?------ It looks like they are - connectors always know start and end --- points.-------- State monad version is quite good - it ameliorates the problem--- of joining to the end point of an empty path...--data St u = St-      { current_point :: Point2 u -      , path_acc      :: H (Path u)-      }---newtype PathM u a = PathM { getPathM :: St u -> (a,St u) }---instance Functor (PathM u) where-  fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1)---instance Applicative (PathM u) where-  pure a    = PathM $ \s -> (a,s)-  mf <*> ma = PathM $ \s -> let (f,s1) = getPathM mf s-                                (a,s2) = getPathM ma s1-                            in (f a,s2)--instance Monad (PathM u) where-  return a  = PathM $ \s -> (a,s)-  m >>= k   = PathM $ \s -> let (a,s1) = getPathM m s in-                            (getPathM . k) a s1------ Running the path is (probably) agnostic to the DrawingCtx.----runPath :: Floating u => Point2 u -> PathM u a -> (a, Path u)-runPath start mf = -    let (a,s') = getPathM mf s in (a, post $ toListH $ path_acc s')-  where-    s = St { current_point = start-           , path_acc      = emptyH-           }-    post []     = line start start-    post (x:xs) = foldl' append x xs  --execPath :: Floating u => Point2 u -> PathM u a -> Path u-execPath start mf = snd $ runPath start mf--snocline :: Floating u => Vec2 u -> PathM u ()-snocline v = PathM $ \(St pt ac) -> let ep = pt .+^ v -                                    in ((), St ep (ac `snocH` line pt ep))---tip :: PathM u (Point2 u)-tip = PathM $ \s -> (current_point s,s)---lineto :: Floating u => Point2 u -> PathM u ()-lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `snocH` line p0 pt))--rlineto :: Floating u => Vec2 u -> PathM u ()-rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy))---hline :: Floating u => u -> PathM u ()-hline len = snocline (hvec len) --vline :: Floating u => u -> PathM u ()-vline len = snocline (vvec len) ----bezierto :: (Floating u, Ord u) -         => Point2 u -> Point2 u -> Point2 u -> PathM u ()-bezierto c1 c2 ep = PathM $ \(St p0 ac) -> -    ((), St ep (ac `snocH` curve p0 c1 c2 ep))-----------curveto :: (Floating u, Ord u) -        => Radian -> Radian -> Point2 u -> PathM u ()-curveto cin cout end = PathM $ \(St p0 ac) -> -    let seg  = curveByAngles p0 cin cout end -        ac1  = ac `snocH` seg-        end1 = tipR seg-    in ((), St end1 ac1) -----verticalHorizontal :: Floating u => Point2 u -> PathM u ()-verticalHorizontal (P2 x y) = -    tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y)--horizontalVertical :: Floating u => Point2 u -> PathM u ()-horizontalVertical (P2 x y) = -    tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y)-
+ src/Wumpus/Drawing/Paths/PathBuilder.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.PathBuilder+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Build relative paths monadically.+--+-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.PathBuilder+  ( +++    GenPathSpec+  , PathSpec+  , Vamp(..)+++  , runGenPathSpec+  , execGenPathSpec+  , evalGenPathSpec+  , stripGenPathSpec++  , runPathSpec+  , runPathSpec_++  , runPivot+++  , penline+  , pencurve+ +  +  , breakPath+  , hpenline+  , vpenline+  , apenline++  , penlines+  , pathmoves++  , vamp+  , cycleSubPath+  , updatePen+ +  ) where++import Wumpus.Drawing.Paths.Base++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Control.Applicative+import Control.Monad+import Data.Monoid+import Prelude hiding ( null, cycle, lines )++-- +-- TODO - possibly we need two drawing contexts one for the pen +-- and one for the decoration trace.+-- +-- Alternatively PathSt should have a local DrawingContext for the +-- pen.+--+++-- | Note - a path spec has an immutable start point like +-- @LocDrawing@.+--+-- Effectively a path is draw in a local coordinate system with +-- @(0,0)@ as the origin.+--+newtype GenPathSpec st u a = GenPathSpec { +    getGenPathSpec :: DrawingContext -> PathSt st -> (a, PathSt st, CatPrim) }++type instance DUnit   (GenPathSpec st u a) = u+type instance UState  (GenPathSpec st u a) = st++type PathSpec u a = GenPathSpec () u a+++data PathSt st = PathSt+      { st_active_pen       :: ActivePen+      , st_pen_ctx          :: DrawingContext+      , st_cumulative_path  :: AbsPath Double+      , st_user_state       :: st+      }+++-- | Note - this formulation doesn\'t support monoidal append.+-- +-- Information gets lost for this one (we really would want to +-- draw the left-hand-side):+--+-- > PEN_DOWN _ _ `mappend` PEN_UP+--+-- So it has to be part of the state not the writer.+-- +data ActivePen = PEN_UP +               | PEN_DOWN (AbsPath Double)+                         +++zeroActivePen :: DPoint2 -> ActivePen+zeroActivePen pt = PEN_DOWN (emptyPath pt)+++data Vamp u = Vamp+       { vamp_move :: Vec2 u+       , vamp_conn :: ConnectorGraphic u+       }++type instance DUnit (Vamp u) = u+++--------------------------------------------------------------------------------+-- Instances+++-- Functor++instance Functor (GenPathSpec st u) where+  fmap f ma = GenPathSpec $ \ctx s -> +                let (a,s1,w1) = getGenPathSpec ma ctx s +                in (f a,s1,w1)+++-- Applicative++instance Applicative (GenPathSpec st u) where+  pure a    = GenPathSpec $ \_   s -> (a, s, mempty)+  mf <*> ma = GenPathSpec $ \ctx s -> +                let (f,s1,w1) = getGenPathSpec mf ctx s+                    (a,s2,w2) = getGenPathSpec ma ctx s1+                in (f a, s2, w1 `mappend` w2)+++-- Monad++instance Monad (GenPathSpec st u) where+  return a  = GenPathSpec $ \_   s -> (a, s, mempty)+  ma >>= k  = GenPathSpec $ \ctx s -> +                let (a,s1,w1) = getGenPathSpec ma ctx s+                    (b,s2,w2) = (getGenPathSpec . k) a ctx s1+                in (b, s2, w1 `mappend` w2)+++-- Monoid ++instance Monoid a => Monoid (GenPathSpec st u a) where+  mempty           = GenPathSpec $ \_   s -> (mempty, s, mempty)+  ma `mappend` mb  = GenPathSpec $ \ctx s -> +                       let (a,s1,w1) = getGenPathSpec ma ctx s+                           (b,s2,w2) = getGenPathSpec mb ctx s1+                       in (a `mappend` b, s2, w1 `mappend` w2)+++-- DrawingCtxM++instance DrawingCtxM (GenPathSpec st u) where+  askDC           = GenPathSpec $ \ctx s -> (ctx, s, mempty)+  asksDC f        = GenPathSpec $ \ctx s -> (f ctx, s, mempty)+  localize upd ma = GenPathSpec $ \ctx s -> +                      getGenPathSpec ma (upd ctx) s+++-- UserStateM ++instance UserStateM (GenPathSpec st u) where+  getState        = GenPathSpec $ \_ s -> +                      (st_user_state s, s, mempty)+  setState ust    = GenPathSpec $ \_ s -> +                      ((), s {st_user_state = ust} , mempty)+  updateState upd = GenPathSpec $ \_ s -> +                      let ust = st_user_state s+                      in ((), s {st_user_state =  upd ust}, mempty)++++-- Note - all these need to peek at the cumulative path++-- LocationM++instance InterpretUnit u => LocationM (GenPathSpec st u) where+  location = locationImpl+++-- CursorM ++instance InterpretUnit u => CursorM (GenPathSpec st u) where+  moveby   = movebyImpl+++-- InsertlM++instance InterpretUnit u => InsertlM (GenPathSpec st u) where+  insertl  = insertlImpl+++           +--------------------------------------------------------------------------------+-- Run functions++runGenPathSpec :: InterpretUnit u +               => st -> PathMode -> GenPathSpec st u a +               -> LocImage u (a, st, AbsPath u)+runGenPathSpec st mode ma = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let P2 dx dy  = normalizeF (dc_font_size ctx) pt+        st_zero   = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) st+        (a,s1,w1) = getGenPathSpec ma ctx st_zero+        dpath     = translate dx dy $ st_cumulative_path s1+        upath     = dinterpF (dc_font_size ctx) dpath+        pctx      = st_pen_ctx s1+        (_,w2)    = runImage pctx (renderActivePen mode $ st_active_pen s1) +        wfinal    = cpmove (V2 dx dy) $ w1 `mappend` w2+    in replaceAns (a, st_user_state s1, upath) $ primGraphic wfinal+++-- Note - eval and exec return the AbsPath this is as-per RWS+-- which returns @w@ for execRWS (s,w) and evalRWS (a,w)+--++evalGenPathSpec :: InterpretUnit u+                => st -> PathMode -> GenPathSpec st u a+                -> LocImage u (a, AbsPath u)+evalGenPathSpec st mode ma = +    (\(a,_,w) -> (a,w)) <$> runGenPathSpec st mode ma++    ++execGenPathSpec :: InterpretUnit u+                => st -> PathMode -> GenPathSpec st u a+                -> LocImage u (st, AbsPath u)+execGenPathSpec st mode ma =+    (\(_,s,w) -> (s,w)) <$> runGenPathSpec st mode ma++++stripGenPathSpec :: InterpretUnit u+                 => st -> PathMode -> GenPathSpec st u a+                 -> LocQuery u (a, st, AbsPath u)+stripGenPathSpec st mode ma = stripLocImage $ runGenPathSpec st mode ma+++runPathSpec :: InterpretUnit u+            => PathMode -> PathSpec u a -> LocImage u (a, AbsPath u)+runPathSpec mode ma = evalGenPathSpec () mode ma++runPathSpec_ :: InterpretUnit u+             => PathMode -> PathSpec u a -> LocGraphic u+runPathSpec_ mode ma = ignoreAns $ evalGenPathSpec () mode ma++++-- Monad run function nomenclature:+--+-- > run  - both+-- > eval - answer (no state)+-- > exec - state (no answer)+-- +-- Note RWS always returns the @w@.+--+-- For Wumpus:+-- +-- > run  - monadic answer, and the writer /construction/+-- > eval - just the monadic answer+-- > exec - just the writer /construction/.+--+-- In all case the CatPrim inside the LocImage may contain +-- additional graphics.+--+-- Client code can use @ignoreAns@ to generate a @LocGraphic@+-- from the @LocImage@.++++-- | Helper.+--+renderActivePen :: PathMode -> ActivePen -> DGraphic +renderActivePen _    PEN_UP              = mempty+renderActivePen mode (PEN_DOWN abs_path) = renderPath_ mode abs_path++++++++-- | Form a \"pivot path\" drawing from two path specifications.+-- The start point of the drawing is the pivot formed by joining+-- the paths.+--+runPivot :: (Floating u, InterpretUnit u)+          => PathSpec u a -> PathSpec u a -> LocGraphic u+runPivot ma mb = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let dpt        = normalizeF (dc_font_size ctx) pt+        st_zero    = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) ()+        (p1,s1,w1) = getGenPathSpec mz ctx st_zero+        dp1        = normalizeF (dc_font_size ctx) p1+        v1         = pvec dpt dp1+        pctx       = st_pen_ctx s1+        (_,w2)     = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s1+        wfinal     = w1 `mappend` w2+    in primGraphic $ cpmove (negateV v1) wfinal+  where+    mz = ma >> location >>= \pt -> mb >> return pt+++--------------------------------------------------------------------------------+-- operations+++locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u)+locationImpl = GenPathSpec $ \ctx s ->+    let pt  = tipR $ st_cumulative_path s +        upt = dinterpF (dc_font_size ctx) pt+    in (upt, s, mempty)+++-- | 'extendPaths' extends both the @cumulative_path@ and the +-- @active_pen@. If the pen is up it, changes to a pendown.+--+extendPaths :: DVec2 -> PathSt st -> PathSt st+extendPaths v1 s@(PathSt { st_cumulative_path = cp+                         , st_active_pen      = pen} )  = +    s { st_cumulative_path = snocLine cp v1, st_active_pen = upd pen }+  where+    upd PEN_UP          = let pt = tipR cp in PEN_DOWN $ line1 pt (pt .+^ v1)+    upd (PEN_DOWN absp) = PEN_DOWN $ snocLine absp v1+++++-- | Extend the path with a line, drawn by the pen.+-- +penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()+penline v1 = GenPathSpec $ \ctx s -> +   let sz  = dc_font_size ctx+       dv1 = normalizeF sz v1+   in ((), extendPaths dv1 s, mempty)++++-- | @extendPenC@ causes a pendown.+--+extendPathsC :: DVec2 -> DVec2 -> DVec2 -> PathSt st -> PathSt st+extendPathsC v1 v2 v3 s@(PathSt { st_cumulative_path = cp+                                , st_active_pen      = pen} )  = +    s { st_cumulative_path = snocCurve cp (v1,v2,v3), st_active_pen = upd pen }+  where+    upd PEN_UP          = let p0 = tipR cp +                              p1 = p0 .+^ v1+                              p2 = p1 .+^ v2+                              p3 = p2 .+^ v3+                          in PEN_DOWN $ curve1 p0 p1 p2 p3+    upd (PEN_DOWN absp) = PEN_DOWN $ snocCurve absp (v1,v2,v3)++++-- | Extend the path with a curve, drawn by the pen.+-- +pencurve :: InterpretUnit u +        => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u ()+pencurve v1 v2 v3 = GenPathSpec $ \ctx s -> +   let sz  = dc_font_size ctx+       dv1 = normalizeF sz v1+       dv2 = normalizeF sz v2+       dv3 = normalizeF sz v3+   in ((), extendPathsC dv1 dv2 dv3 s, mempty)+++-- | @moveby@ causes a pen up.+--+movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()+movebyImpl v1 = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) ->+    let sz      = dc_font_size ctx+        dv1     = normalizeF sz v1+        (_,w1)  = runImage pctx $ 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)+++breakPath :: InterpretUnit u => GenPathSpec st u ()+breakPath = movebyImpl (V2 0 0)++hpenline :: InterpretUnit u => u -> GenPathSpec st u ()+hpenline dx = penline (hvec dx)++vpenline :: InterpretUnit u => u -> GenPathSpec st u ()+vpenline dy = penline (vvec dy)+++apenline :: (Floating u, InterpretUnit u) +         => Radian -> u -> GenPathSpec st u ()+apenline ang d = penline (avec ang d)++penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()+penlines = mapM_ penline++pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()+pathmoves = mapM_ moveby++++insertlImpl :: InterpretUnit u +            => LocImage u a -> GenPathSpec st u a+insertlImpl gf = GenPathSpec $ \ctx s ->+    let upt     = dinterpF (dc_font_size ctx) (tipR $ st_cumulative_path s)+        (a,wcp) = runLocImage ctx upt gf+    in (a, s, wcp)++++vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u ()+vamp (Vamp v1 conn) = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) ->+    let sz     = dc_font_size ctx+        dv1    = normalizeF sz v1+        (_,w1) = runImage pctx $ 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+    in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }+          , w1 `mappend` w2)+++cycleSubPath :: DrawMode -> GenPathSpec st u ()+cycleSubPath mode = GenPathSpec $ \_ s@(PathSt {st_pen_ctx = pctx}) ->+    let (_,w1) = runImage pctx $ renderActivePen (fn mode) (st_active_pen s)+    in ((), s { st_active_pen = PEN_UP }, w1)+  where+    fn DRAW_STROKE      = CSTROKE+    fn DRAW_FILL        = CFILL+    fn DRAW_FILL_STROKE = CFILL_STROKE++++-- Design note +--+-- Should pen changing be @local@ style vis the Reader monad or a +-- state change with the State monad?+-- +-- Now switched to state change.+--+++-- | Note - updates the pen but doesn\'t draw, the final path+-- will be drawing with the last updated context.+--+updatePen :: DrawingContextF -> GenPathSpec st u ()+updatePen upd = GenPathSpec $ \_ s@(PathSt { st_pen_ctx = pctx})  ->+    ((), s { st_pen_ctx = upd pctx}, mempty )+
+ src/Wumpus/Drawing/Paths/Vamps.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Paths.Vamps+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Library of vamps (currently small).+--+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Paths.Vamps+  ( ++    squareWE++  ) where++import Wumpus.Drawing.Paths.PathBuilder ( Vamp(..) )+import Wumpus.Drawing.Paths.Base++import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core+++-- TODO - library of useful / illustrative vamps (circle, square etc.)++++-- +--+squareWE :: (Real u, Floating  u, Ord u, Tolerance u, InterpretUnit u) +         => u -> Vamp u+squareWE diam = Vamp { vamp_move = hvec diam+                     , vamp_conn = conn }+  where+    conn = promoteConn $ \p1 p2 -> +             let dir = vdirection $ pvec p1 p2+             in renderPath_ CSTROKE $ vectorPathTheta path1 dir p1++    hdiam = 0.5 * diam +    path1 = [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ]+++-- Drawing a cirle picks the half point on the vamp_move vector...+
src/Wumpus/Drawing/Shapes.hs view
@@ -20,12 +20,29 @@   , module Wumpus.Drawing.Shapes.Circle   , module Wumpus.Drawing.Shapes.Diamond   , module Wumpus.Drawing.Shapes.Ellipse+  , module Wumpus.Drawing.Shapes.InvSemicircle+  , module Wumpus.Drawing.Shapes.InvSemiellipse+  , module Wumpus.Drawing.Shapes.InvTriangle+  , module Wumpus.Drawing.Shapes.Parallelogram   , module Wumpus.Drawing.Shapes.Rectangle-+  , module Wumpus.Drawing.Shapes.Semicircle+  , module Wumpus.Drawing.Shapes.Semiellipse+  , module Wumpus.Drawing.Shapes.Trapezium+  , module Wumpus.Drawing.Shapes.Triangle   ) where  import Wumpus.Drawing.Shapes.Base import Wumpus.Drawing.Shapes.Circle import Wumpus.Drawing.Shapes.Diamond import Wumpus.Drawing.Shapes.Ellipse+import Wumpus.Drawing.Shapes.InvSemicircle+import Wumpus.Drawing.Shapes.InvSemiellipse+import Wumpus.Drawing.Shapes.InvTriangle+import Wumpus.Drawing.Shapes.Parallelogram import Wumpus.Drawing.Shapes.Rectangle+import Wumpus.Drawing.Shapes.Semicircle+import Wumpus.Drawing.Shapes.Semiellipse+import Wumpus.Drawing.Shapes.Trapezium+import Wumpus.Drawing.Shapes.Triangle++
src/Wumpus/Drawing/Shapes/Base.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- |--- Module      :  Wumpus.Drawing.Shapes.Base2+-- Module      :  Wumpus.Drawing.Shapes.Base -- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 --@@ -21,69 +20,199 @@   (   -    LocShape-  , intoLocShape+    Shape+  , DShape++  , shapeMap+  , makeShape   , strokedShape+  , dblStrokedShape   , filledShape   , borderedShape+  , rstrokedShape+  , rfilledShape+  , rborderedShape    , roundCornerShapePath +  , updatePathAngle+  , setDecoration+   , ShapeCTM   , makeShapeCTM   , ctmCenter   , ctmAngle-  , projectPoint-- +  , ctmLocale+  , projectFromCtr    ) where -import Wumpus.Basic.Kernel import Wumpus.Drawing.Paths +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Colour ( white ) +import Data.AffineSpace                         -- package: vector-space  import Control.Applicative +-- import Data.Traversable ( Traversable )+-- import qualified Data.Traversable as T -type LocShape u a = LocCF u (a, Path u)+-- | Shape is a record of three /LocTheta/ functions - +-- functions /from Point and Angle to answer/. +--+-- The @shape_path_fun@ returns a path. When the Shape is drawn, +-- the rendering function (@strokedShape@, etc.) uses the path for +-- drawing and returns the polymorphic answer @a@ of the +-- @shape_ans_fun@. Lastly the @shape_decoration@ function can +-- instantiated to add decoration (e.g. text) to the Shape as it +-- is rendered.+--+-- The @a@ of the @shape_ans_fun@ represents some concrete shape +-- object (e.g. a Rectangle, Triangle etc.). Crucial for shape +-- objects is that they support Anchors - this allows connectors +-- to address specific locations on the Shape border so +-- \"node and link\" diagrams can be made easily.+--+data Shape t u = Shape +      { shape_ans_fun     :: LocThetaQuery u (t u)+      , shape_path_fun    :: LocThetaQuery u (AbsPath u) +      , shape_decoration  :: LocThetaGraphic u+      } +type instance DUnit (Shape t u) = u -intoLocShape :: LocCF u a -> LocCF u (Path u) -> LocCF u (a,Path u)-intoLocShape = liftA2 (,)+type DShape t = Shape t Double -strokedShape :: Num u => LocShape u a -> LocImage u a-strokedShape mf = -   promoteR1 $ \pt -> -     (mf `at` pt) >>= \(a,spath) -> -     intoImage (pure a) (closedStroke $ toPrimPath spath) +-------------------------------------------------------------------------------- -filledShape :: Num u => LocShape u a -> LocImage u a-filledShape mf = -   promoteR1 $ \pt -> -     (mf `at` pt) >>= \(a,spath) -> -     intoImage (pure a) (filledPath $ toPrimPath spath)+shapeMap :: InterpretUnit u +         => (t u -> t' u) -> Shape t u -> Shape t' u+shapeMap f = (\s sf -> s { shape_ans_fun = qpromoteLocTheta $ \pt ang -> +                                           fmap f $ qapplyLocTheta sf pt ang }) +                <*> shape_ans_fun  -borderedShape :: Num u => LocShape u a -> LocImage u a-borderedShape mf = -   promoteR1 $ \pt -> -     (mf `at` pt) >>= \(a,spath) -> -     intoImage (pure a) (borderedPath $ toPrimPath spath)+-- Note - there are no instances of Applicative, Monad, +-- DrawingCtxM... so Shapes cannot have localized drawing props.+--+-- @localize@ must be performed in the context of @strokeShape@, +-- @fillShape@ etc.+-- +++--------------------------------------------------------------------------------+++makeShape :: InterpretUnit u+          => LocThetaQuery u (t u) -> LocThetaQuery u (AbsPath u) -> Shape t u+makeShape f g = Shape { shape_ans_fun    = f+                      , shape_path_fun   = g+                      , shape_decoration = emptyLocThetaImage+                      }+++++strokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)+strokedShape = shapeToLoc (dcClosedPath DRAW_STROKE)+++-- | Note - this is simplistic double stroking - draw a background +-- line with triple thickness and draw a white line on top.+--+-- I think this is what TikZ does, but it works better for TikZ +-- where the extra thickness seems to be accounted for by the +-- anchors. For Wumpus, arrows cut into the outside black line.+--+-- Probably Wumpus should calculate two paths instead.+--+dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)+dblStrokedShape sh = decorateAbove back fore +  where+    img  = shapeToLoc (dcClosedPath DRAW_STROKE) sh+    back = getLineWidth >>= \lw ->+           localize (set_line_width $ lw * 3.0) img+    fore = ignoreAns $ localize (stroke_colour white) img++++filledShape :: InterpretUnit u => Shape t u -> LocImage u (t u)+filledShape = shapeToLoc (dcClosedPath DRAW_FILL)+++borderedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)+borderedShape = shapeToLoc (dcClosedPath DRAW_FILL_STROKE)+++shapeToLoc :: InterpretUnit u+           => (PrimPath -> Graphic u) -> Shape t u -> LocImage u (t u)+shapeToLoc drawF sh = promoteLoc $ \pt -> +    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 (decorateAbove g2 $ liftQuery (toPrimPath spath) >>= drawF)++++rstrokedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)+rstrokedShape = shapeToLocTheta (dcClosedPath DRAW_STROKE)+++rfilledShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)+rfilledShape = shapeToLocTheta (dcClosedPath DRAW_FILL)+++rborderedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)+rborderedShape = shapeToLocTheta (dcClosedPath DRAW_FILL_STROKE)+++shapeToLocTheta :: InterpretUnit u+                => (PrimPath -> Graphic u) -> Shape t u -> LocThetaImage u (t u)+shapeToLocTheta drawF sh = promoteLocTheta $ \pt theta -> +    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 $ decorateAbove g2 (liftQuery (toPrimPath spath) >>= drawF)+++ -- | Draw the shape path with round corners. -- -roundCornerShapePath :: (Real u, Floating u, FromPtSize u) -                     => [Point2 u] -> CF (Path u)-roundCornerShapePath xs = getRoundCornerSize >>= \sz -> -    if sz == 0 then return (traceLinePoints xs) -               else return (roundTrail  sz xs)+roundCornerShapePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)+                     => u -> [Point2 u] -> Query u (AbsPath u)+roundCornerShapePath sz xs = +    if sz `tEQ` 0 then return (vertexPath xs) +                  else return (roundExterior sz $ vertexPath xs) +-- | The path angle can be modified. This allows /inverse/ +-- versions of shapes (e.g. InvTriangle) to be made by+-- wrapping a base Shape but rotating the path prior to drawing +-- it.+-- +-- Only the Path needs rotating, the decoration takes the original +-- angle. The anchors are typically implemented by rotating the +-- correspoding anchor of the wrapped Shape about its center.+-- +updatePathAngle :: InterpretUnit u +                => (Radian -> Radian) -> Shape t u -> Shape t u+updatePathAngle f = +    (\s fi -> s { shape_path_fun = qpromoteLocTheta $ \pt ang -> +                                   qapplyLocTheta fi pt (mvTheta ang) })+      <*> shape_path_fun+  where+    mvTheta = circularModulo . f  +setDecoration :: LocThetaGraphic u -> Shape t u -> Shape t u+setDecoration gf = (\s -> s { shape_decoration = gf }) ++ -------------------------------------------------------------------------------- -- CTM @@ -93,33 +222,50 @@  data ShapeCTM u = ShapeCTM        { ctm_center              :: Point2 u-      , ctm_scale_x             :: !u-      , ctm_scale_y             :: !u+      , ctm_scale_x             :: !Double+      , ctm_scale_y             :: !Double       , ctm_rotation            :: Radian       }   deriving (Eq,Ord,Show) - type instance DUnit (ShapeCTM u) = u -makeShapeCTM :: Num u => Point2 u -> ShapeCTM u-makeShapeCTM pt = ShapeCTM { ctm_center   = pt-                           , ctm_scale_x  = 1-                           , ctm_scale_y  = 1-                           , ctm_rotation = 0 } +instance Functor ShapeCTM where+  fmap f = (\s i -> s { ctm_center = fmap f i }) <*> ctm_center  +makeShapeCTM :: Point2 u -> Radian -> ShapeCTM u+makeShapeCTM pt ang = ShapeCTM { ctm_center   = pt+                               , ctm_scale_x  = 1+                               , ctm_scale_y  = 1+                               , ctm_rotation = ang } -instance Num u => Scale (ShapeCTM u) where-  scale sx sy = (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy })-                  <*> ctm_scale_x <*> ctm_scale_y +ctmCenter :: ShapeCTM u -> Point2 u+ctmCenter = ctm_center -instance Rotate (ShapeCTM u) where-  rotate ang = (\s i -> s { ctm_rotation = circularModulo $ i+ang })-                  <*> ctm_rotation+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+  scale sx sy = (\s x y pt -> s { ctm_scale_x = x*sx+                                , ctm_scale_y = y*sy +                                , ctm_center  = scale sx sy pt })+                    <*> ctm_scale_x <*> ctm_scale_y <*> ctm_center+++instance (Real u, Floating u) => Rotate (ShapeCTM u) where+  rotate ang = (\s i pt -> let ctr = rotate ang pt+                           in s { ctm_rotation = circularModulo $ i+ang+                                , ctm_center   = ctr })+                    <*> ctm_rotation <*> ctm_center++ instance (Real u, Floating u) => RotateAbout (ShapeCTM u) where   rotateAbout ang pt =      (\s ctr i -> s { ctm_rotation = circularModulo $ i+ang@@ -127,25 +273,18 @@       <*> ctm_center <*> ctm_rotation  -instance Num u => Translate (ShapeCTM u) where-  translate dx dy = (\s (P2 x y) -> s { ctm_center = P2 (x+dx) (y+dy) })-                      <*> ctm_center-+instance (Num u) => Translate (ShapeCTM u) where+  translate dx dy = +    (\s i -> s { ctm_center = translate dx dy i })+      <*> ctm_center   -ctmCenter :: ShapeCTM u  -> Point2 u-ctmCenter = ctm_center--ctmAngle :: ShapeCTM u -> Radian-ctmAngle = ctm_rotation--+projectFromCtr :: (Real u, Floating u) => Vec2 u -> ShapeCTM u -> Anchor u+projectFromCtr v (ShapeCTM { ctm_center   = ctr+                           , ctm_scale_x  = sx+                           , ctm_scale_y  = sy+                           , ctm_rotation = theta }) = +     let v1 = rotate theta $ scale sx sy $ v in ctr .+^ v1 -projectPoint :: (Real u, Floating u) => Point2 u -> ShapeCTM u  -> Point2 u-projectPoint (P2 x y) (ShapeCTM { ctm_center   = (P2 dx dy)-                                , ctm_scale_x  = sx-                                , ctm_scale_y  = sy-                                , ctm_rotation = theta     }) =-    translate dx dy $ rotate theta $ P2 (sx*x) (sy*y)
src/Wumpus/Drawing/Shapes/Circle.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -32,7 +31,6 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space   import Control.Applicative @@ -45,49 +43,56 @@       { circ_ctm    :: ShapeCTM u       , circ_radius :: !u        }-  deriving (Eq,Show)-  -type DCircle = Circle Double -type instance DUnit (Circle u) = u+type instance DUnit (Circle u) = u   +type DCircle = Circle Double +instance Functor Circle where+  fmap f (Circle ctm r) = Circle (fmap f ctm) (f r)  -mapCircleCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u-mapCircleCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm+--------------------------------------------------------------------------------+-- Affine trans -instance Num u => Scale (Circle u) where-  scale sx sy = mapCircleCTM (scale sx sy)+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u+mapCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm  -instance Rotate (Circle u) where-  rotate ang = mapCircleCTM (rotate ang)-                   +instance (Real u, Floating u) => Rotate (Circle u) where+  rotate ang            = mapCTM (rotate ang)+                   instance (Real u, Floating u) => RotateAbout (Circle u) where-  rotateAbout ang pt = mapCircleCTM (rotateAbout ang pt)+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Circle u) where+  scale sx sy           = mapCTM (scale sx sy)  instance Num u => Translate (Circle u) where-  translate dx dy = mapCircleCTM (translate dx dy)+  translate dx dy       = mapCTM (translate dx dy)  +--------------------------------------------------------------------------------+-- Anchors -runCircle :: (u -> ShapeCTM u -> a) -> Circle u -> a-runCircle fn (Circle { circ_ctm = ctm, circ_radius = radius }) = -    fn radius ctm+runDisplaceCenter :: (Real u, Floating u)+                  => (u -> Vec2 u) -> Circle u -> Anchor u+runDisplaceCenter fn (Circle { circ_ctm    = ctm+                             , circ_radius = radius }) = +    projectFromCtr (fn radius) ctm +-- Anchors look like they need ctx...  instance (Real u, Floating u) => CenterAnchor (Circle u) where-  center = runCircle (\_ -> ctmCenter)+  center = runDisplaceCenter $ \_ -> V2 0 0    instance (Real u, Floating u) => CardinalAnchor (Circle u) where-  north = runCircle $ \r -> projectPoint $ P2 0    r-  south = runCircle $ \r -> projectPoint $ P2 0  (-r)-  east  = runCircle $ \r -> projectPoint $ P2 r    0-  west  = runCircle $ \r -> projectPoint $ P2 (-r) 0+  north = runDisplaceCenter $ \r -> V2 0    r+  south = runDisplaceCenter $ \r -> V2 0  (-r)+  east  = runDisplaceCenter $ \r -> V2 r    0+  west  = runDisplaceCenter $ \r -> V2 (-r) 0   instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where@@ -98,29 +103,35 @@   instance (Real u, Floating u) => RadialAnchor (Circle u) where-  radialAnchor theta = runCircle $ \r -> projectPoint $ zeroPt .+^ avec theta r-+  radialAnchor ang = runDisplaceCenter $ \r -> avec ang r    +--------------------------------------------------------------------------------+-- Construction --- | 'circle'  : @ radius -> shape @+-- | 'circle'  : @ radius -> Shape @ ---circle :: (Real u, Floating u) => u -> LocShape u (Circle u)-circle radius = intoLocShape (mkCircle radius) (mkCirclePath radius)+circle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +       => u -> Shape Circle u+circle radius = makeShape (mkCircle radius) (mkCirclePath radius)             -mkCircle :: Num u => u -> LocCF u (Circle u)-mkCircle radius = promoteR1 $ \ctr -> -    pure $ Circle { circ_ctm = makeShapeCTM ctr, circ_radius = radius }-+mkCircle :: InterpretUnit u => u -> LocThetaQuery u (Circle u)+mkCircle radius = qpromoteLocTheta $ \ctr theta -> +    pure $ Circle { circ_ctm    = makeShapeCTM ctr theta+                  , circ_radius = radius +                  }  -mkCirclePath :: (Floating u, Ord u) => u -> LocCF u (Path u)-mkCirclePath radius = promoteR1 $ \ctr -> -    pure $ traceCurvePoints $ bezierCircle 2 radius ctr +-- Rotation (theta) can be ignored.+--+mkCirclePath :: (Floating u, Ord u, InterpretUnit u, Tolerance u)+             => u -> LocThetaQuery u (AbsPath u)+mkCirclePath radius = qpromoteLocTheta $ \ctr _ ->+    pure $ curvePath $ bezierCircle radius ctr
src/Wumpus/Drawing/Shapes/Diamond.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -12,7 +11,7 @@ -- Stability   :  highly unstable -- Portability :  GHC ----- Simple shapes - rectangle, circle diamond, ellipse.+-- Diamond (rhombus). --  -------------------------------------------------------------------------------- @@ -26,17 +25,17 @@    ) where -import Wumpus.Drawing.Geometry.Intersection-import Wumpus.Drawing.Geometry.Paths++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.Kernel                      -- package: wumpus-basic  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space -import Data.VectorSpace  import Control.Applicative @@ -53,46 +52,72 @@       , dia_hh    :: !u       } +type instance DUnit (Diamond u) = u+ type DDiamond = Diamond Double -type instance DUnit (Diamond u) = u +instance Functor Diamond where+  fmap f (Diamond ctm hw hh) = Diamond (fmap f ctm) (f hw) (f hh) -mapDiamondCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u-mapDiamondCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm+--------------------------------------------------------------------------------+-- Affine trans -instance Num u => Scale (Diamond u) where-  scale sx sy = mapDiamondCTM (scale sx sy)+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u+mapCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm  -instance Rotate (Diamond u) where-  rotate ang = mapDiamondCTM (rotate ang)-                   +instance (Real u, Floating u) => Rotate (Diamond u) where+  rotate ang            = mapCTM (rotate ang)+               instance (Real u, Floating u) => RotateAbout (Diamond u) where-  rotateAbout ang pt = mapDiamondCTM (rotateAbout ang pt)+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Diamond u) where+  scale sx sy           = mapCTM (scale sx sy)  instance Num u => Translate (Diamond u) where-  translate dx dy = mapDiamondCTM (translate dx dy)+  translate dx dy       = mapCTM (translate dx dy)  +--------------------------------------------------------------------------------+-- Anchors -runDiamond :: (u -> u -> ShapeCTM u  -> a) -> Diamond u -> a-runDiamond fm (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = -   fm hw hh ctm+-- | 'runDisplaceCenter' : @ ( half_width +--                           * half_height -> Vec ) * diamond -> Point @+--+runDisplaceCenter :: (Real u, Floating u)+                  => (u -> u -> Vec2 u) -> Diamond u -> Anchor u+runDisplaceCenter fn (Diamond { dia_ctm = ctm+                              , dia_hw = hw+                              , dia_hh = hh }) = +   projectFromCtr (fn hw hh) ctm   instance (Real u, Floating u) => CenterAnchor (Diamond u) where-  center = runDiamond (\_ _ -> ctmCenter)+  center = runDisplaceCenter $ \_ _ -> V2 0 0 +instance (Real u, Floating u) => ApexAnchor (Diamond u) where+  apex = runDisplaceCenter $ \_  hh -> V2 0 hh++instance (Real u, Floating u) => +    SideMidpointAnchor (Diamond u) where+  sideMidpoint n a = step (n `mod` 4) +    where+      step 1 = midpoint (north a) (west a)+      step 2 = midpoint (west a)  (south a)+      step 3 = midpoint (south a) (east a)+      step _ = midpoint (east a)  (north a)++ instance (Real u, Floating u) => CardinalAnchor (Diamond u) where-  north = runDiamond $ \_  hh -> projectPoint $ P2 0 hh-  south = runDiamond $ \_  hh -> projectPoint $ P2 0 (-hh)-  east  = runDiamond $ \hw _  -> projectPoint $ P2 hw 0-  west  = runDiamond $ \hw _  -> projectPoint $ P2 (-hw) 0+  north = apex+  south = runDisplaceCenter $ \_  hh -> V2 0 (-hh)+  east  = runDisplaceCenter $ \hw _  -> V2 hw 0+  west  = runDisplaceCenter $ \hw _  -> V2 (-hw) 0 -instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where+instance (Real u, Floating u) => CardinalAnchor2 (Diamond u) where   northeast x = midpoint (north x) (east x)   southeast x = midpoint (south x) (east x)   southwest x = midpoint (south x) (west x)@@ -100,53 +125,43 @@   -instance (Real u, Floating u) => RadialAnchor (Diamond u) where-   radialAnchor = diamondIntersect+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +      RadialAnchor (Diamond u) where+  radialAnchor ang = runDisplaceCenter $ \hw hh -> +      maybe zeroVec id $ diamondRadialAnchor hw hh ang  --- Utils.Intersection needs improving... --diamondIntersect :: (Real u, Floating u) -                 => Radian -> Diamond u -> Point2 u-diamondIntersect theta (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = -    let ps  = diamondPoints hw hh ctm -        ctr = ctmCenter ctm-    in maybe ctr id $ findIntersect ctr theta $ polygonLines ps-    ---midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u-midpoint p1 p2 = let v = 0.5 *^ pvec p1 p2 in p1 .+^ v+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  -- | 'diamond'  : @ half_width * half_height -> shape @ -- -- Note - args might change to tull_width and full_height... ---diamond :: (Real u, Floating u, FromPtSize u) -        => u -> u -> LocShape u (Diamond u)-diamond hw hh = intoLocShape (mkDiamond hw hh) (mkDiamondPath hw hh)---mkDiamond :: Num u => u -> u -> LocCF u (Diamond u)-mkDiamond hw hh = promoteR1 $ \ctr -> -    pure $ Diamond { dia_ctm = makeShapeCTM ctr, dia_hw = hw, dia_hh = hh }+diamond :: (Real u, Floating u, InterpretUnit u, Tolerance u)+        => u -> u -> Shape Diamond u+diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath hw hh)  -mkDiamondPath :: (Real u, Floating u, FromPtSize u) -              => u -> u -> LocCF u (Path u)-mkDiamondPath hw hh = promoteR1 $ \ctr -> -    roundCornerShapePath $ diamondCoordPath hw hh ctr+mkDiamond :: InterpretUnit u => u -> u -> LocThetaQuery u (Diamond u)+mkDiamond hw hh = qpromoteLocTheta $ \ctr theta -> +    pure $ Diamond { dia_ctm = makeShapeCTM ctr theta+                   , dia_hw  = hw+                   , dia_hh  = hh +                   }  -diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]-diamondPoints hw hh ctm = map (projectPoint `flip` ctm) [ s, e, n, w ]-  where-    s = P2   0  (-hh)-    e = P2   hw    0-    n = P2   0    hh-    w = P2 (-hw)   0 -+mkDiamondPath :: (Real u, Floating u, InterpretUnit u, Tolerance u)+              => u -> u -> LocThetaQuery u (AbsPath u)+mkDiamondPath hw hh = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rdiamond_trail (2*hw) (2*hh) theta
src/Wumpus/Drawing/Shapes/Ellipse.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -28,6 +27,7 @@    ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base @@ -35,7 +35,6 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space   import Control.Applicative @@ -47,55 +46,73 @@ -- Ellipse  + data Ellipse u = Ellipse-      { ell_ctm     :: ShapeCTM u +      { ell_ctm     :: ShapeCTM u       , ell_rx      :: !u       , ell_ry      :: !u       } -type DEllipse = Ellipse Double- type instance DUnit (Ellipse u) = u +type DEllipse = Ellipse Double  -mapEllipseCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u-mapEllipseCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm+instance Functor Ellipse where+  fmap f (Ellipse ctm rx ry) = Ellipse (fmap f ctm) (f rx) (f ry) -instance Num u => Scale (Ellipse u) where-  scale sx sy = mapEllipseCTM (scale sx sy) +--------------------------------------------------------------------------------+-- Affine trans -instance Rotate (Ellipse u) where-  rotate ang = mapEllipseCTM (rotate ang)-                  +mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u+mapCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm ++instance (Real u, Floating u) => Rotate (Ellipse u) where+  rotate ang            = mapCTM (rotate ang)+               instance (Real u, Floating u) => RotateAbout (Ellipse u) where-  rotateAbout ang pt = mapEllipseCTM (rotateAbout ang pt)+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Ellipse u) where+  scale sx sy           = mapCTM (scale sx sy) -instance Num u => Translate (Ellipse u) where-  translate dx dy = mapEllipseCTM (translate dx dy)+instance InterpretUnit u => Translate (Ellipse u) where+  translate dx dy       = mapCTM (translate dx dy)  -runEllipse :: (u -> u -> ShapeCTM u  -> a) -> Ellipse u -> a-runEllipse fn (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) = -    fn rx ry ctm+--------------------------------------------------------------------------------+-- Anchors +-- Note - this is monadic for Ellipse... +runDisplaceCenter :: (Real u, Floating u)+                  => (u -> u -> Vec2 u) -> Ellipse u -> Anchor u+runDisplaceCenter fn (Ellipse { ell_ctm = ctm+                              , ell_rx  = rx+                              , ell_ry  = ry }) = +    projectFromCtr (fn rx ry) ctm+++-- NOTE - the Affine instances provided by Wumpus-Core for Point +-- and Vector may be contradictory for Wumpus-Basic.++ -- | x_radius is the unit length. ---scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t-scaleEll rx ry = scale 1 (ry/rx) +scaleEll :: (Real u, Fractional u)+         => u -> u -> Vec2 u -> Vec2 u+scaleEll rx ry v = let rat = realToFrac (ry/rx) in scale 1 rat v   instance (Real u, Floating u) => CenterAnchor (Ellipse u) where-  center = runEllipse $ \_ _ -> ctmCenter+  center = runDisplaceCenter $ \_ _ -> V2 0 0   instance (Real u, Floating u) => RadialAnchor (Ellipse u) where-  radialAnchor theta = runEllipse $ \rx ry -> -    projectPoint $ scaleEll rx ry $ zeroPt .+^ avec theta rx+  radialAnchor theta = runDisplaceCenter $ \rx ry -> +                         scaleEll rx ry $ avec theta rx   instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where@@ -112,23 +129,27 @@   northwest = radialAnchor (0.75*pi)  -+--------------------------------------------------------------------------------+-- Construction  -- | 'ellipse'  : @ x_radii * y_radii -> shape @ ---ellipse :: (Floating u, Ord u) => u -> u -> LocShape u (Ellipse u)-ellipse rx ry = -    intoLocShape (mkEllipse rx ry) (mkEllipsePath rx ry)+ellipse :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) +        => u -> u -> Shape Ellipse u+ellipse rx ry = makeShape (mkEllipse rx ry) (mkEllipsePath rx ry)  -mkEllipse :: Num u => u -> u -> LocCF u (Ellipse u)-mkEllipse rx ry = promoteR1 $ \ctr -> -    pure $ Ellipse { ell_ctm = makeShapeCTM ctr, ell_rx = rx, ell_ry = ry }+mkEllipse :: InterpretUnit u => u -> u -> LocThetaQuery u (Ellipse u)+mkEllipse rx ry = qpromoteLocTheta $ \ctr theta -> +    pure $ Ellipse { ell_ctm = makeShapeCTM ctr theta+                   , ell_rx  = rx+                   , ell_ry  = ry +                   } --- This is wrong...----mkEllipsePath :: (Floating u, Ord u) => u -> u -> LocCF u (Path u)-mkEllipsePath rx ry = promoteR1 $ \(P2 x y) -> -    pure $ traceCurvePoints $ map (translate x y . scaleEll rx ry) -                            $ bezierCircle 2 rx zeroPt++mkEllipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) +              => u -> u -> LocThetaQuery u (AbsPath u)+mkEllipsePath rx ry = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rellipse_trail rx ry theta+
+ src/Wumpus/Drawing/Shapes/InvSemicircle.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Shapes.InvSemicircle+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Inverse semicircle. +-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.InvSemicircle+  ( ++    InvSemicircle+  , DInvSemicircle+  , invsemicircle++  ) where++import Wumpus.Drawing.Shapes.Base+import Wumpus.Drawing.Shapes.Semicircle++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++++--------------------------------------------------------------------------------+-- Inverse semicircle++newtype InvSemicircle u = InvSemicircle { getInvSemicircle :: Semicircle u }++type instance DUnit (InvSemicircle u) = u+  +type DInvSemicircle = InvSemicircle Double+++instance Functor InvSemicircle where+  fmap f = InvSemicircle . fmap f . getInvSemicircle++--------------------------------------------------------------------------------+-- Affine trans++mapInner :: (Semicircle u -> Semicircle u) +         -> InvSemicircle u +         -> InvSemicircle u+mapInner f = InvSemicircle . f . getInvSemicircle+++instance (Real u, Floating u) => Rotate (InvSemicircle u) where+  rotate ang            = mapInner (rotate ang)+              +instance (Real u, Floating u) => RotateAbout (InvSemicircle u) where+  rotateAbout ang pt    = mapInner (rotateAbout ang pt)++instance Fractional u => Scale (InvSemicircle u) where+  scale sx sy           = mapInner (scale sx sy)++instance InterpretUnit u => Translate (InvSemicircle u) where+  translate dx dy       = mapInner (translate dx dy)++++--------------------------------------------------------------------------------+-- Anchors++runRotateAnchor :: (Real u, Floating u) +                => (Semicircle u -> Anchor u) -> InvSemicircle u -> Anchor u+runRotateAnchor f (InvSemicircle a) = +    let ctr = center a in rotateAbout pi ctr (f a)+++instance (Real u, Floating u) => +    CenterAnchor (InvSemicircle u) where+  center = center . getInvSemicircle++instance (Real u, Floating u) => +    ApexAnchor (InvSemicircle u) where+  apex = runRotateAnchor apex++instance (Real u, Floating u) => +    TopCornerAnchor (InvSemicircle u) where+  topLeftCorner  = runRotateAnchor bottomRightCorner+  topRightCorner = runRotateAnchor bottomLeftCorner++instance (Real u, Floating u) => +    CardinalAnchor (InvSemicircle u) where+  north = runRotateAnchor south+  south = runRotateAnchor north+  east  = runRotateAnchor west+  west  = runRotateAnchor east+++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor2 (InvSemicircle u) where+  northeast = runRotateAnchor southwest+  southeast = runRotateAnchor northwest+  southwest = runRotateAnchor northeast+  northwest = runRotateAnchor southeast++++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    RadialAnchor (InvSemicircle u) where+  radialAnchor theta = +    runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)+++--------------------------------------------------------------------------------+-- Construction++-- | 'invsemicircle'  : @ radius -> Shape @+--+invsemicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +           => u -> Shape InvSemicircle u+invsemicircle radius = +    shapeMap InvSemicircle $ updatePathAngle (+ pi) $ semicircle radius
+ src/Wumpus/Drawing/Shapes/InvSemiellipse.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Shapes.InvSemiellipse+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Inverse semiellipse. +-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.InvSemiellipse+  ( ++    InvSemiellipse+  , DInvSemiellipse+  , invsemiellipse++  ) where++import Wumpus.Drawing.Shapes.Base+import Wumpus.Drawing.Shapes.Semiellipse++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++++--------------------------------------------------------------------------------+-- Inverse semiellipse++newtype InvSemiellipse u = InvSemiellipse { getInvSemiellipse :: Semiellipse u }++type instance DUnit (InvSemiellipse u) = u+  +type DInvSemiellipse = InvSemiellipse Double++++instance Functor InvSemiellipse where+  fmap f = InvSemiellipse . fmap f . getInvSemiellipse++--------------------------------------------------------------------------------+-- Affine trans++mapInner :: (Semiellipse u -> Semiellipse u) +         -> InvSemiellipse u +         -> InvSemiellipse u+mapInner f = InvSemiellipse . f . getInvSemiellipse++instance (Real u, Floating u) => Rotate (InvSemiellipse u) where+  rotate ang            = mapInner (rotate ang)+              +instance (Real u, Floating u) => RotateAbout (InvSemiellipse u) where+  rotateAbout ang pt    = mapInner (rotateAbout ang pt)++instance Fractional u => Scale (InvSemiellipse u) where+  scale sx sy           = mapInner (scale sx sy)++instance InterpretUnit u => Translate (InvSemiellipse u) where+  translate dx dy       = mapInner (translate dx dy)++++--------------------------------------------------------------------------------+-- Anchors++runRotateAnchor :: (Real u, Floating u) +                => (Semiellipse u -> Anchor u) -> InvSemiellipse u -> Anchor u+runRotateAnchor f (InvSemiellipse a) =+    let ctr = center a in rotateAbout pi ctr (f a)++++instance (Real u, Floating u, Tolerance u) => +    CenterAnchor (InvSemiellipse u) where+  center = center . getInvSemiellipse++instance (Real u, Floating u, Tolerance u) => +    ApexAnchor (InvSemiellipse u) where+  apex = runRotateAnchor apex++instance (Real u, Floating u, Tolerance u) => +    TopCornerAnchor (InvSemiellipse u) where+  topLeftCorner  = runRotateAnchor bottomRightCorner+  topRightCorner = runRotateAnchor bottomLeftCorner++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor (InvSemiellipse u) where+  north = runRotateAnchor south+  south = runRotateAnchor north+  east  = runRotateAnchor west+  west  = runRotateAnchor east+++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor2 (InvSemiellipse u) where+  northeast = runRotateAnchor southwest+  southeast = runRotateAnchor northwest+  southwest = runRotateAnchor northeast+  northwest = runRotateAnchor southeast++++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    RadialAnchor (InvSemiellipse u) where+  radialAnchor theta = +    runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)+++--------------------------------------------------------------------------------+-- Construction++-- | 'invsemiellipse'  : @ rx * ry -> Shape @+--+invsemiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u) +           => u -> u -> Shape InvSemiellipse u+invsemiellipse rx ry = +    shapeMap InvSemiellipse $ updatePathAngle (+ pi) $ semiellipse rx ry
+ src/Wumpus/Drawing/Shapes/InvTriangle.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Shapes.InvTriangle+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Inverse version of the Triangle shape.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.InvTriangle+  ( ++    InvTriangle+  , DInvTriangle+  , invtriangle+++  ) where++import Wumpus.Drawing.Basis.Geometry+import Wumpus.Drawing.Shapes.Base+import Wumpus.Drawing.Shapes.Triangle++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++++-- Datatype++newtype InvTriangle u = InvTriangle { getInvTriangle :: Triangle u }++type instance DUnit (InvTriangle u) = u+++type DInvTriangle = InvTriangle Double+++instance Functor InvTriangle where+  fmap f = InvTriangle . fmap f . getInvTriangle+++--------------------------------------------------------------------------------+-- Affine trans++mapInner :: (Triangle u -> Triangle u) -> InvTriangle u -> InvTriangle u+mapInner f = InvTriangle . f . getInvTriangle ++instance (Real u, Floating u) => Rotate (InvTriangle u) where+  rotate ang            = mapInner (rotate ang)+              +instance (Real u, Floating u) => RotateAbout (InvTriangle u) where+  rotateAbout ang pt    = mapInner (rotateAbout ang pt)++instance Fractional u => Scale (InvTriangle u) where+  scale sx sy           = mapInner (scale sx sy)++instance InterpretUnit u => Translate (InvTriangle u) where+  translate dx dy       = mapInner (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors++-- Anchors should be rotated about the center by pi...++runRotateAnchor :: (Real u, Floating u) +                => (Triangle u -> Anchor u) -> InvTriangle u -> Anchor u+runRotateAnchor f (InvTriangle a) =+    let ctr = center a in rotateAbout pi ctr (f a)+++instance (Real u, Floating u) => +    CenterAnchor (InvTriangle u) where+  center = center . getInvTriangle+++-- apex is same on InvTriangle as regular triangle++instance (Real u, Floating u) => +    ApexAnchor (InvTriangle u) where+  apex = runRotateAnchor apex++-- Top corners are bottom corners of the wrapped triangle.+--+instance (Real u, Floating u) => +    TopCornerAnchor (InvTriangle u) where+  topLeftCorner  = runRotateAnchor bottomRightCorner+  topRightCorner = runRotateAnchor bottomLeftCorner+++-- Use established points on the InvTrangle - don\'t delegate to +-- the base Triangle.+--+instance (Real u, Floating u) => +    SideMidpointAnchor (InvTriangle u) where+  sideMidpoint n a = step (n `mod` 3) +    where+      step 1 = midpoint (topRightCorner a)  (topLeftCorner a)+      step 2 = midpoint (topLeftCorner a)   (apex a)+      step _ = midpoint (apex a)            (topRightCorner a)++++-- east and west should be parallel to the centroid.+--++instance (Real u, Floating u) => +    CardinalAnchor (InvTriangle u) where+  north = runRotateAnchor south+  south = runRotateAnchor north+  east  = runRotateAnchor west+  west  = runRotateAnchor east+++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor2 (InvTriangle u) where+  northeast = runRotateAnchor southwest+  southeast = runRotateAnchor northwest+  southwest = runRotateAnchor northeast+  northwest = runRotateAnchor southeast++++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    RadialAnchor (InvTriangle u) where+  radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)++--------------------------------------------------------------------------------+-- Construction++-- | 'invtriangle'  : @ top_base_width * height -> Triangle @+--+--+invtriangle :: (Real u, Floating u, InterpretUnit u, Tolerance u)+            => u -> u -> Shape InvTriangle u+invtriangle bw h = +    shapeMap InvTriangle $ updatePathAngle (+ pi) $ triangle bw h+    +++
+ src/Wumpus/Drawing/Shapes/Parallelogram.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Shapes.Parallelogram+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Parallelogram.+--+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.Parallelogram+  ( ++    Parallelogram+  , DParallelogram+  , parallelogram+  , zparallelogram+++  ) 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.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Data.VectorSpace                         -- package: vector-space++import Control.Applicative+++++--------------------------------------------------------------------------------+-- Parallelogram++-- | A Paralleogram.+--+data Parallelogram u = Parallelogram +      { pll_ctm             :: ShapeCTM u+      , pll_base_width      :: !u+      , pll_height          :: !u+      , pll_base_left_ang   :: Radian+      }++type instance DUnit (Parallelogram u) = u+++type DParallelogram = Parallelogram Double+++instance Functor Parallelogram where+  fmap f (Parallelogram ctm bw h lang) = +      Parallelogram (fmap f ctm) (f bw) (f h) lang++++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Parallelogram u -> Parallelogram u+mapCTM f = (\s i -> s { pll_ctm = f i }) <*> pll_ctm+++instance (Real u, Floating u) => Rotate (Parallelogram u) where+  rotate ang            = mapCTM (rotate ang)+              +instance (Real u, Floating u) => RotateAbout (Parallelogram u) where+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)++instance Fractional u => Scale (Parallelogram u) where+  scale sx sy           = mapCTM (scale sx sy)++instance InterpretUnit u => Translate (Parallelogram u) where+  translate dx dy       = mapCTM (translate dx dy)++--------------------------------------------------------------------------------+-- Anchors++-- | 'runDisplaceCenter' : @ ( base_width+--                           * height +--                           * base_minor+--                           -> 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_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+++-- | WARNING - WRONG...++-- top anchors swap the base minor and major...+--++instance (Real u, Floating u) => +    TopCornerAnchor (Parallelogram u) where+  topLeftCorner  = runDisplaceCenterHalves $ \hw hh lang -> +      let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang hypo++  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  = runDisplaceCenterHalves $ \hw hh lang ->+      let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang (-hypo)++  bottomRightCorner = runDisplaceCenterHalves $ \hw hh lang -> +      let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang (-hypo)++++instance (Real u, Floating u) => +    SideMidpointAnchor (Parallelogram u) where+  sideMidpoint n a = step (n `mod` 4) +    where+      step 1 = midpoint (topRightCorner a)    (topLeftCorner a)+      step 2 = midpoint (topLeftCorner a)     (bottomLeftCorner a)+      step 3 = midpoint (bottomLeftCorner a)  (bottomRightCorner a)+      step _ = midpoint (bottomRightCorner a) (topRightCorner a)++++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor (Parallelogram u) where+  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 = 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 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 +-- QuadrantAlg code cannot handle, and a better abstraction is+-- needed (rather than better implementation of QuadrantAlg).+--+pllRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) +                => 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+++--------------------------------------------------------------------------------+-- Construction+++-- | 'parallelogram'  : @ width * height * bottom_left_ang -> Parallelogram @+--+--+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 bw h lang)+++-- | 'zparallelogram'  : @ base_width * height -> Parallelogram @+--+--+zparallelogram :: (Real u, Floating u, InterpretUnit u, Tolerance u) +              => u -> u -> Shape Parallelogram u+zparallelogram bw h = parallelogram bw h ang+  where+    ang = d2r (60::Double)+++--------------------------------------------------------------------------------+++mkParallelogram :: (Real u, Fractional u, InterpretUnit u, Tolerance u) +                => u -> u -> Radian -> LocThetaQuery u (Parallelogram u)+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 -> Radian -> LocThetaQuery u (AbsPath u)+mkParallelogramPath bw h bl_ang = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rparallelogram_trail bw h bl_ang theta++                         ++++
src/Wumpus/Drawing/Shapes/Rectangle.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -13,6 +12,9 @@ -- Portability :  GHC -- -- Rectangle shape.+--+-- Note - CardinalAnchor2 (northeast etc.) point to their radial +-- positions (this is a change since earlier versions). --  -------------------------------------------------------------------------------- @@ -25,12 +27,12 @@    ) where -import Wumpus.Drawing.Geometry.Intersection-import Wumpus.Drawing.Geometry.Paths+import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core @@ -39,8 +41,7 @@   ------------------------------------------------------------------------------------ Rectangle+-- Data type  data Rectangle u = Rectangle        { rect_ctm    :: ShapeCTM u@@ -49,88 +50,120 @@       }   deriving (Eq,Ord,Show) +type instance DUnit (Rectangle u) = u+ type DRectangle = Rectangle Double  -type instance DUnit (Rectangle u) = u+instance Functor Rectangle where+  fmap f (Rectangle ctm hw hh) = Rectangle (fmap f ctm) (f hw) (f hh) +--------------------------------------------------------------------------------+-- Affine trans -mapRectangleCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u-mapRectangleCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u+mapCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm -instance Num u => Scale (Rectangle u) where-  scale sx sy = mapRectangleCTM (scale sx sy)  -instance Rotate (Rectangle u) where-  rotate ang = mapRectangleCTM (rotate ang)-                  -+instance (Real u, Floating u) => Rotate (Rectangle u) where+  rotate ang            = mapCTM (rotate ang)+               instance (Real u, Floating u) => RotateAbout (Rectangle u) where-  rotateAbout ang pt = mapRectangleCTM (rotateAbout ang pt)+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Rectangle u) where+  scale sx sy           = mapCTM (scale sx sy) -instance Num u => Translate (Rectangle u) where-  translate dx dy = mapRectangleCTM (translate dx dy)+instance InterpretUnit u => Translate (Rectangle u) where+  translate dx dy       = mapCTM (translate dx dy) +--------------------------------------------------------------------------------+-- Anchors   -runRectangle :: (u -> u -> ShapeCTM u -> a) -> Rectangle u -> a-runRectangle fn (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) = -   fn hw hh ctm+-- | 'runDisplaceCenter' : @ ( half_width+--                           * half_height -> Vec ) * rectangle -> Point @+--+runDisplaceCenter :: (Real u, Floating u) +                  => (u -> u -> Vec2 u) -> Rectangle u -> Anchor u+runDisplaceCenter fn (Rectangle { rect_ctm = ctm+                                , rect_hw  = hw+                                , rect_hh  = hh }) = +   projectFromCtr (fn hw hh) ctm -instance (Real u, Floating u) => CenterAnchor (Rectangle u) where-  center = runRectangle (\ _ _ -> ctmCenter) -instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where-  north = runRectangle $ \_  hh -> projectPoint $ P2 0 hh-  south = runRectangle $ \_  hh -> projectPoint $ P2 0 (-hh)-  east  = runRectangle $ \hw _  -> projectPoint $ P2 hw 0-  west  = runRectangle $ \hw _  -> projectPoint $ P2 (-hw) 0+instance (Real u, Floating u) => +    CenterAnchor (Rectangle u) where+  center = runDisplaceCenter $ \_ _ -> V2 0 0 -instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where-  northeast = runRectangle $ \hw hh -> projectPoint $ P2 hw hh-  southeast = runRectangle $ \hw hh -> projectPoint $ P2 hw (-hh)-  southwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) (-hh)-  northwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) hh+instance (Real u, Floating u) => +    TopCornerAnchor (Rectangle u) where+  topLeftCorner  = runDisplaceCenter $ \hw hh -> V2 (-hw) hh+  topRightCorner = runDisplaceCenter $ \hw hh -> V2   hw  hh +instance (Real u, Floating u) => +    BottomCornerAnchor (Rectangle u) where+  bottomLeftCorner  = runDisplaceCenter $ \hw hh -> V2 (-hw) (-hh)+  bottomRightCorner = runDisplaceCenter $ \hw hh -> V2   hw  (-hh) -instance (Real u, Floating u) => RadialAnchor (Rectangle u) where-  radialAnchor theta = runRectangle $ \hw hh -> -    projectPoint $ rectangleIntersect hw hh theta+instance (Real u, Floating u) => +    SideMidpointAnchor (Rectangle u) where+  sideMidpoint n a = step (n `mod` 4) +    where+      step 1 = north a+      step 2 = west a+      step 3 = south a+      step _ = east a --- Note - the answer needs projecting with the CTM...----rectangleIntersect :: (Real u, Floating u) -                   => u -> u -> Radian -> Point2 u-rectangleIntersect hw hh theta = -    maybe zeroPt id $ findIntersect zeroPt theta $ rectangleLines zeroPt hw hh  +instance (Real u, Floating u) => +    CardinalAnchor (Rectangle 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 +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor2 (Rectangle u) where+  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 (Rectangle u) where+  radialAnchor ang = runDisplaceCenter $ \hw hh -> +      maybe zeroVec id $ rectangleRadialIntersect (2*hw) (2*hh) ang+++--------------------------------------------------------------------------------+-- Construction++ -- | 'rectangle'  : @ width * height -> shape @ ---rectangle :: (Real u, Floating u, FromPtSize u) -          => u -> u -> LocShape u (Rectangle u)+rectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => u -> u -> Shape Rectangle u rectangle w h = -    intoLocShape (mkRectangle (0.5*w) (0.5*h))-                 (mkRectPath  (0.5*w) (0.5*h))+    makeShape (mkRectangle (0.5*w) (0.5*h)) (mkRectPath (0.5*w) (0.5*h))  -mkRectangle :: Num u => u -> u -> LocCF u (Rectangle u)-mkRectangle hw hh = promoteR1 $ \ctr -> -    pure $ Rectangle { rect_ctm    = makeShapeCTM ctr+mkRectangle :: InterpretUnit u => u -> u -> LocThetaQuery u (Rectangle u)+mkRectangle hw hh = qpromoteLocTheta $ \ctr theta -> +    pure $ Rectangle { rect_ctm    = makeShapeCTM ctr theta                      , rect_hw     = hw                      , rect_hh     = hh                      } +mkRectPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) +           => u -> u -> LocThetaQuery u (AbsPath u)+mkRectPath hw hh = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rrectangle_trail (2*hw) (2*hh) theta -mkRectPath :: (Real u, Floating u, FromPtSize u) -           => u -> u -> LocCF u (Path u)-mkRectPath hw hh = promoteR1 $ \ctr -> -    let btm_left = displace (-hw) (-hh) ctr-    in roundCornerShapePath $ rectangleCoordPath (2*hw) (2*hh) btm_left-    ++
+ src/Wumpus/Drawing/Shapes/Semicircle.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Shapes.Semicircle+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Semicircle. +-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.Semicircle+  ( ++    Semicircle+  , DSemicircle+  , semicircle++  ) where++import Wumpus.Drawing.Basis.ShapeTrails+import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection+import Wumpus.Drawing.Shapes.Base++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative++++--------------------------------------------------------------------------------+-- Datatype++data Semicircle u = Semicircle +      { sc_ctm          :: ShapeCTM u+      , sc_radius       :: !u +      }++type instance DUnit (Semicircle u) = u++  +type DSemicircle = Semicircle Double+++instance Functor Semicircle where+  fmap f (Semicircle ctm r) = Semicircle (fmap f ctm) (f r)++++-- | Use the formula:+--+-- >   4r+-- >  ---+-- >  3pi+--+-- to get the yminor.+--+++hminor :: Floating u => u -> u+hminor radius = (4 * radius) / (3 * pi)++hmajor :: Floating u => u -> u+hmajor radius = radius - hminor radius+++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semicircle u -> Semicircle u+mapCTM f = (\s i -> s { sc_ctm = f i }) <*> sc_ctm+++instance (Real u, Floating u) => Rotate (Semicircle u) where+  rotate ang            = mapCTM (rotate ang)+              +instance (Real u, Floating u) => RotateAbout (Semicircle u) where+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)++instance Fractional u => Scale (Semicircle u) where+  scale sx sy           = mapCTM (scale sx sy)++instance InterpretUnit u => Translate (Semicircle u) where+  translate dx dy       = mapCTM (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors++-- | 'runDisplaceCenter' : @ ( radius+--                           * height_minor +--                           * height_major -> Vec ) * semicircle -> Point @+--+runDisplaceCenter :: (Real u, Floating u) +                  => (u -> Vec2 u) -> Semicircle u -> Anchor u+runDisplaceCenter fn (Semicircle { sc_ctm       = ctm+                                 , sc_radius    = radius }) = +    projectFromCtr (fn radius) ctm+++instance (Real u, Floating u) => +    CenterAnchor (Semicircle u) where+  center = runDisplaceCenter $ \_ -> V2 0 0++instance (Real u, Floating u) => +    ApexAnchor (Semicircle u) where+  apex = runDisplaceCenter $ \r -> V2 0 (hmajor r)++instance (Real u, Floating u) => +    BottomCornerAnchor (Semicircle u) where+  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 $ \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, +-- radius is the hypotenuese, hminor is the other side.+--+pyth :: Floating u => u -> u -> u+pyth hyp s1 = sqrt $ pow2 hyp - pow2 s1+  where+    pow2 = (^ (2::Int))+++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor2 (Semicircle u) where+  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 (Semicircle u) where+  radialAnchor ang = runDisplaceCenter $ \r ->+      maybe zeroVec id $ semicircleRadialAnchor r ang++++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+    rp = anaTrailPath zeroPt $ semicircle_trail r+++--------------------------------------------------------------------------------+-- Construction++-- | 'semicircle'  : @ radius -> Shape @+--+semicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +           => u -> Shape Semicircle u+semicircle radius = makeShape (mkSemicircle radius) (mkSemicirclePath radius)+          +++mkSemicircle :: InterpretUnit u+             => u -> LocThetaQuery u (Semicircle u)+mkSemicircle radius = qpromoteLocTheta $ \ctr theta -> +    pure $ Semicircle { sc_ctm    = makeShapeCTM ctr theta+                      , sc_radius = radius+                      }++++-- TODO - need to check other shapes to see if the are deriving +-- the center properly...+--+mkSemicirclePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) +                 => u -> LocThetaQuery u (AbsPath u)+mkSemicirclePath radius = qpromoteLocTheta $ \ctr theta ->+    return $ anaTrailPath ctr $ rsemicircle_trail radius theta+
+ src/Wumpus/Drawing/Shapes/Semiellipse.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Shapes.Semiellipse+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Semiellipse.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.Semiellipse+  ( ++    Semiellipse+  , DSemiellipse+  , semiellipse++  ) where++import Wumpus.Drawing.Basis.ShapeTrails+import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection+import Wumpus.Drawing.Shapes.Base++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative++++--------------------------------------------------------------------------------+-- Datatype++data Semiellipse u = Semiellipse +      { se_ctm          :: ShapeCTM u+      , se_rx           :: !u +      , se_ry           :: !u+      }++type instance DUnit (Semiellipse u) = u+++  +type DSemiellipse = Semiellipse Double++instance Functor Semiellipse where+  fmap f (Semiellipse ctm rx ry) = Semiellipse (fmap f ctm) (f rx) (f ry)++++ryminor :: Floating u => u -> u+ryminor ry = (4 * ry) / (3 * pi)++rymajor :: Floating u => u -> u+rymajor ry = ry - ryminor ry+++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semiellipse u -> Semiellipse u+mapCTM f = (\s i -> s { se_ctm = f i }) <*> se_ctm+++instance (Real u, Floating u) => Rotate (Semiellipse u) where+  rotate ang            = mapCTM (rotate ang)+              +instance (Real u, Floating u) => RotateAbout (Semiellipse u) where+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)++instance Fractional u => Scale (Semiellipse u) where+  scale sx sy           = mapCTM (scale sx sy)++instance InterpretUnit u => Translate (Semiellipse u) where+  translate dx dy       = mapCTM (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors+++-- | 'runDisplaceCenter' : @ ( rx+--                           * ry +--                           * ry_minor +--                           * ry_major -> Vec ) * semiellipse -> Point @+--+runDisplaceCenter :: (Real u, Floating 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) ctm+++++instance (Real u, Floating u) => +    CenterAnchor (Semiellipse u) where+  center = runDisplaceCenter $ \_ _ -> V2 0 0++instance (Real u, Floating u, Tolerance u) => +    ApexAnchor (Semiellipse u) where+  apex = runDisplaceCenter $ \_ ry -> V2 0 (rymajor ry)++instance (Real u, Floating u) => +    BottomCornerAnchor (Semiellipse u) where+  bottomLeftCorner  = runDisplaceCenter $ \rx ry -> V2 (-rx) (negate $ ryminor ry)+  bottomRightCorner = runDisplaceCenter $ \rx ry -> V2  rx   (negate $ ryminor ry)+++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor (Semiellipse u) where+  north = apex+  south = runDisplaceCenter $ \_ ry -> V2 0 (negate $ ryminor ry)+  east  = radialAnchor 0+  west  = radialAnchor pi++instance (Real u, Floating u, InterpretUnit u, Tolerance u) => +    CardinalAnchor2 (Semiellipse u) where+  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 (Semiellipse u) where+  radialAnchor ang = runDisplaceCenter $ \rx ry ->+      maybe zeroVec id $ semiellipseRadialAnchor rx ry ang+++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+    rp = anaTrailPath zeroPt $ semiellipse_trail rx ry+++--------------------------------------------------------------------------------+-- Construction+++-- | 'semiellipse'  : @ x_radius * y_radius -> Shape @+--+semiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u) +            => u -> u -> Shape Semiellipse u+semiellipse rx ry = makeShape (mkSemiellipse rx ry) (mkSemiellipsePath rx ry)+          ++++mkSemiellipse :: InterpretUnit u +              => u -> u -> LocThetaQuery u (Semiellipse u)+mkSemiellipse rx ry = qpromoteLocTheta $ \ctr theta -> +    pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta+                       , se_rx = rx+                       , se_ry = ry+                       }+++mkSemiellipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) +                  => u -> u -> LocThetaQuery u (AbsPath u)+mkSemiellipsePath rx ry = qpromoteLocTheta $ \ctr theta ->+    return $ anaTrailPath ctr $ rsemiellipse_trail rx ry theta+
+ src/Wumpus/Drawing/Shapes/Trapezium.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Shapes.Trapezium+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Isoceles Trapezium.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.Trapezium+  ( ++    Trapezium+  , DTrapezium+  , trapezium+++  ) where++import Wumpus.Drawing.Basis.ShapeTrails+import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.Intersection+import Wumpus.Drawing.Shapes.Base++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++++import Control.Applicative+++++--------------------------------------------------------------------------------+-- Trapezium++-- | A trapezium.+--+data Trapezium u = Trapezium +      { 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++type DTrapezium = Trapezium Double++instance Functor Trapezium where+  fmap f (Trapezium ctm bw tw h ang) = +    Trapezium (fmap f ctm) (f bw) (f tw) (f h) ang++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Trapezium u -> Trapezium u+mapCTM f = (\s i -> s { tz_ctm = f i }) <*> tz_ctm+++instance (Real u, Floating u) => Rotate (Trapezium u) where+  rotate ang            = mapCTM (rotate ang)+              +instance (Real u, Floating u) => RotateAbout (Trapezium u) where+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)++instance Fractional u => Scale (Trapezium u) where+  scale sx sy           = mapCTM (scale sx sy)++instance InterpretUnit u => Translate (Trapezium u) where+  translate dx dy       = mapCTM (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors+++-- | 'runDisplaceCenter' : @ ( base_width +--                           * height+--                           * bl_ang -> Vec ) * trapezium -> Point @+--+runDisplaceCenter :: (Real u, Floating u)+                  => (u -> u -> Radian -> Vec2 u) +                  -> Trapezium u -> Anchor u+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++++instance (Real u, Floating u) => +    BottomCornerAnchor (Trapezium u) where+  bottomLeftCorner  = runDisplaceCenterHalves $ \hbw _ hh -> V2 (-hbw) (-hh)+  bottomRightCorner = runDisplaceCenterHalves $ \hbw _ hh -> V2  hbw   (-hh)++++++instance (Real u, Floating u) => +    TopCornerAnchor (Trapezium u) where+  topLeftCorner  = runDisplaceCenterHalves $ \_ htw hh -> V2 (-htw) hh+  topRightCorner = runDisplaceCenterHalves $ \_ htw hh -> V2   htw  hh+++instance (Real u, Floating u, Tolerance u) => +    SideMidpointAnchor (Trapezium u) where+  sideMidpoint n a = step (n `mod` 4) +    where+      step 1 = north a+      step 2 = west a+      step 3 = south a+      step _ = east a++++instance (Real u, Floating u, Tolerance u) => +    CardinalAnchor (Trapezium u) where+  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 = 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 ang = runDisplaceCenter $ \bw h bl_ang -> +      maybe zeroVec id $ trapeziumRadialAnchor bw h bl_ang ang+++-- +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+++-- | 'trapezium'  : @ base_width * height * bottom_left_ang * +--     bottom_right_ang -> Shape @+--+--+trapezium :: (Real u, Floating u, InterpretUnit u, Tolerance u) +          => u -> u -> Radian -> Shape Trapezium u+trapezium bw h base_ang = +    makeShape (mkTrapezium bw h base_ang) (mkTrapeziumPath bw h base_ang)+++++--------------------------------------------------------------------------------+++mkTrapezium :: (Real u, Fractional u, InterpretUnit u) +            => 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 -> Radian -> LocThetaQuery u (AbsPath u)+mkTrapeziumPath bw h bl_ang = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ rtrapezium_trail bw h bl_ang theta++
+ src/Wumpus/Drawing/Shapes/Triangle.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Shapes.Triangle+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Isosceles triangle.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.Triangle+  ( ++    Triangle+  , DTriangle+  , triangle++  ) 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.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative+++++-- Datatype++-- | An isosceles triangle, oriented /upwards/.+--+data Triangle u = Triangle +      { tri_ctm         :: ShapeCTM u+      , tri_base_width  :: !u+      , tri_height      :: !u+      }++type instance DUnit (Triangle u) = u++type DTriangle = Triangle Double++instance Functor Triangle where+  fmap f (Triangle ctm bw h) = Triangle (fmap f ctm) (f bw) (f h)+++hminor :: Fractional u => u -> u +hminor h = h / 3++hmajor :: Fractional u => u -> u +hmajor h = 2 * (h / 3)++++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Triangle u -> Triangle u+mapCTM f = (\s i -> s { tri_ctm = f i }) <*> tri_ctm+++instance (Real u, Floating u) => Rotate (Triangle u) where+  rotate ang            = mapCTM (rotate ang)+              +instance (Real u, Floating u) => RotateAbout (Triangle u) where+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)++instance Fractional u => Scale (Triangle u) where+  scale sx sy           = mapCTM (scale sx sy)++instance InterpretUnit u => Translate (Triangle u) where+  translate dx dy       = mapCTM (translate dx dy)++--------------------------------------------------------------------------------+-- Anchors++-- | 'runDisplaceCenter' : @ ( half_base_width +--                           * height_minor +--                           * height_major +--                           * base_ang -> Vec ) * traingle -> Point @+--+runDisplaceCenter :: (Real u, Floating u)+                  => (u -> u -> Vec2 u) -> Triangle u -> Anchor u+runDisplaceCenter fn (Triangle { tri_ctm        = ctm+                               , tri_base_width = bw +                               , tri_height     = h   }) =  +    projectFromCtr (fn bw h) ctm+++instance (Real u, Floating u) => +    CenterAnchor (Triangle u) where+  center = runDisplaceCenter $ \_ _ -> V2 0 0+++instance (Real u, Floating u) => +    ApexAnchor (Triangle u) where+  apex = runDisplaceCenter $ \_ h -> V2 0 (hmajor h)+++instance (Real u, Floating u) => +    BottomCornerAnchor (Triangle u) where+  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.+--++instance (Real u, Floating u) => +    CardinalAnchor (Triangle u) where+  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) => +    SideMidpointAnchor (Triangle u) where+  sideMidpoint n a = step (n `mod` 3) +    where+      step 1 = midpoint (apex a)              (bottomLeftCorner a)+      step 2 = midpoint (bottomLeftCorner a)  (bottomRightCorner a)+      step _ = midpoint (bottomRightCorner a) (apex a)+++findEast :: (Real u, Fractional u) => u -> u -> Vec2 u+findEast bw h = V2 xdist 0+  where+    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 :: (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, InterpretUnit u, Tolerance u) => +    CardinalAnchor2 (Triangle u) where+  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 (Triangle u) where+  radialAnchor ang = runDisplaceCenter $ \bw h -> +      maybe zeroVec id $ isoscelesTriangleRadialIntersect bw h ang+++++    +--------------------------------------------------------------------------------+-- Construction++-- | 'triangle'  : @ base_width * height -> Shape @+--+--+triangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) +         => u -> u -> Shape Triangle u+triangle bw h = makeShape (mkTriangle bw h) (mkTrianglePath bw h)++++++mkTriangle :: (Real u, Fractional u, InterpretUnit u) +           => u -> u -> LocThetaQuery u (Triangle u)+mkTriangle bw h = qpromoteLocTheta $ \ctrd theta -> +    pure $ Triangle { tri_ctm        = makeShapeCTM ctrd theta+                    , tri_base_width = bw+                    , tri_height     = h +                    }++++++mkTrianglePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) +               => u -> u -> LocThetaQuery u (AbsPath u)+mkTrianglePath bw h = qpromoteLocTheta $ \ctr theta -> +    return $ anaTrailPath ctr $ risosceles_triangle_trail bw h theta+
+ src/Wumpus/Drawing/Text/Base/DocTextZero.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Text.Base.DocTextZero+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Flexible text type, composable with @pretty-print@ style +-- operators.+-- +-- Direction zero (left-to-right) only.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Text.Base.DocTextZero+  ( ++    GenDoc+  , Doc +  , GenDocGraphic+  , DocGraphic+  , runGenDoc++  , (<+>)+  , blank+  , space+  , string+  , escaped+  , embedPosObject+  +  , bold+  , italic+  , boldItalic++  , monospace+  , int +  , integer+  , float+  , ffloat++  , strikethrough+  , underline+  , highlight++  ) where+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import Data.Monoid+import Numeric++--+-- Design Issue:+--+-- Can user state be added to Doc?+--+-- Easy if PosObject had user state, difficult as it doesn\'t...+--+ +-- | Doc type.+--+newtype 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 a) = st++type GenDocGraphic st u = GenDoc st u (UNil u)++type Doc u a = GenDoc () u a++type DocGraphic u = Doc u (UNil u)+++data DocEnv = DocEnv +      { doc_alignment   :: VAlign+      , doc_font_family :: FontFamily+      }++instance Functor (GenDoc st u) where+  fmap f ma = GenDoc $ \env -> fmap f $ getGenDoc ma env++instance Applicative (GenDoc st u) where+  pure a    = GenDoc $ \_   -> pure a+  mf <*> ma = GenDoc $ \env -> getGenDoc mf env <*> getGenDoc ma env+++instance Monad (GenDoc st u) where+  return a  = GenDoc $ \_   -> return a+  ma >>= k  = GenDoc $ \env -> getGenDoc ma env >>= \a -> getGenDoc (k a) env++instance (Monoid a, InterpretUnit u) => Monoid (GenDoc st u a) where+  mempty          = GenDoc $ \_   -> mempty+  ma `mappend` mb = GenDoc $ \env -> getGenDoc ma env `hconcat` getGenDoc mb env+++instance DrawingCtxM (GenDoc st u) where+  askDC           = GenDoc $ \_   -> askDC +  asksDC fn       = GenDoc $ \_   -> asksDC fn+  localize upd ma = GenDoc $ \env -> localize upd (getGenDoc ma env)+++instance UserStateM (GenDoc st u) where+  getState        = GenDoc $ \_ -> getState+  setState s      = GenDoc $ \_ -> setState s+  updateState upd = GenDoc $ \_ -> updateState upd+++runGenDoc :: VAlign -> FontFamily -> GenDoc st u a -> GenPosObject st u a+runGenDoc va ff ma = getGenDoc ma env1 +  where+    env1 = DocEnv { doc_alignment = va, doc_font_family = ff }++++--------------------------------------------------------------------------------+-- Get vcat vconcat... from the Concat class++instance (Monoid a, Fractional u, InterpretUnit u) => +    Concat (GenDoc st u a) where+  hconcat = mappend+  vconcat = vcatImpl++vcatImpl        :: (Monoid a, Fractional u, InterpretUnit u) +                => GenDoc st u a -> GenDoc st u a -> GenDoc st u a+vcatImpl ma mb  = GenDoc $ \env -> +    let va = doc_alignment env +    in textlineSpace >>= \sep -> +       valignSpace va sep (getGenDoc ma env) (getGenDoc mb env)++--------------------------------------------------------------------------------+-- Primitives++infixr 6 <+>++-- | Concatenate two Docs separated with a space.+--+-- (infixr 6)+--+(<+>) :: InterpretUnit u +      => GenDocGraphic st u -> GenDocGraphic st u -> GenDocGraphic st u+a <+> b = a `mappend` space `mappend` b ++++blank     :: InterpretUnit u => GenDocGraphic st u+blank     = GenDoc $ \_ -> posTextPrim (Left "")++space     :: InterpretUnit u => GenDocGraphic st u+space     = GenDoc $ \_ -> posCharPrim (Left ' ')+++string    :: InterpretUnit u => String -> GenDocGraphic st u+string ss = GenDoc $ \_ -> posTextPrim (Left ss)++++escaped     :: InterpretUnit u => EscapedText -> GenDocGraphic st u+escaped esc = GenDoc $ \_ -> posTextPrim (Right esc)++embedPosObject :: GenPosObject st u a -> GenDoc st u a+embedPosObject ma = GenDoc $ \_ -> ma++++--------------------------------------------------------------------------------+-- Change font weight++bold :: GenDoc st u a -> GenDoc st u a +bold ma = GenDoc $ \env -> +    localize (set_font $ boldWeight $ doc_font_family env)+             (getGenDoc ma env)+++italic :: GenDoc st u a -> GenDoc st u a +italic ma = GenDoc $ \env -> +    localize (set_font $ italicWeight $ doc_font_family env)+             (getGenDoc ma env)+++boldItalic :: GenDoc st u a -> GenDoc st u a +boldItalic ma = GenDoc $ \env -> +    localize (set_font $ boldItalicWeight $ doc_font_family env)+             (getGenDoc ma env)+++--------------------------------------------------------------------------------+-- Monospace++monospace :: InterpretUnit u +          => EscapedChar -> EscapedText -> GenDocGraphic st u+monospace ref_ch esc = GenDoc $ \_ -> +    monospaceEscText (vector_x <$> escCharVector ref_ch) esc+++++int :: InterpretUnit u => Int -> GenDocGraphic st u+int i = integer $ fromIntegral i+++integer :: InterpretUnit u => Integer -> GenDocGraphic st u+integer i = monospace (CharLiteral '0') (escapeString $ show i)++++--------------------------------------------------------------------------------+++-- | Specialized version of 'ffloat' - the answer is always +-- rendered at \"full precision\".+--+float :: (RealFloat a, InterpretUnit u) => a -> GenDocGraphic st u+float = ffloat Nothing+++-- | This is equivalent to 'showFFloat' in the Numeric module.+-- +-- Like 'showFFloat', the answer is rendered to supplied +-- precision. @Nothing@ indicated full precision.+--+ffloat :: (RealFloat a, InterpretUnit u) +       => (Maybe Int) -> a -> GenDocGraphic st u+ffloat mb d = +    monospace (CharLiteral '0') $ escapeString  $ ($ "") $ showFFloat mb d+++++++--------------------------------------------------------------------------------+-- Decorate++strikethrough :: (Fractional u, InterpretUnit u) +              => GenDoc st u a -> GenDoc st u a+strikethrough = decorateDoc ZABOVE drawStrikethrough ++underline :: (Fractional u, InterpretUnit u) +          => GenDoc st u a -> GenDoc st u a+underline = decorateDoc ZABOVE drawUnderline++highlight :: (Fractional u, InterpretUnit u) +          => RGBi -> GenDoc st u a -> GenDoc st u a+highlight rgb = decorateDoc ZBELOW (drawBackfill rgb) + +++decorateDoc :: InterpretUnit u +            => 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+++           ++-- API might be simple if we conditionally apply strikethrough on +-- interpText (possibly including spaces), but never on interpSpace.+--+-- Might want to derive stroke_colour from text_colour and linewidth+-- fromf font size as well...+--+drawStrikethrough :: (Fractional u, InterpretUnit u) +                  => Orientation u -> LocGraphic u+drawStrikethrough (Orientation xmin xmaj _ ymaj) = +    linestyle $ moveStart (vec (-xmin) vpos) ln+  where+    vpos  = 0.45 * ymaj+    ln    = locStraightLine (hvec $ xmin + xmaj)++++drawUnderline :: (Fractional u, InterpretUnit u) +              => Orientation u -> LocGraphic u+drawUnderline (Orientation xmin xmaj _ _) = +    underlinePosition >>= \vpos ->+    linestyle $ moveStart (vec (-xmin) vpos) ln+  where+    ln    = locStraightLine (hvec $ xmin + xmaj)+++-- | This uses underline_thickness ...+--+linestyle :: LocGraphic u -> LocGraphic u+linestyle mf = +    underlineThickness >>= \sz -> +    localize (stroke_use_text_colour . set_line_width sz) mf+++-- | Note - quarter margin looks good.+--+drawBackfill :: (Fractional u, InterpretUnit u) +             => RGBi -> Orientation u -> LocGraphic u+drawBackfill rgb (Orientation xmin xmaj ymin ymaj) = +    textMargin >>= \(dx,dy) -> +    let hdx = 0.25 * dx+        hdy = 0.25 * dy +    in localize (fill_colour rgb) $ moveStart (mkVec hdx hdy) (mkRect hdx hdy)+  where+    mkVec  dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy)+    mkRect dx dy = let w = dx + xmin + xmaj + dx+                       h = dy + ymin + ymaj + dy+                   in dcRectangle DRAW_FILL w h+
+ src/Wumpus/Drawing/Text/Base/Label.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Text.Base.Label+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Annotation labels.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Text.Base.Label+  ( ++    locImageLabel++  , label_center_of+  , label_left_of+  , label_right_of+  , label_above+  , label_below++  , connectorPathLabel+  , label_midway_of+  , label_atstart_of+  , label_atend_of++  , centerRelative+  , right_of+  , left_of+  , above_right_of+  , below_right_of+  , above_left_of+  , below_left_of++  ) where+++import Wumpus.Drawing.Paths++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+++type BoundedLocRectGraphic u = RectAddress -> LocImage u (BoundingBox u)+++locImageLabel :: InterpretUnit u +              => (a -> Anchor u) +              -> RectAddress +              -> (RectAddress -> LocImage u (BoundingBox u)) +              -> LocImage u a +              -> LocImage u a+locImageLabel fn rpos mklabel obj = promoteLoc $ \pt -> +    elaborateAbove (obj `at` pt)  (\a -> ignoreAns $ mklabel rpos `at` fn a)++++label_center_of :: (InterpretUnit u, CenterAnchor a, u ~ DUnit a) +                => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a+label_center_of = locImageLabel center CENTER+++label_left_of :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) +              => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a+label_left_of = locImageLabel west EE++label_right_of :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) +               => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a+label_right_of = locImageLabel east WW+++label_above :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) +            => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a+label_above = locImageLabel north SS+++label_below :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) +            => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a+label_below = locImageLabel south NN+++++connectorPathLabel :: InterpretUnit u +                   => (AbsPath u -> Point2 u) +                   -> RectAddress+                   -> BoundedLocRectGraphic u+                   -> Image u (AbsPath u) +                   -> Image u (AbsPath u)+connectorPathLabel fn rpos lbl img =  +    elaborateAbove img  (\a -> ignoreAns $ lbl rpos `at` (fn a))+++label_midway_of :: (Real u, Floating u, InterpretUnit u) +                => RectAddress +                -> BoundedLocRectGraphic u +                -> Image u (AbsPath u) -> Image u (AbsPath u)+label_midway_of = connectorPathLabel midway_+++label_atstart_of :: (Real u, Floating u, InterpretUnit u) +                 => RectAddress +                 -> BoundedLocRectGraphic u +                 -> Image u (AbsPath u) -> Image u (AbsPath u)+label_atstart_of = connectorPathLabel atstart_+++label_atend_of :: (Real u, Floating u, InterpretUnit u) +               => RectAddress +               -> BoundedLocRectGraphic u+               -> Image u (AbsPath u) -> Image u (AbsPath u)+label_atend_of = connectorPathLabel atend_+++++-- | Absolute units.+-- +centerRelative :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) +               => (Int,Int) -> a -> Query u (Anchor u)+centerRelative coord a = +    snapmove coord >>= \v -> return $ displace v (center a)++-- TODO - These are really for Anchors.+--+-- Should the have a separate module or be rolled into the same+-- module as the classes?+--++-- | Value is 1 snap unit right.+--+-- This function should be considered obsolete, pending a +-- re-think.+-- +right_of        :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) +                => a -> Query u (Anchor u)+right_of        = centerRelative (1,0)++-- | Value is 1 snap move left.+--+-- This function should be considered obsolete, pending a +-- re-think.+-- +left_of         :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) +                => a -> Query u (Anchor u)+left_of         = centerRelative ((-1),0)++-- | Value is 1 snap move up, 1 snap move right.+--+-- This function should be considered obsolete, pending a +-- re-think.+-- +above_right_of  :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) +                => a -> Query u (Anchor u)+above_right_of  = centerRelative (1,1)++-- | Value is 1 snap move below, 1 snap move right.+--+-- This function should be considered obsolete, pending a +-- re-think.+-- +below_right_of  :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) +                => a -> Query u (Anchor u)+below_right_of  = centerRelative (1, (-1))++-- | Value is 1 snap move up, 1 snap move left.+--+-- This function should be considered obsolete, pending a +-- re-think.+-- +above_left_of   :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) +                => a -> Query u (Anchor u)+above_left_of   = centerRelative ((-1),1)++-- | Value is 1 snap move down, 1 snap move left.+--+-- This function should be considered obsolete, pending a +-- re-think.+-- +below_left_of   :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) +                => a -> Query u (Anchor u)+below_left_of   = centerRelative ((-1),(-1))+ ++++-- TikZ has label=below etc.+-- +-- This would probably translate to a functions:+-- @labelBelow@+--+++-- Design note - there aren\'t many Images that support anchors,+-- except for LocImages that have been /saturated/ (i.e. applied +-- to a point with @at@).+-- +-- For a saturated Image, getting at the anchors via bind does +-- not seem so bad (indeed, this was the original point of +-- anchors). Obviously it is important to add labels to LocImages+-- (the original point of the label functions) but what about +-- LocThetaImages and LocRectImages. Is it acceptable to /saturate/+-- them to LocImages before labelling them?+-- +-- Connectors support different /anchor-like/ positions so they +-- will different labelling functions.+-- +  +
+ src/Wumpus/Drawing/Text/DirectionZero.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.DirectionZero+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Common import module for the Writing Direction 0 modules+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Text.DirectionZero+  ( +    module Wumpus.Drawing.Text.Base.DocTextZero++  , textline+  , rtextline+  , multilineText++  ) where++import Wumpus.Drawing.Text.Base.DocTextZero++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core++-- | Note - this is likely to be moved...+-- +-- Also, reversed argument order would be more convenient as +-- RectAddress always short but String could be long. +--+textline :: InterpretUnit u => RectAddress -> String -> BoundedLocGraphic u+textline addr ss = runPosObjectBBox addr (posText ss)+++-- | Note - this is likely to be moved too...+--+rtextline :: (Real u, Floating u, InterpretUnit u)+          => Radian -> RectAddress -> String -> BoundedLocGraphic u+rtextline ang addr ss = runPosObjectBBox addr (rposText ang ss)+++multilineText :: (Fractional u, InterpretUnit u)+              => VAlign -> RectAddress -> String -> BoundedLocGraphic u+multilineText va addr ss = runPosObjectBBox addr (multilinePosText va ss)++
+ src/Wumpus/Drawing/Text/DocSymbols.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Text.DocSymbols+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Symbols - redefined Basis.Symbols.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Text.DocSymbols+  (++    ocircle+  , small_ocircle++  , empty_box++  , left_slice+  , right_slice++  )+  where++import qualified Wumpus.Drawing.Basis.Symbols as S+import Wumpus.Drawing.Text.Base.DocTextZero+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++-- import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+++ocircle :: (Fractional u, InterpretUnit u) => GenDocGraphic st u+ocircle = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hh = 0.5 * h in Orientation hh hh 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.5 * h) (S.scircle $ 0.5 * h)++++small_ocircle :: (Fractional u, InterpretUnit u) => GenDocGraphic st u+small_ocircle = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hw = 0.33 * h in Orientation hw hw 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.scircle $ 0.25 * h)++empty_box :: (Fractional u, InterpretUnit u) => GenDocGraphic st u+empty_box = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hw = 0.5 * h in Orientation hw hw 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.empty_box $ 0.66 * h)++++left_slice :: (Real u, Floating u, InterpretUnit u) => GenDocGraphic st u+left_slice = embedPosObject $ makePosObject qy gf+  where+    qy = (\h -> let hw = 0.66 * h in Orientation hw hw 0 h) <$> capHeight+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.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.sright_slice h)++-- More to follow...+
− src/Wumpus/Drawing/Text/LRText.hs 
@@ -1,409 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Text.LRText--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Left-to-right measured text. The text uses glyph metrics so it --- can be positioned accurately.--- --- \*\* WARNING \*\* - the API for this module needs work. The --- current API is not satisfactory for drawing according to a --- start position (there are other reasonable start positions than --- the ones currently supported - adding them would explode the --- number of definitions).--- -----------------------------------------------------------------------------------module Wumpus.Drawing.Text.LRText-  ( --    baseCenterLine-  , baseLeftLine-  , baseRightLine--  , rbaseCenterLine-  , rbaseLeftLine-  , rbaseRightLine--  , ctrCenterLine-  , baseCenterEscChar--  , multiAlignLeft-  , multiAlignCenter-  , multiAlignRight--  , rmultiAlignLeft-  , rmultiAlignCenter-  , rmultiAlignRight- --  ) where---import Wumpus.Basic.Kernel--import Wumpus.Core                              -- package: wumpus-core-import Wumpus.Core.Text.GlyphIndices--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace--import Control.Applicative-import Data.Char-import qualified Data.Map               as Map-import Data.Maybe ----- Note - BoundedLocThetaGraphic is probably an adequate type--- even though the same text will have a different bounding box--- if it is rotated (the sides of the BBox are always parallel to --- the x and y axes even if the text is not parrale to the --- x-axis). --- --- I cannot think of any compelling graphics that need a more --- accurate type. The execption is text cannot have exact anchors --- however this is a moot /if/ text is considered as a labelling --- of an existing rectangle (which may or may not have been --- rotated).--------- One line of multiline text----data OnelineText u = OnelineText EscapedText (AdvanceVec u)----- | max_width * oneline_text -> LocThetaGraphic----type LocThetaDrawOneline u = u -> OnelineText u -> LocThetaGraphic u----- | max_width * oneline_text -> LocThetaGraphic----type BoundedLocThetaOneline u = u -> OnelineText u -> BoundedLocThetaGraphic u----- | Draw one line of left-aligned text, knowing the max_width --- of all the lines of text.------ All left-aligned text is moved left by half the max_width.------ Note - implicit point is baseline-center, this is perhaps --- unintituitive given the functions name but it is an --- advantage for drawing multi-line text.--- -drawLeftAligned :: Floating u => LocThetaDrawOneline u-drawLeftAligned max_width (OnelineText esc _) = -    promoteR2 $ \baseline_ctr theta -> -       let mv = displaceParallel ((-0.5) * max_width) theta-       in apply2R2 (rescapedline esc) (mv baseline_ctr) theta-       ----- | Draw one line of center-aligned text. Center aligned text is --- oblivious to the max_width of all the lines of text.------ Each line of center-aligned text is moved left by half its --- advance vector.------ Implicit point is baseline-center.----drawCenterAligned :: Floating u => LocThetaDrawOneline u-drawCenterAligned _ (OnelineText esc av) = -    promoteR2 $ \baseline_ctr theta -> -       let mv = displaceParallel (negate $ 0.5 * advanceH av) theta-       in apply2R2 (rescapedline esc) (mv baseline_ctr) theta-       ---- | Draw one line of right-aligned text, knowing the max_width --- of all the lines of text.------ Each right-aligned text line is moved by the width component --- of the advance vector minus half the max width.------ Note - implicit point is baseline-center, this is perhaps --- unintituitive given the functions name but it is an --- advantage for drawing multi-line text.--- -drawRightAligned :: Floating u => LocThetaDrawOneline u-drawRightAligned max_width (OnelineText esc av) = -    promoteR2 $ \baseline_ctr theta -> -      let mv = displaceParallel ((0.5 * max_width) - advanceH av) theta-      in apply2R2 (rescapedline esc) (mv baseline_ctr) theta------- Impilict point is baseline-center.----onelineBBox :: (Real u, Floating u, FromPtSize u) -            => OnelineText u -> LocThetaDrawingInfo u (BoundingBox u)-onelineBBox (OnelineText _ av) = -    promoteR2 $ \baseline_ctr theta -> -      glyphHeightRange >>= \(ymin, ymax) ->-      getTextMargin    >>= \(xsep, ysep) -> -        let hw        = 0.5 * advanceH av -            btm_left  = baseline_ctr .+^ vec (-hw) ymin-            top_right = baseline_ctr .+^ vec hw    ymax-            bbox      = expandBB xsep ysep (BBox btm_left top_right)-        in pure $ centerOrthoBBox theta bbox-  where-    expandBB xsep ysep (BBox (P2 x0 y0) (P2 x1 y1)) = -        BBox (P2 (x0-xsep) (y0-ysep)) (P2 (x1+xsep) (y1+ysep))-    --------- This should have max_width as a param...----makeMoveableLine :: (Real u, Floating u, FromPtSize u) -                 => LocThetaDrawOneline u -                 -> BoundedLocThetaOneline u-makeMoveableLine drawF max_width oline =-      intoLocThetaImage (onelineBBox oline) (drawF max_width oline)--onelineAlg :: (Real u, Floating u, FromPtSize u) -           => DisplaceFun u -           -> LocThetaDrawOneline u -           -> EscapedText-           -> BoundedLocThetaGraphic u-onelineAlg ptMoveF drawF esc = -   promoteR2 $ \pt theta -> -     onelineEscText esc >>= \ans@(OnelineText _ av) ->-       let max_width = advanceH av-           move      = ptMoveF max_width ans theta -       in apply2R2 (makeMoveableLine drawF max_width ans) (move pt) theta-------- | Draw 1 line...------ Impilict point is baseline-left.-----baseLeftLine :: (Real u, Floating u, FromPtSize u) -              => String -> BoundedLocGraphic u-baseLeftLine ss = rbaseLeftLine ss `rot` 0------ | Draw 1 line...------ Impilict point is baseline-center.----baseCenterLine :: (Real u, Floating u, FromPtSize u) -               => String -> BoundedLocGraphic u-baseCenterLine ss = rbaseCenterLine ss `rot` 0------- | Draw 1 line...------ Impilict point is baseline-right.----baseRightLine :: (Real u, Floating u, FromPtSize u) -              => String -> BoundedLocGraphic u-baseRightLine ss = rbaseRightLine ss `rot` 0----rbaseLeftLine :: (Real u, Floating u, FromPtSize u) -              => String -> BoundedLocThetaGraphic u-rbaseLeftLine ss = -    onelineAlg leftToCenter drawLeftAligned (escapeString ss)---rbaseCenterLine :: (Real u, Floating u, FromPtSize u) -                => String -> BoundedLocThetaGraphic u-rbaseCenterLine ss = -    onelineAlg centerToCenter drawCenterAligned (escapeString ss)---rbaseRightLine :: (Real u, Floating u, FromPtSize u) -              => String -> BoundedLocThetaGraphic u-rbaseRightLine ss = -    onelineAlg rightToCenter drawRightAligned (escapeString ss)----- Note - assumes the ymin of the font is 0 or less.----ctrCenterLine :: (Real u, Floating u, FromPtSize u) -              => String -> BoundedLocGraphic u-ctrCenterLine ss =-    glyphHeightRange >>= \(ymin, ymax) -> -      let hh = 0.5 * ymax - ymin in -        moveStartPoint (displaceV $ negate $ hh - abs ymin) $ baseCenterLine ss----baseCenterEscChar :: (Real u, Floating u, FromPtSize u) -                  => EscapedChar -> BoundedLocGraphic u-baseCenterEscChar esc = body `rot` 0-  where-    body = onelineAlg centerToCenter drawCenterAligned (wrapEscChar esc)--------- | max_width * interim_text * theta -> (Point -> Point)----type DisplaceFun u = u -> OnelineText u -> Radian -> PointDisplace u--centerToCenter :: DisplaceFun u-centerToCenter _ _ _ = id--leftToCenter :: Floating u => DisplaceFun u-leftToCenter max_width _ theta =-    displaceParallel (0.5 * max_width) theta--rightToCenter :: Floating u => DisplaceFun u-rightToCenter max_width (OnelineText _ av) theta =-    displaceParallel ((0.5 * max_width) - advanceH av) theta-----multiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u)-               => String-               -> BoundedLocGraphic u-multiAlignLeft ss = rmultiAlignLeft ss `rot` 0---multiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u)-                 => String-                 -> BoundedLocGraphic u-multiAlignCenter ss = rmultiAlignCenter ss `rot` 0-----multiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u)-                => String-                -> BoundedLocGraphic u-multiAlignRight ss = rmultiAlignRight ss `rot` 0---rmultiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u)-               => String-               -> BoundedLocThetaGraphic u-rmultiAlignLeft = multilineTEXT (makeMoveableLine drawLeftAligned)---rmultiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u)-                  => String-                  -> BoundedLocThetaGraphic u-rmultiAlignCenter = multilineTEXT (makeMoveableLine drawCenterAligned)---rmultiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u)-                 => String-                 -> BoundedLocThetaGraphic u-rmultiAlignRight = multilineTEXT (makeMoveableLine drawRightAligned)----multilineTEXT :: (Floating u, Ord u, FromPtSize u)-              => BoundedLocThetaOneline u-              -> String-              -> BoundedLocThetaGraphic u-multilineTEXT _  [] = lift1R2 emptyBoundedLocGraphic-multilineTEXT mf ss = -    lift0R2 (linesToInterims ss) >>= \(max_av, itexts) -> -      centralPoints (length itexts) >>= \pts -> -        zipMultis (advanceH max_av) mf itexts pts---      --zipMultis :: (Ord u, FromPtSize u)-          => u-          -> BoundedLocThetaOneline u-          -> [OnelineText u] -> [Point2 u]-          -> BoundedLocThetaGraphic u-zipMultis _     _  []     _       = lift1R2 $ emptyBoundedLocGraphic-zipMultis _     _  _      []      = lift1R2 $ emptyBoundedLocGraphic-zipMultis max_w mf (a:as) (b:bs) = step a b as bs-  where-    mkGraphic itext pt        = promoteR2 $ \_ theta -> -                                  apply2R2 (mf max_w itext) pt theta-    step r s (r2:rs) (s2:ss)  = liftA2 oplus (mkGraphic r s) (step r2 s2 rs ss)-    step r s _       _        = mkGraphic r s------- | @ana@ is an /anacrusis/ factor - if there are even points--- half the baseline_spacing is added to get the top point----centralPoints :: Floating u => Int -> LocThetaDrawingInfo u [Point2 u]-centralPoints n | n < 2     = promoteR2 $ \ctr _  -> return [ctr]-                | even n    = body (n `div` 2) (0.5*)-                | otherwise = body (n `div` 2) (0 *) -  where-    body halfn ana  = promoteR2 $ \ctr theta -> -                        baselineSpacing >>= \h ->-                          let y0  = (h * fromIntegral halfn) + ana h-                              top = displacePerpendicular y0 theta ctr-                          in pure $ trailPoints n h theta top-        ---trailPoints :: Floating u => Int -> u -> Radian -> Point2 u -> [Point2 u]-trailPoints n height theta top = take n $ iterate fn top-  where-    fn pt = displacePerpendicular (-height) theta pt---------------------------------------------------------------------------------------- This isn't worth the complexity to get down to one traversal...--linesToInterims :: (FromPtSize u, Ord u) -                => String -> DrawingInfo (AdvanceVec u, [OnelineText u])-linesToInterims = fmap post . mapM (onelineEscText . escapeString) . lines-  where-    post xs                    = let vmax = foldr fn (hvec 0) xs in (vmax,xs)-    fn (OnelineText _ av) vmax = avMaxWidth av vmax--avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u-avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a--onelineEscText :: FromPtSize u => EscapedText -> DrawingInfo (OnelineText u)-onelineEscText esc = fmap (OnelineText esc) $ textVector esc----textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u)-textVector esc = -    cwLookupTable >>= \table -> -       let cs = destrEscapedText id esc -       in pure $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs-     -   ---charWidth :: FromPtSize u -          => CharWidthTable u -> EscapedChar -> AdvanceVec u-charWidth fn (CharLiteral c) = fn $ ord c-charWidth fn (CharEscInt i)  = fn i-charWidth fn (CharEscName s) = fn ix-  where-    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices
− src/Wumpus/Drawing/Text/SafeFonts.hs 
@@ -1,167 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Text.SafeFonts--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Safe to use \"Core 13\" fonts that are expected to be present--- for any PostScript interpreter.------ Note - regrettably Symbol is not safe to use for SVG.------ \*\* WARNING \*\* - this module is in flux due to changes to --- Text encoding in Wumpus-Core and adding font metrics to --- Wumpus-Basic. The code here is likely to be revised.--------------------------------------------------------------------------------------module Wumpus.Drawing.Text.SafeFonts-  ( -  -- * Times Roman-    times_roman-  , times_italic-  , times_bold-  , times_bold_italic--  -- * Helvetica-  , helvetica-  , helvetica_oblique-  , helvetica_bold-  , helvetica_bold_oblique--  -- * Courier-  , courier-  , courier_oblique-  , courier_bold-  , courier_bold_oblique--  -- * Symbol-  , symbol--  ) where----import Wumpus.Core-import Wumpus.Core.Text.StandardEncoding-import Wumpus.Core.Text.Symbol---- Supported fonts are:------ Times-Roman  Times-Italic       Times-Bold      Times-BoldItalic--- Helvetica    Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique--- Courier      Courier-Oblique    Courier-Bold    Courier-Bold-Oblique--- Symbol------------------------------------------------------------------------------------- ---- | Times-Roman--- -times_roman :: FontFace-times_roman = -    FontFace "Times-Roman" "Times New Roman" SVG_REGULAR standard_encoding---- | Times Italic----times_italic :: FontFace-times_italic = -    FontFace "Times-Italic" "Times New Roman" SVG_ITALIC standard_encoding-                       --- | Times Bold----times_bold :: FontFace-times_bold = -    FontFace "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding---- | Times Bold Italic----times_bold_italic :: FontFace-times_bold_italic = FontFace "Times-BoldItalic" -                             "Times New Roman" -                             SVG_BOLD_ITALIC -                             standard_encoding-------------------------------------------------------------------------------------- Helvetica---- | Helvetica ----helvetica :: FontFace-helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding----- | Helvetica Oblique----helvetica_oblique :: FontFace-helvetica_oblique = -    FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding---- | Helvetica Bold--- -helvetica_bold :: FontFace-helvetica_bold = -    FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding----- | Helvetica Bold Oblique----helvetica_bold_oblique :: FontFace-helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" -                                  "Helvetica" -                                  SVG_BOLD_OBLIQUE -                                  standard_encoding---------------------------------------------------------------------------------------- | Courier--- -courier :: FontFace-courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding---- | Courier Oblique--- -courier_oblique :: FontFace-courier_oblique = -    FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding---- | Courier Bold--- -courier_bold :: FontFace-courier_bold = -    FontFace "Courier-Bold" "Courier New" SVG_BOLD standard_encoding----- | Courier Bold Oblique--- -courier_bold_oblique :: FontFace-courier_bold_oblique = FontFace "Courier-Bold-Oblique" -                                "Courier New" -                                SVG_BOLD_OBLIQUE -                                standard_encoding------------------------------------------------------------------------------------- Symbol---- | Symbol------ Note - Symbol is intentionally not supported for SVG by some --- renderers (Firefox). Chrome is fine, but the use of symbol --- should be still be avoided for web graphics.--- -symbol :: FontFace-symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_encoding-----
+ src/Wumpus/Drawing/Text/StandardFontDefs.hs view
@@ -0,0 +1,323 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Text.StandardFontDefs+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Safe to use \"Core 13\" fonts that are expected to be present+-- for any PostScript interpreter.+--+-- Note - regrettably Symbol is not safe to use for SVG.+--+--------------------------------------------------------------------------------++module Wumpus.Drawing.Text.StandardFontDefs+  ( +  -- * Times Roman+    times_roman_family+  +  , times_roman+  , times_italic+  , times_bold+  , times_bold_italic++  -- * Helvetica+  , helvetica_family++  , helvetica+  , helvetica_oblique+  , helvetica_bold+  , helvetica_bold_oblique++  -- * Courier+  , courier_family++  , courier+  , courier_oblique+  , courier_bold+  , courier_bold_oblique++  -- * Symbol+  , symbol++  ) where+++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Text.StandardEncoding+import Wumpus.Core.Text.Symbol++-- Supported fonts are:+--+-- Times-Roman  Times-Italic       Times-Bold      Times-BoldItalic+-- Helvetica    Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique+-- Courier      Courier-Oblique    Courier-Bold    Courier-Bold-Oblique+-- Symbol++--------------------------------------------------------------------------------+-- ++-- | 'FontFamily' definition for Times-Roman.+--+times_roman_family :: FontFamily+times_roman_family = +    FontFamily { ff_regular     = times_roman+               , ff_bold        = Just times_bold+               , ff_italic      = Just times_italic+               , ff_bold_italic = Just times_bold_italic+               }+++-- | Times-Roman+-- +times_roman :: FontDef+times_roman = +    FontDef { font_def_face   = face+            , gs_file_name    = "n021003l.afm"          -- NimbusRomNo9L-Regu+            , afm_file_name   = "Times-Roman.afm"+            }+  where+    face = FontFace { ps_font_name      = "Times-Roman" +                    , svg_font_family   = "Times New Roman" +                    , svg_font_style    = SVG_REGULAR +                    , font_enc_vector   = standard_encoding+                    }+++-- | Times Italic+--+times_italic :: FontDef+times_italic =+    FontDef { font_def_face   = face+            , gs_file_name    = "n021023l.afm"        -- NimbusRomNo9L-ReguItal+            , afm_file_name   = "Times-Italic.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Times-Italic"+                     , svg_font_family  = "Times New Roman"+                     , svg_font_style   = SVG_ITALIC+                     , font_enc_vector  = standard_encoding+                     }+++-- | Times Bold+--+times_bold :: FontDef+times_bold = +    FontDef { font_def_face   = face+            , gs_file_name    = "n021004l.afm"          -- NimbusRomNo9L-Medi+            , afm_file_name   = "Times-Bold.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Times-Bold"+                     , svg_font_family  = "Times New Roman"+                     , svg_font_style   = SVG_BOLD+                     , font_enc_vector  = standard_encoding+                     }+++-- | Times Bold Italic+--+times_bold_italic :: FontDef+times_bold_italic = +    FontDef { font_def_face   = face+            , gs_file_name    = "n021024l.afm"          -- NimbusRomNo9L-MediItal+            , afm_file_name   = "Times-BoldItalic.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Times-BoldItalic"+                     , svg_font_family  = "Times New Roman"+                     , svg_font_style   = SVG_BOLD_ITALIC+                     , font_enc_vector  = standard_encoding+                     }+++--------------------------------------------------------------------------------+-- Helvetica++-- | 'FontFamily' definition for Helvetica.+--+helvetica_family :: FontFamily+helvetica_family = +    FontFamily { ff_regular     = helvetica+               , ff_bold        = Just helvetica_bold+               , ff_italic      = Just helvetica_oblique+               , ff_bold_italic = Just helvetica_bold_oblique+               }++++-- | Helvetica regular weight.+--+helvetica :: FontDef+helvetica =+    FontDef { font_def_face   = face+            , gs_file_name    = "n019003l.afm"          -- NimbusSanL-Regu+            , afm_file_name   = "Helvetica.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Helvetica"+                     , svg_font_family  = "Helvetica"+                     , svg_font_style   = SVG_REGULAR+                     , font_enc_vector  = standard_encoding+                     }+++-- | Helvetica Oblique+--+helvetica_oblique :: FontDef+helvetica_oblique = +    FontDef { font_def_face   = face+            , gs_file_name    = "n019023l.afm"          -- NimbusSanL-ReguItal+            , afm_file_name   = "Helvetica-Oblique.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Helvetica-Oblique"+                     , svg_font_family  = "Helvetica"+                     , svg_font_style   = SVG_OBLIQUE+                     , font_enc_vector  = standard_encoding+                     }++-- | Helvetica Bold+-- +helvetica_bold :: FontDef+helvetica_bold = +    FontDef { font_def_face   = face+            , gs_file_name    = "n019004l.afm"          -- NimbusSanL-Bold+            , afm_file_name   = "Helvetica-Bold.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Helvetica-Bold"+                     , svg_font_family  = "Helvetica"+                     , svg_font_style   = SVG_BOLD+                     , font_enc_vector  = standard_encoding+                     }+++-- | Helvetica Bold Oblique+--+helvetica_bold_oblique :: FontDef+helvetica_bold_oblique = +    FontDef { font_def_face   = face+            , gs_file_name    = "n019024l.afm"          -- NimbusSanL-BoldItal+            , afm_file_name   = "Helvetica-BoldOblique.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Helvetica-Bold-Oblique"+                     , svg_font_family  = "Helvetica"+                     , svg_font_style   = SVG_BOLD_OBLIQUE+                     , font_enc_vector  = standard_encoding+                     }++++--------------------------------------------------------------------------------++-- | 'FontFamily' definition for Courier.+--+courier_family :: FontFamily+courier_family = +    FontFamily { ff_regular     = courier+               , ff_bold        = Just courier_bold+               , ff_italic      = Just courier_oblique+               , ff_bold_italic = Just courier_bold_oblique+               }++++-- | Courier+-- +courier :: FontDef+courier = +    FontDef { font_def_face   = face+            , gs_file_name    = "n022003l.afm"          -- NimbusMonL-Regu+            , afm_file_name   = "Courier.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Courier"+                     , svg_font_family  = "Courier New"+                     , svg_font_style   = SVG_REGULAR+                     , font_enc_vector  = standard_encoding+                     }++-- | Courier Oblique+-- +courier_oblique :: FontDef+courier_oblique = +    FontDef { font_def_face   = face+            , gs_file_name    = "n022023l.afm"          -- NimbusMonL-ReguObli+            , afm_file_name   = "Courier-Oblique.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Courier-Oblique"+                     , svg_font_family  = "Courier New"+                     , svg_font_style   = SVG_OBLIQUE+                     , font_enc_vector  = standard_encoding+                     }+++-- | Courier Bold+-- +courier_bold :: FontDef+courier_bold =+    FontDef { font_def_face   = face+            , gs_file_name    = "n022004l.afm"          -- NimbusMonL-Bold+            , afm_file_name   = "Courier-Bold.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Courier-Bold"+                     , svg_font_family  = "Courier New"+                     , svg_font_style   = SVG_BOLD+                     , font_enc_vector  = standard_encoding+                     }+++-- | Courier Bold Oblique+-- +courier_bold_oblique :: FontDef+courier_bold_oblique = +    FontDef { font_def_face   = face+            , gs_file_name    = "n022024l.afm"          -- NimbusMonL-BoldObli+            , afm_file_name   = "Courier-BoldOblique.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Courier-Bold-Oblique"+                     , svg_font_family  = "Courier New"+                     , svg_font_style   = SVG_BOLD_OBLIQUE+                     , font_enc_vector  = standard_encoding+                     }++--------------------------------------------------------------------------------+-- Symbol++-- | Symbol+--+-- Note - Symbol is intentionally not supported for SVG by some +-- renderers (Firefox). Chrome is fine, but the use of symbol +-- should be still be avoided for web graphics.+-- +symbol :: FontDef+symbol = +    FontDef { font_def_face   = face+            , gs_file_name    = "s050000l.afm"          -- StandardSymL+            , afm_file_name   = "Symbol.afm"+            }+  where+    face =  FontFace { ps_font_name     = "Symbol"+                     , svg_font_family  = "Symbol"+                     , svg_font_style   = SVG_REGULAR+                     , font_enc_vector  = symbol_encoding+                     }+++++
− src/Wumpus/Drawing/Turtle/TurtleClass.hs 
@@ -1,91 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Turtle.TurtleClass--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Turtle monad and monad transformer.------ The Turtle monad embodies the LOGO style of imperative --- drawing - sending commands to update the a cursor.------ While Wumpus generally aims for a more compositional,--- \"coordinate-free\" style of drawing, some types of diagram --- are more easily expressed in the LOGO style.------ Note - as turtle drawing with Wumpus is a /local effect/, --- there is only one instance of TurtleM. Potentially TurtleM --- will be removed and the functions implemented directly. --------------------------------------------------------------------------------------module Wumpus.Drawing.Turtle.TurtleClass-  (--    Coord--  , TurtleM(..)--  , setsLoc-  , setsLoc_--  -- * movement-  , resetLoc-  , moveLeft-  , moveRight-  , moveUp-  , moveDown-  , nextLine- --  ) where----type Coord = (Int,Int)---class Monad m => TurtleM m where-  getLoc     :: m (Int,Int)-  setLoc     :: (Int,Int) -> m ()-  getOrigin  :: m (Int,Int)-  setOrigin  :: (Int,Int) -> m ()----setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a-setsLoc f = getLoc      >>= \coord -> -            let (a,coord') = f coord in setLoc coord' >> return a--setsLoc_ :: TurtleM m => (Coord -> Coord) -> m ()-setsLoc_ f = getLoc     >>= \coord ->  setLoc (f coord)---resetLoc    :: TurtleM m => m ()-resetLoc    = getOrigin >>= setLoc---moveRight   :: TurtleM m => m ()-moveRight   = setsLoc_ $ \(x,y)-> (x+1, y)---moveLeft    :: TurtleM m => m ()-moveLeft    = setsLoc_ $ \(x,y) -> (x-1,y)--moveUp      :: TurtleM m => m ()-moveUp      = setsLoc_ $ \(x,y) -> (x,y+1)--moveDown    :: TurtleM m => m ()-moveDown    = setsLoc_ $ \(x,y) -> (x ,y-1)---nextLine    :: TurtleM m => m ()-nextLine    = getOrigin >>= \(ox,_) ->-              setsLoc_ $ \(_,y) -> (ox,y-1)-
− src/Wumpus/Drawing/Turtle/TurtleMonad.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Turtle.TurtleMonad--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Turtle monad transformer.------ The Turtle monad embodies the LOGO style of imperative --- drawing - sending commands to update the a cursor.------ While Wumpus generally aims for a more compositional,--- \"coordinate-free\" style of drawing, some types of --- diagram are more easily expressed in the LOGO style.------ Turtle is only a transformer - it is intended to be run within--- a 'Drawing'.--------------------------------------------------------------------------------------module Wumpus.Drawing.Turtle.TurtleMonad-  (-    -- * Re-exports-    module Wumpus.Drawing.Turtle.TurtleClass--  -- * Turtle transformer-  , TurtleT-  , runTurtleT--   -  ) where--import Wumpus.Basic.Kernel-import Wumpus.Drawing.Turtle.TurtleClass----import Control.Applicative-import Control.Monad----- Note - if Turtle is now just a /local effect/ monad is the --- Turtle class still needed? Afterall, there is (probably)--- only ever going to be one instance.------- Turtle is a Reader / State monad--- --- The env is the horizontal and vertical move distances.--- --- The state is the current coordinate and the origin.-----data TurtleState = TurtleState -      { _turtle_origin   :: (Int,Int)-      , _current_coord   :: (Int,Int)-      }--newtype TurtleT u m a = TurtleT { -          getTurtleT :: ScalingContext Int Int u -                     -> TurtleState -                     -> m (a, TurtleState) }--type instance MonUnit (TurtleT u m) = u-    ----- Functor----instance Monad m => Functor (TurtleT u m) where-  fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->-                               return (f a, s')----- Applicative --instance Monad m => Applicative (TurtleT u m) where-  pure a    = TurtleT $ \_ s -> return (a,s)-  mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s  >>= \(f,s')  ->-                                getTurtleT ma r s' >>= \(a,s'') ->-                                return (f a,s'') ----- Monad --instance Monad m => Monad (TurtleT u m) where-  return a = TurtleT $ \_ s -> return (a,s)-  m >>= k  = TurtleT $ \r s -> getTurtleT m r s        >>= \(a,s')  ->-                               (getTurtleT . k) a r s' >>= \(b,s'') ->-                               return (b,s'')-----instance Monad m => TurtleM (TurtleT u m) where-  getLoc      = TurtleT $ \_ s@(TurtleState _ c) -> return (c,s)-  setLoc c    = TurtleT $ \_ (TurtleState o _)   -> return ((),TurtleState o c)-  getOrigin   = TurtleT $ \_ s@(TurtleState o _) -> return (o,s)-  setOrigin o = TurtleT $ \_ (TurtleState _ c)   -> return ((),TurtleState o c)---runTurtleT :: (Monad m, Num u) -           => (Int,Int) -> ScalingContext Int Int u -> TurtleT u m a -> m a-runTurtleT ogin cfg mf = getTurtleT mf cfg st0 >>= \(a,_) -> return a-  where -    st0 = TurtleState ogin ogin ----------------------------------------------------------------------------------------- Cross instances--instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where-  askDC           = TurtleT $ \_ s -> askDC >>= \ ctx -> return (ctx,s)-  localize upd mf = TurtleT $ \r s -> localize upd (getTurtleT mf r s)----- This needs undecidable instances...--instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where-  trace a  = TurtleT $ \_ s -> trace a >> return ((),s)---instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where-  position = TurtleT $ \r s@(TurtleState _ (x,y)) -> return (scalePt r x y,s)-
src/Wumpus/Drawing/VersionNumber.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.VersionNumber--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -23,7 +23,7 @@  -- | Version number ----- > (0,1,0)+-- > (0,9,0) -- wumpus_drawing_version :: (Int,Int,Int)-wumpus_drawing_version = (0,1,0)+wumpus_drawing_version = (0,9,0)
wumpus-drawing.cabal view
@@ -1,5 +1,5 @@ name:             wumpus-drawing-version:          0.1.0+version:          0.9.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -12,7 +12,7 @@   \*\* WARNING \*\* - this package is sub-alpha. Although many of    the drawing objects have been improved since the code was split    from Wumpus-Basic, the code is still prototypical. Essentially-  this package is a /technology preview/ and not a re-usable +  this package is a /technology preview/ and not yet a re-usable    library.   .   NOTE - many of the demos use font metrics. Font metrics for@@ -24,7 +24,7 @@   links below. To run the demos properly you will need one of    these sets of metrics.   .-  Adobe Font techinal notes:+  Adobe Font technical notes:   <https://www.adobe.com/devnet/font.html>   .   Core 14 AFM metrics:@@ -38,22 +38,44 @@   .   Changelog:   .-  v0.1.0:+  v0.8.0 to v0.9.0:+  . +  * Updated to work with wumpus-basic-0.24.0.    .-  * Initial release - this is a split from @Wumpus-Basic@ making -    the (very prototypical - read sub-alpha, unstable...) modules -    in the @Drawing@ hierarchy a separate package.+  * Removed monoid mappend alias @(<>)@ as it is now defined by+    Data.Monoid.    .-  * Simplified Chains - chains are now regular lists (though often-    infinite). Drawings are made with chains using new zip-like-    functions.+  v0.7.0 to v0.8.0:   .-  * Re-worked Shapes.+  * Changed API to make Connectors.   .-  * Re-worked Arrow and Arrow Tip types.+  * Added InclineTrails to Drawing.Basis.+  . +  * Reworked @Extras.Loop@.   .-  * Re-worked ConnectorPaths.+  v0.6.0 to v0.7.0:   .+  * Changed paths - @RelPath@ has been removed and there are now +    only absolute paths. @PathBuilder@ builds absolute paths.+    Pen updating in @PathBuilder@ now works like a State monad +    rather than @local@ in a Reader monad.+  .+  * Changed argument order of the run functions to @monadLib@ +    style (params * monadic action) rather than @MTL@ style +    (monadic action * params).+  .+  * Added Symbols to Drawing.Basis.+  .+  * Added a tube box connector.+  .+  v0.5.0 to v0.6.0:+  .+  * Removed @LocTrace@ and @RefTrace@ from @Wumpus.Drawing.Basis@,+    they are superseded by @LocDrawing@ in Wumpus-Basic.+  . +  * Remaned path building operations in @RelPathBuilder@.+  .+  . build-type:         Simple stability:          highly unstable cabal-version:      >= 1.2@@ -63,59 +85,76 @@   LICENSE,   demo/ArrowCircuit.hs,   demo/Arrowheads.hs,+  demo/Automata.hs,   demo/ClipPic.hs,   demo/ColourCharts.hs,   demo/ColourChartUtils.hs,   demo/Connectors.hs   demo/DotPic.hs,   demo/FeatureModel.hs,-  demo/FontLoaderUtils.hs,   demo/FontPic.hs,   demo/LeftRightText.hs,   demo/PetriNet.hs,-  demo/PictureCompo.hs,-  demo/Symbols.hs,-  demo/TableChains.hs+  demo/SingleChar.hs,+  demo/SingleLine.hs,+  demo/SampleShapes.hs,+  demo/Symbols.hs  library   hs-source-dirs:     src   build-depends:      base            <  5,                        containers      >= 0.3     && <= 0.6,-                      directory       >= 1.0     && <  2.0, -                      filepath        >= 1.1     && <  2.0,                       vector-space    >= 0.6     && <  1.0,-                      wumpus-core     >= 0.42.0  && <  0.43.0,-                      wumpus-basic    == 0.15.0+                      wumpus-core     >= 0.52.0  && <  0.53.0,+                      wumpus-basic    == 0.24.0       exposed-modules:-    Wumpus.Drawing.Arrows,-    Wumpus.Drawing.Arrows.Connectors,-    Wumpus.Drawing.Arrows.Tips,-    Wumpus.Drawing.Chains,-    Wumpus.Drawing.Chains.Base,-    Wumpus.Drawing.Chains.Derived,+    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,+    Wumpus.Drawing.Connectors,+    Wumpus.Drawing.Connectors.Arrowheads,+    Wumpus.Drawing.Connectors.Base,+    Wumpus.Drawing.Connectors.BoxConnectors,+    Wumpus.Drawing.Connectors.ConnectorPaths,+    Wumpus.Drawing.Connectors.ConnectorProps,     Wumpus.Drawing.Dots.AnchorDots,-    Wumpus.Drawing.Dots.Marks,-    Wumpus.Drawing.Geometry.Intersection,-    Wumpus.Drawing.Geometry.Paths,+    Wumpus.Drawing.Dots.SimpleDots,+    Wumpus.Drawing.Extras.Axes,+    Wumpus.Drawing.Extras.Clip,+    Wumpus.Drawing.Extras.Grids,+    Wumpus.Drawing.Extras.Loop,     Wumpus.Drawing.Paths,     Wumpus.Drawing.Paths.Base,-    Wumpus.Drawing.Paths.Connectors,-    Wumpus.Drawing.Paths.MonadicConstruction,-    Wumpus.Drawing.Paths.ControlPoints,+    Wumpus.Drawing.Paths.Illustrate,+    Wumpus.Drawing.Paths.Intersection,+    Wumpus.Drawing.Paths.PathBuilder,+    Wumpus.Drawing.Paths.Vamps,     Wumpus.Drawing.Shapes,     Wumpus.Drawing.Shapes.Base,     Wumpus.Drawing.Shapes.Circle,     Wumpus.Drawing.Shapes.Diamond,     Wumpus.Drawing.Shapes.Ellipse,+    Wumpus.Drawing.Shapes.InvSemicircle,+    Wumpus.Drawing.Shapes.InvSemiellipse,+    Wumpus.Drawing.Shapes.InvTriangle,+    Wumpus.Drawing.Shapes.Parallelogram,     Wumpus.Drawing.Shapes.Rectangle,-    Wumpus.Drawing.Text.LRText,-    Wumpus.Drawing.Text.SafeFonts,-    Wumpus.Drawing.Turtle.TurtleClass,-    Wumpus.Drawing.Turtle.TurtleMonad,+    Wumpus.Drawing.Shapes.Trapezium,+    Wumpus.Drawing.Shapes.Semicircle,+    Wumpus.Drawing.Shapes.Semiellipse,+    Wumpus.Drawing.Shapes.Triangle,+    Wumpus.Drawing.Text.Base.DocTextZero,+    Wumpus.Drawing.Text.Base.Label,+    Wumpus.Drawing.Text.DirectionZero,+    Wumpus.Drawing.Text.DocSymbols,+    Wumpus.Drawing.Text.StandardFontDefs,     Wumpus.Drawing.VersionNumber    other-modules: