wumpus-drawing 0.1.0 → 0.2.0

raw patch · 46 files changed

+3512/−1350 lines, 46 filesdep −directorydep −filepathdep ~wumpus-basicdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependencies removed: directory, filepath

Dependency ranges changed: wumpus-basic, wumpus-core

API changes (from Hackage documentation)

Files

• CHANGES +13/−1
• demo/ArrowCircuit.hs +13/−9
• demo/Arrowheads.hs +6/−4
• demo/ClipPic.hs +12/−11
• demo/ColourCharts.hs +7/−5
• demo/Connectors.hs +6/−4
• demo/DotPic.hs +8/−5
• demo/FeatureModel.hs +7/−7
• demo/FontPic.hs +12/−8
• demo/LeftRightText.hs +69/−76
• demo/PetriNet.hs +15/−13
• demo/PictureCompo.hs +0/−151
• demo/SampleShapes.hs +206/−0
• demo/SingleLine.hs +80/−0
• demo/Symbols.hs +7/−6
• demo/TableChains.hs +16/−10
• src/Wumpus/Drawing/Chains/Base.hs +198/−56
• src/Wumpus/Drawing/Chains/Derived.hs +64/−35
• src/Wumpus/Drawing/Dots/AnchorDots.hs +44/−42
• src/Wumpus/Drawing/Dots/Marks.hs +5/−5
• src/Wumpus/Drawing/Geometry/Intersection.hs +0/−173
• src/Wumpus/Drawing/Geometry/Paths.hs +0/−138
• src/Wumpus/Drawing/Grids.hs +67/−0
• src/Wumpus/Drawing/Paths.hs +4/−3
• src/Wumpus/Drawing/Paths/Base.hs +24/−89
• src/Wumpus/Drawing/Paths/Connectors.hs +12/−6
• src/Wumpus/Drawing/Paths/MonadicConstruction.hs +2/−2
• src/Wumpus/Drawing/Shapes.hs +18/−1
• src/Wumpus/Drawing/Shapes/Base.hs +151/−39
• src/Wumpus/Drawing/Shapes/Circle.hs +39/−29
• src/Wumpus/Drawing/Shapes/Diamond.hs +59/−54
• src/Wumpus/Drawing/Shapes/Ellipse.hs +31/−21
• src/Wumpus/Drawing/Shapes/InvSemicircle.hs +121/−0
• src/Wumpus/Drawing/Shapes/InvSemiellipse.hs +123/−0
• src/Wumpus/Drawing/Shapes/InvTriangle.hs +147/−0
• src/Wumpus/Drawing/Shapes/Parallelogram.hs +269/−0
• src/Wumpus/Drawing/Shapes/Rectangle.hs +69/−40
• src/Wumpus/Drawing/Shapes/Semicircle.hs +235/−0
• src/Wumpus/Drawing/Shapes/Semiellipse.hs +265/−0
• src/Wumpus/Drawing/Shapes/Trapezium.hs +281/−0
• src/Wumpus/Drawing/Shapes/Triangle.hs +226/−0
• src/Wumpus/Drawing/Text/Base.hs +166/−0
• src/Wumpus/Drawing/Text/CatText.hs +207/−0
• src/Wumpus/Drawing/Text/LRText.hs +180/−297
• src/Wumpus/Drawing/VersionNumber.hs +2/−2
• wumpus-drawing.cabal +26/−8

@@ -1,4 +1,16 @@  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.

@@ -8,17 +8,18 @@  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.Shapes import Wumpus.Drawing.Text.LRText import Wumpus.Drawing.Text.SafeFonts -import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader.Afm+import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Core                              -- package: wumpus-core+ import FontLoaderUtils  @@ -70,7 +71,7 @@           circuit_pic :: CtxPicture Double  circuit_pic = drawTracing $ do-    a1 <- drawi $ (strokedShape $ rrectangle 12 66 30) `at` P2 0 72+    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"@@ -103,16 +104,19 @@          , TraceM m, DrawingCtxM m, u ~ MonUnit m )       => t -> String -> m () atext ancr ss = let pt = center ancr in-   drawi_ $ ctrCenterLine ss `at` pt+   drawi_ $ textAlignCenter 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+    drawi_ $ textAlignCenter ss `at` pt  +-- Note - return type is a LocImage not a shape...+-- 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)+           => u -> u -> u -> LocImage u (Rectangle u)+rrectangle r w h = +    localize (roundCornerFactor $ realToFrac r) $ strokedShape (rectangle w h)

@@ -3,12 +3,13 @@ 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.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space@@ -60,10 +61,11 @@  tableGraphic :: (Real u, Floating u, FromPtSize u)               => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u ()-tableGraphic tips = zipchainWith makeArrowDrawing tips ps+tableGraphic tips = +    draw $ unchainZipWith emptyLocGraphic makeArrowDrawing tips chn `at` start   where-    ps = tableDown 20 (120,24) (P2 0 480)-+    chn   = tableDown 20 (120,24)+    start = P2 0 480    std_ctx :: DrawingContext

@@ -12,12 +12,14 @@  module ClipPic where -import Wumpus.Basic.Kernel import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Paths+import Wumpus.Drawing.Paths.MonadicConstruction import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space@@ -38,25 +40,24 @@   big_pic :: DCtxPicture-big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4]+big_pic = pic1 `cxpDown` oconcat cpic1 [cpic2, cpic3, cpic4]  fillPath :: Num u => Path u -> Graphic u fillPath = filledPath . toPrimPath  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+pic1 = drawTracing $ localize (fillColour medium_slate_blue) $ do+    draw $ fillPath path01+    draw $ localize (fillColour powder_blue) $ fillPath path02+    draw $ fillPath path03+    draw $ fillPath path04   background :: RGBi -> DCtxPicture background rgb = drawTracing $ -    localize (strokeColour rgb) $ -        unchain 112 iheartHaskell $ tableDown 18 (86,16) (P2 0 288)+    draw $ localize (strokeColour rgb) $ ihh `at` P2 0 288+  where+    ihh = unchain 112 emptyLocGraphic iheartHaskell $ tableDown 18 (86,16)  cpic1 :: DCtxPicture  cpic1 = clipCtxPicture (toPrimPath path01) (background black)

@@ -4,9 +4,10 @@  import ColourChartUtils -import Wumpus.Basic.Kernel import Wumpus.Drawing.Chains +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  import System.Directory@@ -42,11 +43,12 @@  tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double () tableGraphic row_count xs = -    zipchainWith (\(name,rgb) -> colourSample name rgb) xs ps+    draw $ unchainZip emptyLocGraphic gs chn `at` pt   where-    ps = tableDown row_count (152,11) pt-    pt = displaceV (fromIntegral $ 11 * row_count) zeroPt -+    chn  = tableDown row_count (152,11)+    pt   = displaceV (fromIntegral $ 11 * row_count) zeroPt +    gs   = map (uncurry colourSample) xs+     colourSample :: String -> RGBi -> LocGraphic Double colourSample name rgb = localize (fillColour rgb) $ 

@@ -3,12 +3,13 @@ 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.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  import System.Directory@@ -50,10 +51,11 @@  tableGraphic :: (Real u, Floating u, FromPtSize u)               => [ConnectorPath u] -> TraceDrawing u ()-tableGraphic conns = zipchainWith makeConnDrawing conns ps+tableGraphic conns = +    draw $ unchainZipWith emptyLocGraphic makeConnDrawing conns chn `at` start   where-    ps = tableDown 10 (120,52) (displaceV 520 zeroPt)-+    chn   = tableDown 10 (120,52) +    start = P2 0 520     std_ctx :: DrawingContext

@@ -3,9 +3,7 @@ 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@@ -13,6 +11,10 @@  import FontLoaderUtils +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader.Afm+import Wumpus.Basic.System.FontLoader.GhostScript+ import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space@@ -82,10 +84,11 @@  tableGraphic :: (Real u, Floating u, FromPtSize u)               => [DotLocImage u] -> TraceDrawing u ()-tableGraphic imgs = zipchainWith makeDotDrawing imgs ps+tableGraphic imgs = +    draw $ unchainZipWith emptyLocGraphic makeDotDrawing imgs chn `at` pt   where     row_count   = length imgs-    ps          = tableDown row_count (1,36) pt+    chn         = tableDown row_count (1,36)     pt          = displaceV (fromIntegral $ 36 * row_count) zeroPt   

@@ -5,17 +5,18 @@  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.Shapes import Wumpus.Drawing.Text.LRText import Wumpus.Drawing.Text.SafeFonts -import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader.Afm+import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Core                              -- package: wumpus-core+ import FontLoaderUtils  @@ -26,7 +27,6 @@ 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@@ -95,7 +95,7 @@         => 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+    drawi_ $ textAlignCenter ss `at` center a     -- draw  $ filledDisk 2 `at` center a     return a @@ -113,7 +113,7 @@ connWith arrh b0 b1 = do    lw <- getLineWidth    let p0 = south b0-   let p1 = northwards (realToFrac lw) b1+   let p1 = projectAnchor north (realToFrac lw) b1    drawi $ apply2R2 (rightArrow arrh connLine) p0 p1  infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_`

@@ -2,12 +2,13 @@  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.Basic.Kernel                      -- package: wumpus-basic+ import Wumpus.Core                              -- package: wumpus-core  @@ -56,23 +57,26 @@   pointChain :: LocChain Double-pointChain = verticals $ map (fromIntegral . (+2)) point_sizes+pointChain = verticalSteps $ map (fromIntegral . (+2)) point_sizes -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 -> FontFace -> DLocGraphic +fontGraphic rgb ff = +    unchainZipWith emptyLocGraphic mkGF point_sizes pointChain +  where+    mkGF sz = makeLabel rgb ff sz + std_ctx :: DrawingContext std_ctx = standardContext 10   fontDrawing :: [(RGBi,FontFace)] -> DCtxPicture fontDrawing xs = drawTracing $  -    zipchainWithTD (\(rgb,ff) -> fontGraphic rgb ff) xs ps+    draw $ unchainZipWith emptyLocGraphic (uncurry fontGraphic) xs chn `at` start   where-    ps = tableDown 4 (1,180) (P2 0 (4*180))+    chn   = tableDown 4 (1,180)+    start = P2 0 (4*180)   

@@ -15,19 +15,19 @@  module LeftRightText where +import FontLoaderUtils -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.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader.Afm+import Wumpus.Basic.System.FontLoader.GhostScript -import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Core                              -- package: wumpus-core  import System.Directory @@ -66,43 +66,44 @@   makeCtx :: GlyphMetrics -> DrawingContext-makeCtx = fontFace helvetica . metricsContext 18+makeCtx = fontFace helvetica . metricsContext 14   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 center_text)     `at` P2 150 400+    drawi_ $ (fn right_text)      `at` P2 300 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 ne_oneline)      `at` P2 150 300 +    drawi_ $ (fn cc_oneline)      `at` P2 300 300+++    drawi_ $ (fn sw_oneline)      `at` P2   0 200+    drawi_ $ (fn ss_oneline)      `at` P2 150 200+    drawi_ $ (fn se_oneline)      `at` P2 300 200+    drawi_ $ (fn swr_multi)       `at` P2   0 100+    drawi_ $ (fn ssr_multi)       `at` P2 150 100+    drawi_ $ (fn ner_multi)       `at` P2 300 100     drawi_ $ (fn rleft_text)      `at` P2   0 (-75)-    drawi_ $ (fn rcenter_text)    `at` P2 200 (-75)-    drawi_ $ (fn rright_text)     `at` P2 400 (-75)-      - +    drawi_ $ (fn rcenter_text)    `at` P2 150 (-75)+    drawi_ $ (fn rright_text)     `at` P2 300 (-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@@ -111,81 +112,73 @@ redPlus = localize (strokeColour red) markPlus  -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 = singleLine "north east" `startPos` NE -newblr :: BoundedLocGraphic Double-newblr = -    localize (strokeColour dark_slate_gray) $ -        baseRightLine "new baseline right" +-- single line+--+se_oneline :: BoundedLocGraphic Double+se_oneline = singleLine "south east" `startPos` SE -rnewblc :: BoundedLocGraphic Double-rnewblc = -    localize (strokeColour dark_slate_gray) $ -        rbaseCenterLine "baseline center" `rot` (0.25*pi)+-- single line+--+ss_oneline :: BoundedLocGraphic Double+ss_oneline = singleLine "south" `startPos` SS -rnewbll :: BoundedLocGraphic Double-rnewbll = -    localize (strokeColour dark_slate_gray) $ -        rbaseLeftLine "baseline left" `rot` (0.25*pi)+-- single line+--+sw_oneline :: BoundedLocGraphic Double+sw_oneline = singleLine "south west" `startPos` SW -rnewblr :: BoundedLocGraphic Double-rnewblr = -    localize (strokeColour dark_slate_gray) $ -        rbaseRightLine "baseline right" `rot` (0.25 * pi) +-- multi line+--+ssr_multi :: BoundedLocGraphic Double+ssr_multi = multiAlignCenter (0.25*pi) "south rot45" `startPos` SS -bl_oneline :: BoundedLocGraphic Double-bl_oneline = -    localize (strokeColour dark_slate_gray) $ baseLeftLine "Baseline-left..."+-- multi line+--+swr_multi :: BoundedLocGraphic Double+swr_multi = multiAlignCenter (0.25*pi) "south west rot45" `startPos` SW +-- multi line+--+ner_multi :: BoundedLocGraphic Double+ner_multi = multiAlignCenter (0.25*pi) "north east rot45" `startPos` NE + cc_oneline :: BoundedLocGraphic Double-cc_oneline = -    localize (strokeColour dark_slate_gray) $ ctrCenterLine "Center-center..."+cc_oneline = rsingleLine 0 "Center-center..."  `startPos` CENTER + blank_text :: BoundedLocGraphic Double-blank_text = -    localize (strokeColour dark_slate_gray) $ multiAlignCenter ""+blank_text = multiAlignCenter 0 "" `startPos` CENTER   left_text :: BoundedLocGraphic Double-left_text = -    localize (strokeColour dark_slate_gray) $ multiAlignLeft dummy_text+left_text = multiAlignLeft 0 dummy_text `startPos` CENTER   right_text :: BoundedLocGraphic Double-right_text = -    localize (strokeColour dark_slate_gray) $ multiAlignRight dummy_text+right_text = multiAlignRight 0 dummy_text `startPos` CENTER  center_text :: BoundedLocGraphic Double-center_text = -    localize (strokeColour dark_slate_gray) $ multiAlignCenter dummy_text+center_text = multiAlignCenter 0 dummy_text `startPos` CENTER   rleft_text :: BoundedLocGraphic Double-rleft_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignLeft dummy_text `rot`   (0.25*pi)+rleft_text = multiAlignLeft (0.25*pi)  dummy_text `startPos` CENTER   rright_text :: BoundedLocGraphic Double-rright_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignRight dummy_text `rot`  (0.25*pi)+rright_text = multiAlignRight (0.25*pi) dummy_text `startPos` CENTER  rcenter_text :: BoundedLocGraphic Double-rcenter_text = -    localize (strokeColour dark_slate_gray) $ -        rmultiAlignCenter dummy_text `rot` (0.25*pi)+rcenter_text = multiAlignCenter (0.25*pi) dummy_text `startPos` CENTER   dummy_text :: String 

@@ -7,9 +7,6 @@  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@@ -19,6 +16,10 @@  import FontLoaderUtils +import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader.Afm+import Wumpus.Basic.System.FontLoader.GhostScript+ import Wumpus.Core                              -- package: wumpus-core  @@ -96,19 +97,20 @@     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 "processing_w"   `at` (projectAnchor south 12 pw)+    draw $ lblBold "ready_to_write" `at` (projectAnchor south 12 rtw)+    draw $ lblBold "writing"        `at` (projectAnchor south 12 w)     draw $ lblBold' "resource"      `at` (P2 300 72)-    draw $ lblBold "processing_r"   `at` (northwards 12 pr)-    draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)-    draw $ lblBold "reading"        `at` (northwards 12 r)+    draw $ lblBold "processing_r"   `at` (projectAnchor north 12 pr)+    draw $ lblBold "ready_to_read"  `at` (projectAnchor north 12 rtr)+    draw $ lblBold "reading"        `at` (projectAnchor north 12 r)     return ()  greenFill :: DrawingCtxM m => m a -> m a greenFill = localize (fillColour lime_green) -place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) +place :: ( Real u, Floating u, FromPtSize u+         , DrawingCtxM m, TraceM m, u ~ MonUnit m )        => u -> u -> m (Circle u) place x y = greenFill $ drawi $ (borderedShape $ circle 14) `at` P2 x y @@ -153,6 +155,6 @@   lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u-lblBold ss = localize (fontFace helvetica_bold) $ post $ ctrCenterLine ss-  where-    post = fmap (replaceL uNil)+lblBold ss = localize (fontFace helvetica_bold) $ +                ignoreAns $ textAlignCenter ss+

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

@@ -0,0 +1,206 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}+++module SampleShapes where+++import FontLoaderUtils++import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Dots.Marks+import Wumpus.Drawing.Shapes+import Wumpus.Drawing.Text.LRText+import Wumpus.Drawing.Text.SafeFonts++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader.Afm+import Wumpus.Basic.System.FontLoader.GhostScript+++import Wumpus.Core                              -- package: wumpus-core++import Control.Monad+import System.Directory+++main :: IO ()+main = do +    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help+    createDirectoryIfMissing True "./out/shapes/"+    maybe gs_failk  (makeGSPicture shape_list)  $ mb_gs+    maybe afm_failk (makeAfmPicture shape_list) $ mb_afm+  where+    gs_failk  = putStrLn "No GhostScript font path supplied..."+    afm_failk = putStrLn "No AFM v4.1 font path supplied..."+++makeGSPicture :: ShapeList -> FilePath -> IO ()+makeGSPicture shapes font_dir = do+    putStrLn "Using GhostScript metrics..."+    (gs_metrics, msgs) <- loadGSMetrics font_dir ["Courier"]+    mapM_ putStrLn msgs+    mapM_ (out1 gs_metrics) shapes +  where+    out1 gs_metrics (name, shape_pic) = do +       let pic1 = runCtxPictureU (makeCtx gs_metrics) $ shape_pic name+       writeEPS ("./out/shapes/" ++ name ++ "01.eps") pic1+       writeSVG ("./out/shapes/" ++ name ++ "01.svg") pic1+++makeAfmPicture :: ShapeList -> FilePath -> IO ()+makeAfmPicture shapes font_dir = do+    putStrLn "Using AFM 4.1 metrics..."+    (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Courier"]+    mapM_ putStrLn msgs+    mapM_ (out1 afm_metrics) shapes +  where+    out1 afm_metrics (name, shape_pic) = do +        let pic1 = runCtxPictureU (makeCtx afm_metrics) $ shape_pic name+        writeEPS ("./out/shapes/" ++ name ++ "02.eps") pic1+        writeSVG ("./out/shapes/" ++ name ++ "02.svg") pic1++type ShapeList = [(String, (String -> DCtxPicture))]+++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) $ +          ztrapezium 300 150)+    , ( "triangle"+      , shapePic (apexAnchor >=> bottomCorners >=> midPoints 3) $ +          triangle 300 150 )+    ]++makeCtx :: GlyphMetrics -> DrawingContext+makeCtx = fontFace courier . metricsContext 16++rotate05 :: Rotate a => a -> a+rotate05 = rotate (d2r (5::Double))++-- Extra elaboration...++voidExtra :: a -> TraceDrawing u ()+voidExtra _ = return ()++apexAnchor :: ( Real u, Floating u, FromPtSize u+            , ApexAnchor a+            , u ~ DUnit a )+            => a -> TraceDrawing u a+apexAnchor a = do+    draw $ label EAST   "(apex)"    `at` apex  a+    return a++bottomCorners :: ( Real u, Floating u, FromPtSize u+               , BottomCornerAnchor a+               , u ~ DUnit a )+            => a -> TraceDrawing u a+bottomCorners a = do+    draw $ label SOUTH_WEST   "(bottom left)"    `at` bottomLeftCorner  a+    draw $ label SOUTH_EAST   "(bottom right)"   `at` bottomRightCorner a+    return a++topCorners :: ( Real u, Floating u, FromPtSize u+              , TopCornerAnchor a+              , u ~ DUnit a )+           => 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, FromPtSize 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 :: ( CenterAnchor a, CardinalAnchor a, CardinalAnchor2 a+            , RadialAnchor a+            , Scale a, Rotate a+            , DUnit a ~ Double) +         => (a -> DTraceDrawing b) -> DShape a -> String -> DCtxPicture+shapePic mf sh name = drawTracing $ do+    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 deg10 a1+    draw $ label NORTH_WEST   "(110 deg)"     `at` radialAnchor deg110 a1+    draw $ label WEST         "(190 deg)"     `at` radialAnchor deg190 a1+    draw $ label NORTH        "(250 deg)"     `at` radialAnchor deg250 a1+    _ <- mf a1+    return ()    +  where+    shape   = strokedShape $ setDecoration textF sh+    textF   = lift1R2 $ ignoreAns (multiAlignCenter 0 name `startPos` CENTER)++    deg10   = d2r (10::Double)+    deg110  = d2r (110::Double)+    deg190  = d2r (190::Double)+    deg250  = d2r (250::Double)+++++++shapeSty :: DrawingContextF+shapeSty = strokeColour light_steel_blue . ultrathick++label :: (Real u, Floating u, FromPtSize u) +           => Cardinal -> String -> LocGraphic u+label cpos ss = markX `oplus` msg+  where+    (rpos,fn)     = go cpos+    msg           = ignoreAns $ moveStart (fn 10) $ +                       multiAlignCenter 0 ss `startPos` rpos++    go NORTH      = (SS, northwards)+    go NORTH_EAST = (SW, northeastwards)+    go EAST       = (WW, eastwards) +    go SOUTH_EAST = (NW, southeastwards)+    go SOUTH      = (NN, southwards)+    go SOUTH_WEST = (NE, southwestwards)+    go WEST       = (EE, westwards)+    go NORTH_WEST = (SE, northwestwards)+  +

@@ -0,0 +1,80 @@+{-# OPTIONS -Wall #-}+++module SingleLine where++import FontLoaderUtils++import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Text.LRText+import Wumpus.Drawing.Text.SafeFonts++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.System.FontLoader.Afm+import Wumpus.Basic.System.FontLoader.GhostScript++import Wumpus.Core                              -- package: wumpus-core++import System.Directory+++main :: IO ()+main = do +    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help+    createDirectoryIfMissing True "./out/"+    maybe gs_failk  makeGSPicture  $ mb_gs+    maybe afm_failk makeAfmPicture $ mb_afm+  where+    gs_failk  = putStrLn "No GhostScript font path supplied..."+    afm_failk = putStrLn "No AFM v4.1 font path supplied..."+++makeGSPicture :: FilePath -> IO ()+makeGSPicture font_dir = do+    putStrLn "Using GhostScript metrics..."+    (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"]+    mapM_ putStrLn msgs+    let pic1 = runCtxPictureU (makeCtx gs_metrics) drawing01+    writeEPS "./out/single_line01.eps" pic1+    writeSVG "./out/single_line01.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) drawing01+    writeEPS "./out/single_line02.eps" pic2+    writeSVG "./out/single_line02.svg" pic2++++makeCtx :: GlyphMetrics -> DrawingContext+makeCtx = fontFace helvetica . metricsContext 12++++drawing01 :: DCtxPicture+drawing01 = drawTracing $ localize (fillColour red) $ mf +++mf :: (Real u, Floating u, FromPtSize u) => TraceDrawing u ()+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 :: (Real u, Floating u, FromPtSize u) => RectPosition -> LocGraphic u+testDraw rpos = filledDisk 2 `oplus` (ignoreAns ans)+  where+    ans = singleLine "Qwerty" `startPos` rpos+++

@@ -2,11 +2,10 @@  module Symbols where -import Wumpus.Basic.Kernel import Wumpus.Drawing.Chains import Wumpus.Drawing.Text.SafeFonts -+import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Core                              -- package: wumpus-core  import Prelude hiding ( pi, product )@@ -32,12 +31,14 @@ -- symbols :: DCtxPicture symbols = drawTracing $ do-    localize (fontFace symbol) $ zipchainWith sdraw all_letters ps-    zipchainWith ldraw all_letters ps+    draw $ localize (fontFace symbol) $ +            unchainZipWith emptyLocGraphic sdraw all_letters chn `at` start+    draw $ unchainZipWith emptyLocGraphic ldraw all_letters chn `at` start   where-    ps              = tableDown 30 (100,20) (P2 0 (30*20))+    chn             = tableDown 30 (100,20) +    start           = P2 0 (30*20)     sdraw (s,_)     = textline s-    ldraw (_,name)  = moveStartPoint (displaceH 16) (textline name)+    ldraw (_,name)  = moveStart (displaceH 16) (textline name)   all_letters :: [(String, String)]

@@ -3,15 +3,14 @@ module TableChains where  -import Wumpus.Basic.Kernel-import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours+import Wumpus.Drawing.Grids +import Wumpus.Basic.Kernel                      -- package: wumpus-basic import Wumpus.Core                              -- package: wumpus-core  import System.Directory - main :: IO () main = do      createDirectoryIfMissing True "./out/"@@ -19,10 +18,16 @@     writeEPS "./out/table_chains01.eps" pic1     writeSVG "./out/table_chains01.svg" pic1 -table_drawing :: CtxPicture Double-table_drawing = drawTracing $ tableGraphic+std_ctx :: DrawingContext+std_ctx = fillColour peru $ standardContext 18 +table_drawing :: CtxPicture Double+table_drawing = drawTracing $ do +--    tableGraphic+    draw $ connect (interiorGrid 10) (P2 (-20) (-20)) (P2 150 80)+    draw $ grid (3,2) 20 `at` (P2 300 60) +{- tableGraphic :: (Real u, Floating u, FromPtSize u)               => TraceDrawing u () tableGraphic = do @@ -34,11 +39,12 @@     downs   = tableDown  4 (36,24) dstart     rights  = tableRight 5 (36,24) rstart -    dstart  = P2 0   480-    rstart  = P2 240 480-+    dstart  = P2 0   200   -- note grows down...+    rstart  = P2 240 200   -- ditto+-}  -std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 18+++  

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Chains.Base--- Copyright   :  (c) Stephen Tetley 2010-2011+-- Copyright   :  (c) Stephen Tetley 2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -12,25 +12,24 @@ -- -- 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+    PointChain   , LocChain-  , unchain-  , zipchain-  , zipchainWith--  , unchainTD-  , zipchainTD-  , zipchainWithTD+  , ConnectorChain +  -- * Unrolling chains+  , unchain+  , unchainU+  , unchainZip+  , unchainZipWith+  , unconnectorChain +  -- * Building chains+  , liftChainF    ) where @@ -40,78 +39,221 @@   --- | 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.+-- | A 'PointChain' is a list of points.  -- -type Chain u = [Point2 u]+-- The list is typically inifinte so some attention must be given +-- to choosing a chain drawing function and using it appropriately.+-- +type PointChain u = [Point2 u]  --- | A LocChain is a function from a starting point to a 'Chain'.+-- | A LocChain is a function from a starting point to a +-- 'PointChain'.+--+-- The list is often expected to be inifinte, but if it was a +-- Stream it would loose the ability to use list comprehensions. -- -type LocChain u = Point2 u -> Chain u+type LocChain u = LocDrawingInfo u (PointChain 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+-- | A ConnectorChain is a function from a start- and end-point +-- to a 'Chain'.+-- +type ConnectorChain u = ConnectorCF u (PointChain u)    +-- | 'unchain' : @ unroll_count * alt_fun * draw_fun * chain -> LocCF @+-- +-- Unroll the chain, applying the @draw_fun@ to each point +-- producing a LocCF (usually a 'LocGraphic'). If the chain does +-- not produce any points the @alt_fun@ is applied to the start +-- point.+--+-- Note - commonly a 'Chain' may be infinite, so it is only +-- unrolled a finite number of times - the @unrool_count@.+--+-- This function has a very general type signature commonly it +-- will be used at these types:+--+-- > unchain :: (Num u, OPlus a) => +-- >     Int -> LocImage u a -> LocImage u a -> LocChain u -> LocImage u a+-- >+-- > unchain :: Num u => +-- >     Int -> LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u+--+unchain :: (Num u, OPlus a) +        => Int +        -> LocCF u (ImageAns u a) +        -> LocCF u (ImageAns u a) +        -> LocChain u +        -> LocCF u (ImageAns u a)+unchain i alt _  _   | i <= 0 = alt+unchain i alt gf chn          = promoteR1 $ \p0 -> +    (chn `at` p0) >>= \pts -> case pts of +      []     -> alt `at` p0+      [x]    -> gf  `at` x+      (x:xs) -> go x (take (i-1) xs)+  where+    go x []     = gf `at` x+    go x (y:ys) = (gf `at` x) `oplus` go y ys  -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 +-- | 'unchain' : @ alt_fun * draw_fun * chain -> LocCF @+-- +-- /Unsafe/ version of 'unchain' - this function assumes the chain+-- is finite which is not usually the case.+--+-- This function has a very general type signature commonly it +-- will be used at these type:+--+-- > unchainU :: (Num u, OPlus a) => +-- >     LocImage u a -> LocImage u a -> LocChain u -> LocImage u a+-- >+-- > unchainU :: Num u => +-- >     LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u+--+-- \*\* WARNING \*\* - if the chain is infinite this function will +-- not terminate.+--+unchainU :: (Num u, OPlus a)+         => LocCF u (ImageAns u a) +         -> LocCF u (ImageAns u a) +         -> LocChain u +         -> LocCF u (ImageAns u a)+unchainU alt gf chn = promoteR1 $ \p0 -> +    (chn `at` p0) >>= \pts -> case pts of +      []     -> alt `at` p0+      [x]    -> gf  `at` x+      (x:xs) -> go x xs   where-    go (a:as) (p:ps)   = draw (op a `at` p) >> go as ps-    go _      _        = return ()-+    go x []     = gf `at` x+    go x (y:ys) = (gf `at` x) `oplus` go y ys  --- | Variant of 'unchain' where the drawing argument is a --- @TraceDrawing@ not a @LocGraphic@. +-- | 'unchainZip' : @ alt_fun * [draw_fun] * chain -> LocCF @+-- +-- Unroll the chain, zipping the list of @draw_funs@ to the list+-- of points producing a LocCF (usually a 'LocGraphic'). If the +-- chain does not produce any points the @alt_fun@ is applied to +-- the start point. ---unchainTD :: Int -> (Point2 u -> TraceDrawing u ()) -> Chain u -> TraceDrawing u ()-unchainTD i op chn = go i chn+-- This function has a very general type signature commonly it +-- will be used at these types:+--+-- > unchainZip :: (Num u, OPlus a) => +-- >     LocImage u a -> [LocImage u a] -> LocChain u -> LocImage u a+-- >+-- > unchainZip :: Num u => +-- >     LocGraphic u -> [LocGraphic u] -> LocChain u -> LocGraphic u+--+-- \*\* WARNING \*\* - the list of drawing functions should be +-- finite. If both the list of drawing functions and the chain are +-- infinite this function will not terminate.+-- +unchainZip :: (Num u, OPlus a) +           => LocCF u (ImageAns u a) +           -> [LocCF u (ImageAns u a)] +           -> LocChain u +           -> LocCF u (ImageAns u a)+unchainZip alt []     _   = promoteR1 $ \p0 -> alt `at` p0+unchainZip alt  (g:gs) chn = promoteR1 $ \p0 -> +    (chn `at` p0) >>= \pts -> case pts of +      []     -> alt `at` p0+      [x]    -> g `at` x+      (x:xs) -> go (g `at` x) gs xs   where-    go n _      | n <= 0 = return ()-    go _ []              = return () -    go n (x:xs)          = (op x) >> go (n-1) xs+    go acc _      []     = acc+    go acc []     _      = acc+    go acc (f:fs) (p:ps) = go (acc `oplus` (f `at` p)) fs ps  -zipchainTD :: [Point2 u -> TraceDrawing u ()] -> Chain u -> TraceDrawing u ()-zipchainTD (g:gs) (p:ps)   = g p >> zipchainTD gs ps-zipchainTD _      _        = return () +-- | 'unchainZipWith' : @ alt_fun * (a -> draw_fun) * [a] * chain -> LocCF @+-- +-- Version of 'unchainZip' where the list is some data rather +-- than a drawing function and the @(a -> draw_fun)@ builder is +-- applied to each element as part of the unrolling.+-- +-- Approximately this function is a @zipWith@ to the @zip@ of +-- @unchainZip@.+--+-- This function has a very general type signature commonly it +-- will be used at these type:+--+-- > unchainZipWith :: (Num u, OPlus a) => +-- >     LocImage u a -> (s -> LocImage u a) -> [s] -> LocChain u -> LocImage u a+-- >+-- > unchainZipWith :: Num u => +-- >     LocGraphic u -> (s -> LocGraphic u) -> [s] -> LocChain u -> LocGraphic u+--+-- \*\* WARNING \*\* - if the chain and list are infinite this +-- function will not terminate.+--+unchainZipWith :: (Num u, OPlus a)+                => LocCF u (ImageAns u a) +                -> (s -> LocCF u (ImageAns u a))+                -> [s]+                -> LocChain u +                -> LocCF u (ImageAns u a)+unchainZipWith alt _    []     _   = promoteR1 $ \p0 -> alt `at` p0+unchainZipWith alt mkGF (s:ss) chn = promoteR1 $ \p0 -> +    (chn `at` p0) >>= \pts -> case pts of +      []     -> alt `at` p0+      [x]    -> mkGF s `at` x+      (x:xs) -> go (mkGF s `at` x) ss xs+  where+    go acc _      []     = acc+    go acc []     _      = acc+    go acc (t:ts) (p:ps) = go (acc `oplus` (mkGF t `at` p)) ts ps  -zipchainWithTD :: (a -> Point2 u -> TraceDrawing u ()) -> [a] -> Chain u -> TraceDrawing u ()-zipchainWithTD op xs chn = go xs chn +++-- | 'unconnectorChain' : @ alt_fun * draw_fun * conn_chain -> ConnectorCF @+--+-- Unroll the chain produced between the implicit start and end +-- points. Apply the @draw_fun@ to each point producing a +-- ConnectorCF (usually a 'ConnectorGraphic'). If the chain does +-- not produce any points, the @alt_fun@ is applied to the start +-- and end points.+--+-- This function has a very general type signature commonly it +-- will be used at these types:+--+-- > unconnectorChain :: (Num u, OPlus a) => +-- >     ConnectorImage u a -> LocImage u a -> ConnectorChain u -> ConnectorImage u a+-- >+-- > unconnectorChain :: Num u => +-- >     ConnectorGraphic u -> LocGraphic u -> ConnectorChain u -> ConnectorGraphic u+--+--+unconnectorChain :: (Num u, OPlus a) +                 => ConnectorCF u (ImageAns u a) +                 -> LocCF u (ImageAns u a) +                 -> ConnectorChain u +                 -> ConnectorCF u (ImageAns u a)+unconnectorChain alt gf cchn = promoteR2 $ \p0 p1 -> +    (connect cchn p0 p1) >>= \pts -> case pts of+      []     -> connect alt p0 p1+      [x]    -> gf `at` x+      (x:xs) -> go (gf `at` x) xs   where-    go (a:as) (p:ps)   = op a p >> go as ps-    go _      _        = return ()+    go acc []     = acc+    go acc (p:ps) = go (acc `oplus` (gf `at` p)) ps   --- 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). ++--------------------------------------------------------------------------------++-- | 'liftChainF' : @ (point -> [point]) -> LocChain @ ----- 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?).+-- Lift a pure chain generating function inot a 'LocChain'. --+liftChainF :: (Point2 u -> PointChain u) -> LocChain u+liftChainF fn = promoteR1 $ \pt -> return $ fn pt 

@@ -22,18 +22,25 @@     tableDown   , tableRight -  , horizontal-  , vertical+  , horizontalPoints+  , verticalPoints -  , horizontals-  , verticals+  , horizontalSteps+  , verticalSteps +  , innerHorizontals+  , innerVerticals+   ) where  import Wumpus.Drawing.Chains.Base  import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Core                              -- package: wumpus-core ++import Data.List + -------------------------------------------------------------------------------- -- Tables @@ -47,11 +54,11 @@ -- @top-left@. -- tableDown :: Num u => Int -> (u,u) -> LocChain u-tableDown n (rw,rh) pt = map fn ints+tableDown n (rw,rh) = liftChainF $ \pt -> map (fn pt) ints   where-    ints = iterate (+1) 0-    fn i = let (x,y) = i `divMod` n -           in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt+    ints    = iterate (+1) 0+    fn pt i = let (x,y) = i `divMod` n +              in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt   -- | 'tableRight' : @ num_cols * row_width * row_height -> LocChain @@@ -62,56 +69,45 @@ -- This chain is infinite. -- tableRight :: Num u => Int -> (u,u) -> LocChain u-tableRight n (rw,rh) pt = map fn ints+tableRight n (rw,rh) = liftChainF $ \pt -> map (fn pt) ints   where-    ints = iterate (+1) 0-    fn i = let (y,x) = i `divMod` n -           in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt--+    ints    = iterate (+1) 0+    fn pt i = let (y,x) = i `divMod` n +              in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt   --- | 'horizontal' : @ horizontal_dist -> LocChain @+-- | 'horizontalPoints' : @ 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)+horizontalPoints :: Num u => u -> LocChain u+horizontalPoints dx = liftChainF $ iterate (displaceH dx)  --- | 'vertical' : @ vertical_dist -> LocChain @+-- | 'verticalPoints' : @ 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) +verticalPoints :: Num u => u -> LocChain u+verticalPoints dy = liftChainF $ iterate (displaceV dy)  --- | 'horizontals' : @ [horizontal_dist] -> LocChain @+-- | 'horizontalSteps' : @ [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 +horizontalSteps :: Num u => [u] -> LocChain u+horizontalSteps xs = liftChainF $ \pt -> scanl (flip displaceH) pt xs   --- | 'verticals' : @ [vertical_dist] -> LocChain @+-- | 'verticalSteps' : @ [vertical_dist] -> LocChain @ -- -- This is a @scanl@ successive displacing the start point. --@@ -120,7 +116,40 @@ -- \*\* 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+verticalSteps :: Num u => [u] -> LocChain u+verticalSteps ys = liftChainF $ \pt -> scanl (flip displaceV) pt ys ++{-# INLINE [0] ceilingi #-}+ceilingi :: RealFrac a => a -> Int+ceilingi = ceiling+++-- | Note - horizontals are projected from the start point. The +-- horizontal component of the second point is ignored.+-- +-- This chain is finite for well formed input.+--+innerHorizontals :: RealFrac u => u -> ConnectorChain u+innerHorizontals n = promoteR2 $ \a b -> return $ body a b+  where+    body (P2 x0 y0) (P2 x1 _) = unfoldr phi (n * fromIntegral z) +      where z                 = ceilingi $ x0 / n+            phi x | x < x1    = Just (P2 x y0, x+n)+                  | otherwise = Nothing++      ++-- | Note - verticals are projected from the start point. The +-- vertical component of the second point is ignored.+-- +-- This chain is finite for well formed input.+--+innerVerticals :: RealFrac u => u -> ConnectorChain u+innerVerticals n = promoteR2 $ \a b -> return $ body a b+  where+    body (P2 x0 y0) (P2 _ y1) = unfoldr phi (n * fromIntegral z)+      where z                 = ceilingi $ y0 / n+            phi y | y < y1    = Just (P2 x0 y, y+n)+                  | otherwise = Nothing 

@@ -57,12 +57,13 @@   ) where  -import Wumpus.Drawing.Geometry.Intersection-import Wumpus.Drawing.Geometry.Paths import Wumpus.Drawing.Dots.Marks import Wumpus.Drawing.Text.LRText -import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Geometry.Intersection       -- package: wumpus-basic+import Wumpus.Basic.Geometry.Paths+import Wumpus.Basic.Geometry.Quadrant+import Wumpus.Basic.Kernel                 import Wumpus.Core                              -- package: wumpus-core @@ -83,8 +84,6 @@                               , radial_anchor   :: Radian   -> Point2 u                               , cardinal_anchor :: Cardinal -> Point2 u } -data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW-  deriving (Eq,Show)   type instance DUnit (DotAnchor u) = u @@ -95,53 +94,53 @@    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) +polyCardinal f NORTH                = f (0.5  * pi)+polyCardinal f NORTH_EAST           = f (0.25 * pi) +polyCardinal f EAST                 = f 0 +polyCardinal f SOUTH_EAST           = f (1.75 * pi) +polyCardinal f SOUTH                = f (1.5  * pi) +polyCardinal f SOUTH_WEST           = f (1.25 * pi)+polyCardinal f WEST                 = f pi +polyCardinal f NORTH_WEST           = f (0.75 * pi)    @@ -151,17 +150,18 @@               , radial_anchor   = fn                 , cardinal_anchor = rectCardinal hw hh ctr }   where-    fn theta =  maybe ctr id $ findIntersect ctr theta -                             $ rectangleLines ctr hw hh+    fn theta =  displaceVec (rectRadialVector hw hh theta) ctr  -polygonAnchor :: (Real u, Floating u) => [Point2 u] -> Point2 u -> DotAnchor u+polygonAnchor :: (Real u, Floating u, FromPtSize u) +              => [Point2 u] -> Point2 u -> DotAnchor u polygonAnchor ps ctr =      DotAnchor { center_anchor   = ctr               , radial_anchor   = fn                 , cardinal_anchor = polyCardinal fn }   where-    fn theta =  maybe ctr id $ findIntersect ctr theta $ polygonLines ps+    fn theta =  maybe ctr id $ findIntersect ctr theta +                             $ polygonLineSegments ps   @@ -217,7 +217,9 @@   dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u -dotText ss = fmap (bimapL bboxRectAnchor) (ctrCenterLine ss)+dotText ss = fmap (bimapL bboxRectAnchor) (textAlignCenter ss)++-- Note - maybe Wumpus-Basic should have a @swapAns@ function?   dotHLine :: (Floating u, FromPtSize u) => DotLocImage u

@@ -50,10 +50,10 @@   ) where  -import Wumpus.Drawing.Geometry.Paths import Wumpus.Drawing.Text.LRText -import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Geometry.Paths              -- package: wumpus-basic+import Wumpus.Basic.Kernel          import Wumpus.Core                              -- package: wumpus-core @@ -89,7 +89,7 @@   markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u-markText ss = fmap (replaceL uNil) $ ctrCenterLine ss+markText ss = fmap (replaceL uNil) $ textAlignCenter ss   @@ -97,7 +97,7 @@ -- | Supplied point is the center. -- axialLine :: Fractional u => Vec2 u -> LocGraphic u-axialLine v = moveStartPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)+axialLine v = moveStart (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)   markHLine :: (Fractional u, FromPtSize u) => LocGraphic u @@ -169,7 +169,7 @@ markSquare :: (Fractional u, FromPtSize u) => LocGraphic u markSquare =      lift0R1 markHeight >>= \h -> -    let d = 0.5*(-h) in moveStartPoint (displace d d) $ strokedRectangle h h+    let d = 0.5*(-h) in moveStart (displace d d) $ strokedRectangle h h       

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

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

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

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Paths--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -11,6 +11,9 @@ -- Portability :  GHC -- -- Shim import module for Paths.+--+-- Note MonadicConstruction is not exported, this module is +-- somewhat out-of-date and needs a re-think. --  -------------------------------------------------------------------------------- @@ -20,12 +23,10 @@     module Wumpus.Drawing.Paths.Base   , module Wumpus.Drawing.Paths.Connectors   , module Wumpus.Drawing.Paths.ControlPoints-  , module Wumpus.Drawing.Paths.MonadicConstruction    ) where  import Wumpus.Drawing.Paths.Base import Wumpus.Drawing.Paths.Connectors import Wumpus.Drawing.Paths.ControlPoints-import Wumpus.Drawing.Paths.MonadicConstruction 

@@ -69,9 +69,8 @@   ) where  -import Wumpus.Drawing.Geometry.Intersection ( langle ) --- package: wumpus-basic+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl                                    , ViewR(..), viewr, cons, snoc, join ) import qualified Wumpus.Basic.Utils.JoinList as JL@@ -79,7 +78,6 @@ import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace-import Data.VectorSpace  import Data.List ( foldl' )  @@ -175,9 +173,9 @@              in Path v p0 (JL.one $ LineSeg v p0 p1) p1     -curve :: (Floating u, Ord u)+curve :: (Floating u, Ord u, FromPtSize u)       => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u -curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3+curve p0 p1 p2 p3 = let v = bezierLength (BezierCurve p0 p1 p2 p3)                     in Path v p0 (JL.one $ CurveSeg v p0 p1 p2 p3) p3  -- | A draw a /straight line/ of length 0 at the supplied point. @@ -209,7 +207,8 @@ -- '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 :: (Floating u, Ord u, FromPtSize u) +                 => [Point2 u] -> Path u traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs   where     step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs@@ -218,7 +217,7 @@ traceCurvePoints _            = error "tracePointsCurve - less than 4 elems."  -curveByAngles :: (Floating u, Ord u) +curveByAngles :: (Floating u, Ord u, FromPtSize u)                => Point2 u -> Radian -> Radian -> Point2 u -> Path u curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end   where@@ -252,75 +251,7 @@   ------------------------------------------------------------------------------------ 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  @@ -372,9 +303,11 @@ 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'+shortenSegL n (CurveSeg u p0 p1 p2 p3)  = CurveSeg (u-n) q0 q1 q2 q3+  where+    (BezierCurve q0 q1 q2 q3) = snd $ subdividet (n/u) +                                                 (BezierCurve p0 p1 p2 p3)+        shortenLineL :: (Real u, Floating u) @@ -419,9 +352,11 @@ 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'+shortenSegR n (CurveSeg u p0 p1 p2 p3)  = CurveSeg (u-n) q0 q1 q2 q3+  where+    (BezierCurve q0 q1 q2 q3) = fst $ subdividet ((u-n)/u) +                                                 (BezierCurve p0 p1 p2 p3)+        shortenLineR :: (Real u, Floating u) @@ -555,14 +490,14 @@ -- longer than half of /d/ (d - being the distance between the  -- /truncated/ points and the corner). ---cornerCurve :: (Real u, Floating u) +cornerCurve :: (Real u, Floating u, FromPtSize u)              => Point2 u -> Point2 u -> Point2 u -> Path u cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3   where     len1 = 0.6 *  (vlength $ pvec p1 p2)     len2 = 0.6 *  (vlength $ pvec p3 p2)-    cp1  = p1 .+^ (avec (langle p1 p2) len1)-    cp2  = p3 .+^ (avec (langle p3 p2) len2)+    cp1  = p1 .+^ (avec (lineAngle p1 p2) len1)+    cp2  = p3 .+^ (avec (lineAngle p3 p2) len2)   -- | 'roundTrail' : @ rounding_distance * [point] -> Path @@@ -580,7 +515,7 @@ -- 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) +roundTrail :: (Real u, Floating u, FromPtSize u)             => u -> [Point2 u] -> Path u  roundTrail _ []             = error "roundTrail - empty list." roundTrail _ [a]            = pathZero a@@ -599,7 +534,7 @@ -- Note - the starting point is moved, this function is for  -- closed, rounded paths. ---lineCurveTrail :: (Real u, Floating u) +lineCurveTrail :: (Real u, Floating u, FromPtSize u)                 => u -> Point2 u -> Point2 u -> Point2 u -> Path u lineCurveTrail u a b c = line p1 p2 `append` cornerCurve p2 b p3   where@@ -620,8 +555,8 @@ -- 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 :: (Real u, Floating u, FromPtSize u) +              => u -> [Point2 u] -> Path u  roundInterior _ []             = error "roundEveryInterior - empty list." roundInterior _ [a]            = pathZero a roundInterior _ [a,b]          = line a b@@ -640,7 +575,7 @@ -- 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) +lineCurveInter1 :: (Real u, Floating u, FromPtSize u)                  => u -> Point2 u -> Point2 u -> Point2 u -> (Path u, Point2 u) lineCurveInter1 u a b c =      (line a p2 `append` cornerCurve p2 b p3, p3)

@@ -184,7 +184,8 @@ -- -- @u@ is the altitude of the triangle. ---connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u +connIsoscelesCurve :: (Real u, Floating u, FromPtSize 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]@@ -196,7 +197,8 @@ -- The two Bezier control points take the /top/ corners. The -- curve tends to be very deep. -- -connSquareCurve :: (Real u, Floating u) => ConnectorPath u +connSquareCurve :: (Real u, Floating u, FromPtSize u) +                => ConnectorPath u  connSquareCurve = promoteR2 $ \ p0 p1 ->     let (cp0,cp1) = squareFromBasePoints p0 p1     in pure $ traceCurvePoints [p0, cp0, cp1, p1]@@ -210,7 +212,8 @@ --  -- (Underneath is modulo the direction, of course). -- -connUSquareCurve :: (Real u, Floating u) => ConnectorPath u +connUSquareCurve :: (Real u, Floating u, FromPtSize u) +                 => ConnectorPath u  connUSquareCurve = promoteR2 $ \ p0 p1 ->      let (cp0,cp1) = usquareFromBasePoints p0 p1     in pure $ traceCurvePoints [p0, cp0, cp1, p1]@@ -220,7 +223,8 @@ -- -- Form a curve inside a trapeziod. -- -connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u +connTrapezoidCurve :: (Real u, Floating u, FromPtSize 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]@@ -229,7 +233,8 @@ -- | Make a curve within a square, following the corner points as -- a Z. ---connZSquareCurve :: (Real u, Floating u) => ConnectorPath u +connZSquareCurve :: (Real u, Floating u, FromPtSize u) +                 => ConnectorPath u  connZSquareCurve = promoteR2 $ \p0 p1 ->      let (cp0,cp1)  = squareFromCornerPoints p0 p1     in pure $ traceCurvePoints [p0,cp0,cp1,p1]@@ -240,7 +245,8 @@ -- The order of tracing flips the control points, so this is an -- /underneath/ version of 'connZSquareCurve'. -- -connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u +connUZSquareCurve :: (Real u, Floating u, FromPtSize u) +                  => ConnectorPath u  connUZSquareCurve = promoteR2 $ \ p0 p1 ->      let (cp0,cp1)  = squareFromCornerPoints p0 p1     in pure $ traceCurvePoints [p0,cp1,cp0,p1]

@@ -127,7 +127,7 @@   -bezierto :: (Floating u, Ord u) +bezierto :: (Floating u, Ord u, FromPtSize 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))@@ -139,7 +139,7 @@ --  -curveto :: (Floating u, Ord u) +curveto :: (Floating u, Ord u, FromPtSize u)          => Radian -> Radian -> Point2 u -> PathM u () curveto cin cout end = PathM $ \(St p0 ac) ->      let seg  = curveByAngles p0 cin cout end 

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

@@ -4,7 +4,7 @@  -------------------------------------------------------------------------------- -- |--- Module      :  Wumpus.Drawing.Shapes.Base2+-- Module      :  Wumpus.Drawing.Shapes.Base -- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 --@@ -21,59 +21,144 @@   (   -    LocShape-  , intoLocShape+    Shape+  , DShape++  , makeShape   , strokedShape   , filledShape   , borderedShape+  , rstrokedShape+  , rfilledShape+  , rborderedShape    , roundCornerShapePath +  , updatePathAngle+  , setDecoration+   , ShapeCTM   , makeShapeCTM   , ctmCenter   , ctmAngle-  , projectPoint-+  , displaceCenter      ) where -import Wumpus.Basic.Kernel 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  -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 u a = Shape +      { shape_ans_fun     :: LocThetaCF u a+      , shape_path_fun    :: LocThetaCF u (Path u) +      , shape_decoration  :: LocThetaGraphic u+      }  -intoLocShape :: LocCF u a -> LocCF u (Path u) -> LocCF u (a,Path u)-intoLocShape = liftA2 (,)+type DShape a = Shape Double a -strokedShape :: Num u => LocShape u a -> LocImage u a-strokedShape mf = -   promoteR1 $ \pt -> -     (mf `at` pt) >>= \(a,spath) -> -     intoImage (pure a) (closedStroke $ toPrimPath spath)+type instance DUnit (Shape u a) = u  -filledShape :: Num u => LocShape u a -> LocImage u a-filledShape mf = -   promoteR1 $ \pt -> -     (mf `at` pt) >>= \(a,spath) -> -     intoImage (pure a) (filledPath $ toPrimPath spath)+-------------------------------------------------------------------------------- +instance Functor (Shape u) where+  fmap f = (\s i -> s { shape_ans_fun = fmap f i }) +             <*> 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 :: Num u => LocThetaCF u a -> LocThetaCF u (Path u) -> Shape u a+makeShape f g = Shape { shape_ans_fun    = f+                      , shape_path_fun   = g+                      , shape_decoration = emptyLocThetaGraphic+                      }+++++strokedShape :: Num u => Shape u a -> LocImage u a+strokedShape = shapeToLoc closedStroke+++filledShape :: Num u => Shape u a -> LocImage u a+filledShape = shapeToLoc filledPath+++borderedShape :: Num u => Shape u a -> LocImage u a+borderedShape = shapeToLoc borderedPath+++shapeToLoc :: Num u +           => (PrimPath u -> Graphic u) -> Shape u a -> LocImage u a+shapeToLoc pathF sh = promoteR1 $ \pt -> +    atRot (shape_ans_fun sh)  pt 0 >>= \a -> +    atRot (shape_path_fun sh) pt 0 >>= \spath -> +    let g1 = pathF $ toPrimPath spath +        g2 = atRot (shape_decoration sh) pt 0 +    in intoImage (pure a) (g1 `oplus` g2)++++rstrokedShape :: Num u => Shape u a -> LocThetaImage u a+rstrokedShape = shapeToLocTheta closedStroke+++rfilledShape :: Num u => Shape u a -> LocThetaImage u a+rfilledShape = shapeToLocTheta filledPath+++rborderedShape :: Num u => Shape u a -> LocThetaImage u a+rborderedShape = shapeToLocTheta borderedPath+++shapeToLocTheta :: Num u +                => (PrimPath u -> Graphic u) -> Shape u a -> LocThetaImage u a+shapeToLocTheta pathF sh = promoteR2 $ \pt theta -> +    atRot (shape_ans_fun sh)  pt theta >>= \a -> +    atRot (shape_path_fun sh) pt theta >>= \spath -> +    let g1 = pathF $ toPrimPath spath +        g2 = atRot (shape_decoration sh) pt theta+    in intoImage (pure a) (g1 `oplus` g2)+++ -- | Draw the shape path with round corners. --  roundCornerShapePath :: (Real u, Floating u, FromPtSize u) @@ -82,8 +167,35 @@     if sz == 0 then return (traceLinePoints xs)                 else return (roundTrail  sz 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 :: (Radian -> Radian) -> Shape u a -> Shape u a+updatePathAngle f = +    (\s i -> s { shape_path_fun = moveTheta (circularModulo . f) i})+      <*> shape_path_fun +setDecoration :: LocThetaGraphic u -> Shape u a -> Shape u a+setDecoration gf = (\s -> s { shape_decoration = gf }) ++++-- For Wumpus-Basic...+-- | Move the /rotation/ of a LocThetaImage with the supplied +-- displacement function.+--+moveTheta :: (Radian -> Radian) -> LocThetaCF u a -> LocThetaCF u a+moveTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta)+++ -------------------------------------------------------------------------------- -- CTM @@ -102,13 +214,11 @@  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 }--+makeShapeCTM :: Num u => 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@@ -141,11 +251,13 @@ ctmAngle = ctm_rotation  --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)-+displaceCenter :: (Real u, Floating u) => Vec2 u -> ShapeCTM u  -> Point2 u+displaceCenter v0 (ShapeCTM { ctm_center   = ctr0+                            , ctm_scale_x  = sx+                            , ctm_scale_y  = sy+                            , ctm_rotation = theta }) = ctr .+^ v+  where+    ctr = rotate theta $ scale sx sy ctr0+    v   = rotateAbout theta ctr $ scale sx sy v0+     +    

@@ -32,7 +32,6 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space   import Control.Applicative @@ -45,49 +44,54 @@       { circ_ctm    :: ShapeCTM u       , circ_radius :: !u        }-  deriving (Eq,Show)    type DCircle = Circle Double  type instance DUnit (Circle u) = u  -+--------------------------------------------------------------------------------+-- Affine trans -mapCircleCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u-mapCircleCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u+mapCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm  instance Num u => Scale (Circle u) where-  scale sx sy = mapCircleCTM (scale sx sy)+  scale sx sy = mapCTM (scale sx sy)   instance Rotate (Circle u) where-  rotate ang = mapCircleCTM (rotate ang)+  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 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 -> Point2 u+runDisplaceCenter fn (Circle { circ_ctm    = ctm+                             , circ_radius = radius }) = +    displaceCenter (fn radius) ctm  + 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 +102,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, FromPtSize u) +       => u -> Shape u (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 :: Num u => u -> LocThetaCF u (Circle u)+mkCircle radius = promoteR2 $ \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, FromPtSize u) +             => u -> LocThetaCF u (Path u)+mkCirclePath radius = promoteR2 $ \ctr _ -> +    pure $ traceCurvePoints $ bezierCircle radius ctr    

@@ -12,7 +12,7 @@ -- Stability   :  highly unstable -- Portability :  GHC ----- Simple shapes - rectangle, circle diamond, ellipse.+-- Diamond (rhombus). --  -------------------------------------------------------------------------------- @@ -26,17 +26,16 @@    ) where -import Wumpus.Drawing.Geometry.Intersection-import Wumpus.Drawing.Geometry.Paths import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Geometry.Quadrant+import Wumpus.Basic.Geometry.Paths+import Wumpus.Basic.Kernel        import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space -import Data.VectorSpace  import Control.Applicative @@ -58,39 +57,63 @@ type instance DUnit (Diamond u) = u  -mapDiamondCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u-mapDiamondCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm+--------------------------------------------------------------------------------+-- Affine trans +mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u+mapCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm+ instance Num u => Scale (Diamond u) where-  scale sx sy = mapDiamondCTM (scale sx sy)+  scale sx sy = mapCTM (scale sx sy)   instance Rotate (Diamond u) where-  rotate ang = mapDiamondCTM (rotate ang)+  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 Num u => Translate (Diamond u) where-  translate dx dy = mapDiamondCTM (translate dx dy)+  translate dx dy = mapCTM (translate dx dy)   -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+--------------------------------------------------------------------------------+-- Anchors +-- | 'runDisplaceCenter' : @ ( half_width +--                           * half_height -> Vec ) * diamond -> Point @+--+runDisplaceCenter :: (Real u, Floating u) +                  => (u -> u -> Vec2 u) -> Diamond u -> Point2 u+runDisplaceCenter fn (Diamond { dia_ctm = ctm+                              , dia_hw = hw+                              , dia_hh = hh }) = +   displaceCenter (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   northeast x = midpoint (north x) (east x)@@ -101,52 +124,34 @@   instance (Real u, Floating u) => RadialAnchor (Diamond u) where-   radialAnchor = diamondIntersect+    radialAnchor ang = runDisplaceCenter $ \hw hh -> +                         diamondRadialVector 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--+--------------------------------------------------------------------------------+-- 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)+        => u -> u -> Shape u (Diamond u)+diamond hw hh = makeShape (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 }+mkDiamond :: Num u => u -> u -> LocThetaCF u (Diamond u)+mkDiamond hw hh = promoteR2 $ \ctr theta -> +    pure $ Diamond { dia_ctm = makeShapeCTM ctr theta+                   , dia_hw  = hw+                   , dia_hh = hh +                   }   mkDiamondPath :: (Real u, Floating u, FromPtSize u) -              => u -> u -> LocCF u (Path u)-mkDiamondPath hw hh = promoteR1 $ \ctr -> -    roundCornerShapePath $ diamondCoordPath hw hh ctr---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 --+              => u -> u -> LocThetaCF u (Path u)+mkDiamondPath hw hh = promoteR2 $ \ctr theta -> +    roundCornerShapePath $ map (rotateAbout theta ctr) +                         $ diamondCoordPath hw hh ctr

@@ -35,7 +35,6 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space   import Control.Applicative @@ -57,7 +56,8 @@  type instance DUnit (Ellipse u) = u -+--------------------------------------------------------------------------------+-- Affine trans  mapEllipseCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u mapEllipseCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm@@ -78,11 +78,17 @@   translate dx dy = mapEllipseCTM (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 +runDisplaceCenter :: (Real u, Floating u) +                  => (u -> u -> Vec2 u) -> Ellipse u -> Point2 u+runDisplaceCenter fn (Ellipse { ell_ctm = ctm+                       , ell_rx  = rx+                       , ell_ry  = ry }) = +    displaceCenter (fn rx ry) ctm + -- | x_radius is the unit length. -- scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t@@ -90,12 +96,12 @@   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 +118,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, FromPtSize u, Ord u) +        => u -> u -> Shape u (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 :: Num u => u -> u -> LocThetaCF u (Ellipse u)+mkEllipse rx ry = promoteR2 $ \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, FromPtSize u, Ord u) +              => u -> u -> LocThetaCF u (Path u)+mkEllipsePath rx ry = promoteR2 $ \pt theta -> +    pure $ traceCurvePoints $ map (rotateAbout theta pt) +                            $ bezierEllipse rx ry pt 

@@ -0,0 +1,121 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# 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 DInvSemicircle = InvSemicircle Double++type instance DUnit (InvSemicircle u) = u+++--------------------------------------------------------------------------------+-- Affine trans++mapSemicircle :: (Semicircle u -> Semicircle u) +              -> InvSemicircle u +              -> InvSemicircle u+mapSemicircle f = InvSemicircle . f . getInvSemicircle++instance Num u => Scale (InvSemicircle u) where+  scale sx sy = mapSemicircle (scale sx sy)+++instance Rotate (InvSemicircle u) where+  rotate ang = mapSemicircle (rotate ang)+                  ++instance (Real u, Floating u) => RotateAbout (InvSemicircle u) where+  rotateAbout ang pt = mapSemicircle (rotateAbout ang pt)+++instance Num u => Translate (InvSemicircle u) where+  translate dx dy = mapSemicircle (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors++runRotateAnchor :: (Real u, Floating u) +                => (Semicircle u -> Point2 u) -> InvSemicircle u -> Point2 u+runRotateAnchor f (InvSemicircle a) = rotateAbout pi (center a) (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, FromPtSize u) => +    CardinalAnchor2 (InvSemicircle u) where+  northeast = runRotateAnchor southwest+  southeast = runRotateAnchor northwest+  southwest = runRotateAnchor northeast+  northwest = runRotateAnchor southeast++++instance (Real u, Floating u, FromPtSize u) => +    RadialAnchor (InvSemicircle u) where+  radialAnchor theta = +    runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)+++--------------------------------------------------------------------------------+-- Construction++-- | 'invsemicircle'  : @ radius -> Shape @+--+invsemicircle :: (Real u, Floating u, FromPtSize u) +           => u -> Shape u (InvSemicircle u)+invsemicircle radius = +    fmap InvSemicircle $ updatePathAngle (+ pi) $ semicircle radius

@@ -0,0 +1,123 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# 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 DInvSemiellipse = InvSemiellipse Double++type instance DUnit (InvSemiellipse u) = u+++--------------------------------------------------------------------------------+-- Affine trans++mapSemiellipse :: (Semiellipse u -> Semiellipse u) +              -> InvSemiellipse u +              -> InvSemiellipse u+mapSemiellipse f = InvSemiellipse . f . getInvSemiellipse++instance Num u => Scale (InvSemiellipse u) where+  scale sx sy = mapSemiellipse (scale sx sy)+++instance Rotate (InvSemiellipse u) where+  rotate ang = mapSemiellipse (rotate ang)+                  ++instance (Real u, Floating u) => RotateAbout (InvSemiellipse u) where+  rotateAbout ang pt = mapSemiellipse (rotateAbout ang pt)+++instance Num u => Translate (InvSemiellipse u) where+  translate dx dy = mapSemiellipse (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors++runRotateAnchor :: (Real u, Floating u) +                => (Semiellipse u -> Point2 u) -> InvSemiellipse u -> Point2 u+runRotateAnchor f (InvSemiellipse a) = rotateAbout pi (center a) (f a)+++instance (Real u, Floating u) => CenterAnchor (InvSemiellipse u) where+  center = center . getInvSemiellipse++instance (Real u, Floating u, FromPtSize u) => +    ApexAnchor (InvSemiellipse u) where+  apex = runRotateAnchor apex++instance (Real u, Floating u) => TopCornerAnchor (InvSemiellipse u) where+  topLeftCorner  = runRotateAnchor bottomRightCorner+  topRightCorner = runRotateAnchor bottomLeftCorner++instance (Real u, Floating u, FromPtSize u) => +    CardinalAnchor (InvSemiellipse u) where+  north = runRotateAnchor south+  south = runRotateAnchor north+  east  = runRotateAnchor west+  west  = runRotateAnchor east+++instance (Real u, Floating u, FromPtSize u) => +    CardinalAnchor2 (InvSemiellipse u) where+  northeast = runRotateAnchor southwest+  southeast = runRotateAnchor northwest+  southwest = runRotateAnchor northeast+  northwest = runRotateAnchor southeast++++instance (Real u, Floating u, FromPtSize u) => +    RadialAnchor (InvSemiellipse u) where+  radialAnchor theta = +    runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)+++--------------------------------------------------------------------------------+-- Construction++-- | 'invsemiellipse'  : @ rx * ry -> Shape @+--+invsemiellipse :: (Real u, Floating u, FromPtSize u) +           => u -> u -> Shape u (InvSemiellipse u)+invsemiellipse rx ry = +    fmap InvSemiellipse $ updatePathAngle (+ pi) $ semiellipse rx ry

@@ -0,0 +1,147 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# 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.Shapes.Base+import Wumpus.Drawing.Shapes.Triangle++import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core+++++++-- Datatype++newtype InvTriangle u = InvTriangle { getInvTriangle :: Triangle u }++++type DInvTriangle = InvTriangle Double++type instance DUnit (InvTriangle u) = u+++--------------------------------------------------------------------------------+-- Affine trans++mapTriangle :: (Triangle u -> Triangle u) -> InvTriangle u -> InvTriangle u+mapTriangle f = InvTriangle . f . getInvTriangle +++instance Num u => Scale (InvTriangle u) where+  scale sx sy = mapTriangle (scale sx sy)+++instance Rotate (InvTriangle u) where+  rotate ang = mapTriangle (rotate ang)+                  ++instance (Real u, Floating u) => RotateAbout (InvTriangle u) where+  rotateAbout ang pt = mapTriangle (rotateAbout ang pt)+++instance Num u => Translate (InvTriangle u) where+  translate dx dy = mapTriangle (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors++-- I think anchors should be rotated about the center by pi...++runRotateAnchor :: (Real u, Floating u) +                => (Triangle u -> Point2 u) -> InvTriangle u -> Point2 u+runRotateAnchor f (InvTriangle a) = rotateAbout pi (center a) (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) => CardinalAnchor2 (InvTriangle u) where+  northeast = runRotateAnchor southwest+  southeast = runRotateAnchor northwest+  southwest = runRotateAnchor northeast+  northwest = runRotateAnchor southeast++++instance (Real u, Floating u) => RadialAnchor (InvTriangle u) where+  radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)++--------------------------------------------------------------------------------+-- Construction++-- | 'invtriangle'  : @ top_base_width * height -> Triangle @+--+--+invtriangle :: (Real u, Floating u, FromPtSize u)+            => u -> u -> Shape u (InvTriangle u)+invtriangle bw h = fmap InvTriangle $ updatePathAngle (+ pi) $ triangle bw h+    +++

@@ -0,0 +1,269 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# 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.Paths+import Wumpus.Drawing.Shapes.Base++import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Geometry.Intersection+import Wumpus.Basic.Geometry.Paths+import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative+++++--------------------------------------------------------------------------------+-- Parallelogram++-- | A Paralleogram.+--+data Parallelogram u = Parallelogram +      { pll_ctm         :: ShapeCTM u+      , pll_base_width  :: !u+      , pll_height      :: !u+      , pll_base_l_ang  :: Radian+      , pll_syn_props   :: SyntheticProps u+      }+++-- | Note (center) is a line dropped from the center of the+-- paralleogram.+-- +-- > base_minor is the (center) to left corner.+-- > base_major is the (center) to right corner.+--+data SyntheticProps u = SyntheticProps+      { pll_base_minor  :: u+      , pll_base_major  :: u+      }+++type DParallelogram = Parallelogram Double++type instance DUnit (Parallelogram u) = u+++++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Parallelogram u -> Parallelogram u+mapCTM f = (\s i -> s { pll_ctm = f i }) <*> pll_ctm++instance Num u => Scale (Parallelogram u) where+  scale sx sy = mapCTM (scale sx sy)+++instance 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 Num u => Translate (Parallelogram u) where+  translate dx dy = mapCTM (translate dx dy)++--------------------------------------------------------------------------------+-- Anchors++-- | 'runDisplaceCenter' : @ ( half_base_width+--                           * half_height +--                           * base_minor+--                           * base_major -> Vec ) * parallelogram -> Point @+--+runDisplaceCenter :: (Real u, Floating u)+                  => (u -> u -> u -> u -> Vec2 u) -> Parallelogram u -> Point2 u+runDisplaceCenter fn (Parallelogram { pll_ctm        = ctm+                                    , pll_base_width = bw+                                    , pll_height     = h  +                                    , pll_syn_props  = syn }) = +    displaceCenter (fn (0.5 * bw) (0.5 * h) +                       (pll_base_minor syn) (pll_base_major syn)) ctm++++instance (Real u, Floating u) => CenterAnchor (Parallelogram u) where+  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0++-- top anchors swap the base minor and major...+--+instance (Real u, Floating u) => TopCornerAnchor (Parallelogram u) where+  topLeftCorner  = runDisplaceCenter $ \_ hh _ bmaj -> V2 (-bmaj) hh+  topRightCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 bmin    hh++instance (Real u, Floating u) => BottomCornerAnchor (Parallelogram u) where+  bottomLeftCorner  = runDisplaceCenter $ \_ hh bmin _ -> V2 (-bmin) (-hh)+  bottomRightCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 bmaj    (-hh)++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) => CardinalAnchor (Parallelogram u) where+  north = runDisplaceCenter $ \_  hh _ _ -> V2 0 hh+  south = runDisplaceCenter $ \_  hh _ _ -> V2 0 (-hh)+  east  = runDisplaceCenter $ \hw _  _ _ -> V2 hw 0+  west  = runDisplaceCenter $ \hw _  _ _ -> V2 (-hw) 0+++instance (Real u, Floating u, FromPtSize u) => +    CardinalAnchor2 (Parallelogram u) where+  northeast = pllRadialAnchor (0.25*pi)+  southeast = pllRadialAnchor (1.75*pi)+  southwest = pllRadialAnchor (1.25*pi)+  northwest = pllRadialAnchor (0.75*pi)++++instance (Real u, Floating u, FromPtSize u) => +     RadialAnchor (Parallelogram u) where+   radialAnchor = pllRadialAnchor+++-- TODO - update this to a quadrant function...+--+pllRadialAnchor :: (Real u, Floating u, FromPtSize u) +                => Radian -> Parallelogram u -> Point2 u+pllRadialAnchor theta (Parallelogram { pll_ctm       = ctm+                                     , pll_height    = h+                                     , pll_syn_props = syn }) =+    post $ findIntersect zeroPt theta $ polygonLineSegments ps+  where +    ps   = pllPoints (pll_base_minor syn) (pll_base_major syn) h+    post = \ans -> case ans of +                    Nothing       -> displaceCenter (V2 0 0) ctm+                    Just (P2 x y) -> displaceCenter (V2 x y) ctm+    ++--------------------------------------------------------------------------------+-- Construction+++-- | 'parallelogram'  : @ width * height * bottom_left_ang -> Parallelogram @+--+--+parallelogram :: (Real u, Floating u, FromPtSize u) +              => u -> u -> Radian -> Shape u (Parallelogram u)+parallelogram bw h lang =+    let props = synthesizeProps bw h lang +    in makeShape (mkParallelogram bw h lang props) +                 (mkParallelogramPath (pll_base_minor props) +                                      (pll_base_major props) h)+++-- | 'zparallelogram'  : @ base_width * height -> Parallelogram @+--+--+zparallelogram :: (Real u, Floating u, FromPtSize u) +              => u -> u -> Shape u (Parallelogram u)+zparallelogram bw h = parallelogram bw h ang+  where+    ang = d2r (60::Double)+++--------------------------------------------------------------------------------+++mkParallelogram :: (Real u, Fractional u) +                => u -> u -> Radian -> SyntheticProps u +                -> LocThetaCF u (Parallelogram u)+mkParallelogram bw h lang props = promoteR2 $ \ctr theta -> +    pure $ Parallelogram { pll_ctm          = makeShapeCTM ctr theta+                         , pll_base_width   = bw+                         , pll_height       = h+                         , pll_base_l_ang   = lang+                         , pll_syn_props    = props+                         }++-- Note - expects ang value 0 < ang < 180, though does not check...+-- +synthesizeProps :: Fractional u => u -> u -> Radian -> SyntheticProps u+synthesizeProps bw h lang +    | lang == 0.5*pi = let hw = 0.5 * bw in SyntheticProps hw hw+    | lang >  0.5*pi = less_ninety+    | otherwise      = grtr_ninety+  where+    less_ninety = let extw            = h / (fromRadian $ tan lang)+                      half_rect_width = 0.5 * (bw + extw)+                  in SyntheticProps half_rect_width (half_rect_width - extw)++    grtr_ninety = let extw            = h / (fromRadian $ tan (pi-lang))+                      half_rect_width = 0.5 * (bw + extw)+                  in SyntheticProps (half_rect_width - extw) half_rect_width++                       ++++mkParallelogramPath :: (Real u, Floating u, FromPtSize u) +                    => u -> u -> u -> LocThetaCF u (Path u)+mkParallelogramPath bw_minor bw_major h = promoteR2 $ \ctr theta -> +    roundCornerShapePath $ map (rotateAbout theta ctr) +                         $ pllPath bw_minor bw_major h ctr+++pllPath :: (Real u, Floating u) +       => u -> u -> u -> LocCoordPath u+pllPath bw_minor bw_major h (P2 x y) = [ bl, br, tr, tl ]+  where+    hh = 0.5 * h+    bl = P2 (x - bw_minor) (y - hh)+    br = P2 (x + bw_major) (y - hh)+    tl = P2 (x - bw_major) (y + hh)     -- topleft subtracts major+    tr = P2 (x + bw_minor) (y + hh)     -- topright adds minor+++pllPoints :: (Real u, Floating u) +          => u -> u -> u -> [Point2 u]+pllPoints bw_minor bw_major h = [ bl, br, tr, tl ]+  where+    hh = 0.5 * h     +    bl = P2 (-bw_minor) (-hh) +    br = P2   bw_major  (-hh)+    tl = P2 (-bw_major) hh+    tr = P2   bw_minor  hh++++

@@ -13,6 +13,9 @@ -- Portability :  GHC -- -- Rectangle shape.+--+-- Note - CardinalAnchor2 (northeast etc.) point to their radial +-- positions (this is a change since earlier versions). --  -------------------------------------------------------------------------------- @@ -25,12 +28,12 @@    ) where -import Wumpus.Drawing.Geometry.Intersection-import Wumpus.Drawing.Geometry.Paths import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Geometry.Paths              -- package: wumpus-basic+import Wumpus.Basic.Geometry.Quadrant+import Wumpus.Basic.Kernel  import Wumpus.Core                              -- package: wumpus-core @@ -39,8 +42,7 @@   ------------------------------------------------------------------------------------ Rectangle+-- Data type  data Rectangle u = Rectangle        { rect_ctm    :: ShapeCTM u@@ -55,82 +57,109 @@ type instance DUnit (Rectangle u) = u  -mapRectangleCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u-mapRectangleCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm+--------------------------------------------------------------------------------+-- Affine trans +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)+  scale sx sy = mapCTM (scale sx sy)   instance Rotate (Rectangle u) where-  rotate ang = mapRectangleCTM (rotate ang)+  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 Num u => Translate (Rectangle u) where-  translate dx dy = mapRectangleCTM (translate dx dy)+  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 -> Point2 u+runDisplaceCenter fn (Rectangle { rect_ctm = ctm+                                , rect_hw  = hw+                                , rect_hh  = hh }) = +   displaceCenter (fn hw hh) ctm + instance (Real u, Floating u) => CenterAnchor (Rectangle u) where-  center = runRectangle (\ _ _ -> ctmCenter)+  center = runDisplaceCenter $ \_ _ -> V2 0 0 +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) => 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++ 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+  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) => 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+  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) => RadialAnchor (Rectangle u) where-  radialAnchor theta = runRectangle $ \hw hh -> -    projectPoint $ rectangleIntersect hw hh theta+  radialAnchor theta = runDisplaceCenter $ \hw hh -> +                          rectRadialVector hw hh theta --- 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   +--------------------------------------------------------------------------------+-- Construction + -- | 'rectangle'  : @ width * height -> shape @ -- rectangle :: (Real u, Floating u, FromPtSize u) -          => u -> u -> LocShape u (Rectangle u)+          => u -> u -> Shape u (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 :: Num u => u -> u -> LocThetaCF u (Rectangle u)+mkRectangle hw hh = promoteR2 $ \ctr theta -> +    pure $ Rectangle { rect_ctm    = makeShapeCTM ctr theta                      , rect_hw     = hw                      , rect_hh     = hh                      }   mkRectPath :: (Real u, Floating u, FromPtSize u) -           => u -> u -> LocCF u (Path u)-mkRectPath hw hh = promoteR1 $ \ctr -> +           => u -> u -> LocThetaCF u (Path u)+mkRectPath hw hh = promoteR2 $ \ctr theta ->      let btm_left = displace (-hw) (-hh) ctr-    in roundCornerShapePath $ rectangleCoordPath (2*hw) (2*hh) btm_left+    in roundCornerShapePath $ map (rotateAbout theta ctr)+                            $ rectangleCoordPath (2*hw) (2*hh) btm_left       

@@ -0,0 +1,235 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# 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.Paths+import Wumpus.Drawing.Shapes.Base++import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Geometry.Intersection+import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++import Control.Applicative++++--------------------------------------------------------------------------------+-- Datatype++data Semicircle u = Semicircle +      { sc_ctm          :: ShapeCTM u+      , sc_radius       :: !u +      , sc_syn_props    :: SyntheticProps u+      }++++-- | rect_width is the width of the (greater) enclosing rectangle.+data SyntheticProps u = SyntheticProps+      { sc_ctr_minor  :: u+      , sc_ctr_major  :: u+      }+  +type DSemicircle = Semicircle Double++type instance DUnit (Semicircle u) = u+++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semicircle u -> Semicircle u+mapCTM f = (\s i -> s { sc_ctm = f i }) <*> sc_ctm++instance Num u => Scale (Semicircle u) where+  scale sx sy = mapCTM (scale sx sy)+++instance 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 Num 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 -> u -> u -> Vec2 u) -> Semicircle u -> Point2 u+runDisplaceCenter fn (Semicircle { sc_ctm       = ctm+                                 , sc_radius    = radius+                                 , sc_syn_props = syn    }) = +    displaceCenter (fn radius (sc_ctr_minor syn) (sc_ctr_major syn)) 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 $ \_ _    cmaj -> V2 0  cmaj++instance (Real u, Floating u) => BottomCornerAnchor (Semicircle u) where+  bottomLeftCorner  = runDisplaceCenter $ \r hminor _  -> V2 (-r) (-hminor)+  bottomRightCorner = runDisplaceCenter $ \r hminor _  -> V2  r   (-hminor)++instance (Real u, Floating u) => CardinalAnchor (Semicircle u) where+  north = apex+  south = runDisplaceCenter $ \_ cmin _    -> V2 0  (-cmin)+  east  = runDisplaceCenter $ \r cmin _    -> let x = pyth r cmin in V2 x 0+  west  = runDisplaceCenter $ \r cmin _    -> let x = pyth r cmin in V2 (-x) 0++-- | 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, FromPtSize 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, FromPtSize u) => RadialAnchor (Semicircle u) where+  radialAnchor theta = runDisplaceCenter (scRadialVec theta)+++scRadialVec :: (Real u, Floating u, Ord u, FromPtSize u)+            => Radian -> u -> u -> u -> Vec2 u+scRadialVec theta radius hminor _ = go theta+  where+    (lang,rang)                     = baselineRange radius hminor+    (bctr, br, _, bl)               = constructionPoints radius hminor+    plane                           = makePlane zeroPt theta+    base_line                       = LineSegment bl br+    left_curve                      = mkCurve radius half_pi bctr+    right_curve                     = mkCurve radius 0 bctr+    post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)+    go a | lang <= a && a <= rang   = post $ interLinesegLine base_line plane +         | half_pi <= a && a < lang = post $ interCurveLine left_curve plane+         | otherwise                = post $ interCurveLine right_curve plane+++mkCurve :: Floating u => u -> Radian -> Point2 u -> BezierCurve u+mkCurve radius theta ctr = BezierCurve p0 p1 p2 p3+  where+    (BezierCurve p0 p1 p2 p3) = bezierMinorArc half_pi radius theta ctr++++-- | 'constructionPoints' : @ radius * hminor -> +--     (base_ctr, base_right, apex, base_left) @+--+-- Assumes centroid is (0,0).+--+constructionPoints :: Num u +                   => u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)+constructionPoints radius hminor = (bctr, br, apx, bl)+  where+    bctr  = P2 0 (-hminor)+    br    = bctr .+^ hvec radius+    apx   = bctr .+^ vvec radius+    bl    = bctr .-^ hvec radius+++++-- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @+--+-- Find the angle range where a ray from the centroid will cross+-- the baseline rather than cut the curve.+--+baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)+baselineRange radius hminor = (lang, rang)+  where+    ang   = toRadian $ atan (radius / hminor)+    lang  = (1.5*pi) - ang+    rang  = (1.5*pi) + ang++--------------------------------------------------------------------------------+-- Construction++-- | 'semicircle'  : @ radius -> Shape @+--+semicircle :: (Real u, Floating u, FromPtSize u) +           => u -> Shape u (Semicircle u)+semicircle radius = +    let props = synthesizeProps radius+    in makeShape (mkSemicircle radius props) +                 (mkSemicirclePath radius (sc_ctr_minor props))+          ++synthesizeProps :: Floating u => u -> SyntheticProps u+synthesizeProps radius = +    SyntheticProps { sc_ctr_minor  = cminor+                   , sc_ctr_major  = cmajor+                   }+  where+    cminor = (4 * radius) / (3 * pi)+    cmajor = radius - cminor+++mkSemicircle :: Num u => u -> SyntheticProps u -> LocThetaCF u (Semicircle u)+mkSemicircle radius props = promoteR2 $ \ctr theta -> +    pure $ Semicircle { sc_ctm = makeShapeCTM ctr theta+                      , sc_radius = radius+                      , sc_syn_props = props +                      }++++-- TODO - need to check other shapes to see if the are deriving +-- the center properly...+--+mkSemicirclePath :: (Real u, Floating u, FromPtSize u) +                 => u -> u -> LocThetaCF u (Path u)+mkSemicirclePath radius cminor = promoteR2 $ \pt theta ->+    let ctr = displacePerpendicular (-cminor) theta pt+    in pure $ traceCurvePoints $ bezierArcPoints pi radius theta ctr +

@@ -0,0 +1,265 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# 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.Paths+import Wumpus.Drawing.Shapes.Base++import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Geometry.Intersection+import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative++++--------------------------------------------------------------------------------+-- Datatype++data Semiellipse u = Semiellipse +      { se_ctm          :: ShapeCTM u+      , se_rx           :: !u +      , se_ry           :: !u+      , se_syn_props    :: SyntheticProps u+      }++++-- | rect_width is the width of the (greater) enclosing rectangle.+data SyntheticProps u = SyntheticProps+      { se_ry_minor  :: u+      , se_ry_major  :: u+      }+  +type DSemiellipse = Semiellipse Double++type instance DUnit (Semiellipse u) = u+++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semiellipse u -> Semiellipse u+mapCTM f = (\s i -> s { se_ctm = f i }) <*> se_ctm++instance Num u => Scale (Semiellipse u) where+  scale sx sy = mapCTM (scale sx sy)+++instance 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 Num 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 -> u -> u -> Vec2 u) -> Semiellipse u -> Point2 u+runDisplaceCenter fn (Semiellipse { se_ctm       = ctm+                                  , se_rx        = rx+                                  , se_ry        = ry+                                  , se_syn_props = syn    }) = +    displaceCenter (fn rx ry (se_ry_minor syn) (se_ry_major syn)) ctm+++++instance (Real u, Floating u) => CenterAnchor (Semiellipse u) where+  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0++instance (Real u, Floating u, FromPtSize u) => +    ApexAnchor (Semiellipse u) where+  apex = runDisplaceCenter $ \_ _ _ ry_major -> V2 0 ry_major++instance (Real u, Floating u) => BottomCornerAnchor (Semiellipse u) where+  bottomLeftCorner  = runDisplaceCenter $ \rx _ ry_minor _  -> V2 (-rx) (-ry_minor)+  bottomRightCorner = runDisplaceCenter $ \rx _ ry_minor _  -> V2  rx   (-ry_minor)+++instance (Real u, Floating u, FromPtSize u) => +    CardinalAnchor (Semiellipse u) where+  north = apex+  south = runDisplaceCenter $ \_ _ ry_minor _ -> V2 0 (-ry_minor)+  east  = radialAnchor 0+  west  = radialAnchor pi++instance (Real u, Floating u, FromPtSize 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, FromPtSize u) => RadialAnchor (Semiellipse u) where+  radialAnchor theta = runDisplaceCenter (seRadialVec theta)+++seRadialVec :: (Real u, Floating u, Ord u, FromPtSize u)+            => Radian -> u -> u -> u -> u -> Vec2 u+seRadialVec theta rx ry hminor _ = go theta+  where+    (lang,rang)                     = baselineRange rx hminor+    (bctr, br, _, bl)               = constructionPoints rx ry hminor+    plane                           = makePlane zeroPt theta+    base_line                       = LineSegment bl br+    (right_curve,left_curve)        = bezierSemiellipse rx ry bctr+    post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)+    go a | lang <= a && a <= rang   = post $ interLinesegLine base_line plane +         | half_pi <= a && a < lang = post $ interCurveLine left_curve plane+         | otherwise                = post $ interCurveLine right_curve plane++++-- | 'constructionPoints' : @ rx * ry * hminor -> +--     (base_ctr, base_right, apex, base_left) @+--+-- Assumes centroid is (0,0).+--+constructionPoints :: Num u +                   => u -> u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)+constructionPoints rx ry hminor = (bctr, br, apx, bl)+  where+    bctr  = P2 0 (-hminor)+    br    = bctr .+^ hvec rx+    apx   = bctr .+^ vvec ry+    bl    = bctr .+^ hvec (-rx)+++++-- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @+--+-- Find the angle range where a ray from the centroid will cross+-- the baseline rather than cut the curve.+--+baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)+baselineRange rx hminor = (lang, rang)+  where+    ang   = toRadian $ atan (rx / hminor)+    lang  = (1.5*pi) - ang+    rang  = (1.5*pi) + ang++++--------------------------------------------------------------------------------+-- Construction+++-- | 'semiellipse'  : @ x_radius * y_radius -> Shape @+--+semiellipse :: (Real u, Floating u, FromPtSize u) +            => u -> u -> Shape u (Semiellipse u)+semiellipse rx ry = +    let props = synthesizeProps ry+    in makeShape (mkSemiellipse rx ry props) +                 (mkSemiellipsePath rx ry (se_ry_minor props))+          +++synthesizeProps :: Floating u => u -> SyntheticProps u+synthesizeProps ry = +    SyntheticProps { se_ry_minor  = ry_minor+                   , se_ry_major  = ry_major+                   }+  where+    ry_minor = (4 * ry) / (3 * pi)+    ry_major = ry - ry_minor+++mkSemiellipse :: Num u +              => u -> u -> SyntheticProps u -> LocThetaCF u (Semiellipse u)+mkSemiellipse rx ry props = promoteR2 $ \ctr theta -> +    pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta+                       , se_rx = rx+                       , se_ry = ry+                       , se_syn_props = props +                       }+++mkSemiellipsePath :: (Real u, Floating u, FromPtSize u) +                  => u -> u -> u -> LocThetaCF u (Path u)+mkSemiellipsePath rx ry cminor = promoteR2 $ \pt theta ->+    let ctr = displacePerpendicular (-cminor) theta pt+    in pure $ traceCurvePoints $ map (rotateAbout theta ctr)+                               $ bezierSemiellipsePoints rx ry ctr+++bezierSemiellipsePoints :: Floating u+                        => u -> u -> Point2 u -> [Point2 u]+bezierSemiellipsePoints rx ry pt = [ p0, c1,c2,p3, c4,c5,p6 ]+  where +    (BezierCurve p0 c1 c2 p3, BezierCurve _ c4 c5 p6) = bezierSemiellipse rx ry pt+++-- For Geometry?++-- | Generate the bezier arcs for quadrants I and II. +--+-- Drawing is expected to proceed CCW.+-- +-- Note - Point is the (full) ellipse center.+--+bezierSemiellipse :: Floating u+                  => u -> u -> Point2 u -> (BezierCurve u, BezierCurve u)+bezierSemiellipse rx ry (P2 x y) = +    (BezierCurve p00 c01 c02 p03, BezierCurve p03 c04 c05 p06)+  where+    lrx = rx * kappa+    lry = ry * kappa+    p00 = P2 (x + rx) y+    c01 = p00 .+^ vvec lry+    c02 = p03 .+^ hvec lrx++    p03 = P2 x (y + ry) +    c04 = p03 .+^ hvec (-lrx)+    c05 = p06 .+^ vvec lry++    p06 = P2 (x - rx) y++++kappa :: Floating u => u+kappa = 4 * ((sqrt 2 - 1) / 3)

@@ -0,0 +1,281 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# 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+--+-- Trapezium.+--+-- Note cardinal anchors correspond directly to the compass +-- positions.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Shapes.Trapezium+  ( ++    Trapezium+  , DTrapezium+  , trapezium+  , ztrapezium+++  ) where++import Wumpus.Drawing.Paths+import Wumpus.Drawing.Shapes.Base++import Wumpus.Basic.Geometry.Intersection       -- package: wumpus-basic+import Wumpus.Basic.Geometry.Paths+import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core+++import Data.VectorSpace                         -- package: vector-space++import Control.Applicative+++++--------------------------------------------------------------------------------+-- Trapezium++-- | A trapezium.+--+data Trapezium u = Trapezium +      { tz_ctm          :: ShapeCTM u+      , tz_base_width   :: !u+      , tz_height       :: !u+      , tz_base_l_ang   :: Radian+      , tz_base_r_ang   :: Radian+      }+++type DTrapezium = Trapezium Double++type instance DUnit (Trapezium u) = u+++--------------------------------------------------------------------------------+-- Affine trans++mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Trapezium u -> Trapezium u+mapCTM f = (\s i -> s { tz_ctm = f i }) <*> tz_ctm++instance Num u => Scale (Trapezium u) where+  scale sx sy = mapCTM (scale sx sy)+++instance 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 Num u => Translate (Trapezium u) where+  translate dx dy = mapCTM (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors++-- | 'runDisplaceCenter' : @ ( half_base_width +--                           * half_height+--                           * left_base_ang +--                           * right_base_ang -> Vec ) * trapzium -> Point @+--+runDisplaceCenter :: (Real u, Floating u)+                  => (u -> u -> Radian -> Radian -> Vec2 u) +                  -> Trapezium u -> Point2 u+runDisplaceCenter fn (Trapezium { tz_ctm          = ctm+                                , tz_base_width   = bw+                                , tz_height       = h+                                , tz_base_l_ang   = lang+                                , tz_base_r_ang   = rang }) =+    displaceCenter (fn (0.5 * bw) (0.5 * h) lang rang) 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  = runDisplaceCenter $ \hbw hh _ _  -> V2 (-hbw) (-hh)+  bottomRightCorner = runDisplaceCenter $ \hbw hh _ _  -> V2  hbw   (-hh)+++instance (Real u, Floating u) => TopCornerAnchor (Trapezium u) where+  topLeftCorner  = runDisplaceCenter $ \hbw hh lang _  -> +                     let vbase = V2 (-hbw) (-hh)+                         vup   = leftSideVec (2*hh) lang +                     in vbase ^+^ vup+  topRightCorner = runDisplaceCenter $ \hbw hh _ rang  ->+                     let vbase = V2  hbw   (-hh)+                         vup   = rightSideVec (2*hh) rang+                     in vbase ^+^ vup+++instance (Real u, Floating u, FromPtSize 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, FromPtSize u) => +    CardinalAnchor (Trapezium u) where+  north = runDisplaceCenter $ \_ hh _ _ -> V2 0 hh+  south = runDisplaceCenter $ \_ hh _ _ -> V2 0 (-hh)+  east  = tzRadialAnchor 0+  west  = tzRadialAnchor pi+++instance (Real u, Floating u, FromPtSize u) => +    CardinalAnchor2 (Trapezium u) where+  northeast = tzRadialAnchor (0.25*pi)+  southeast = tzRadialAnchor (1.75*pi)+  southwest = tzRadialAnchor (1.25*pi)+  northwest = tzRadialAnchor (0.75*pi)++++instance (Real u, Floating u, FromPtSize u) => +    RadialAnchor (Trapezium u) where+  radialAnchor = tzRadialAnchor++-- TODO - update this to a quadrant function...+--+tzRadialAnchor :: (Real u, Floating u, FromPtSize u) +               => Radian -> Trapezium u -> Point2 u+tzRadialAnchor theta (Trapezium { tz_ctm        = ctm+                                , tz_base_width = bw+                                , tz_height     = h+                                , tz_base_l_ang = lang+                                , tz_base_r_ang = rang }) =+    post $ findIntersect zeroPt theta $ polygonLineSegments ps+  where +    ps   = tzPoints bw h lang rang+    post = \ans -> case ans of +                    Nothing       -> displaceCenter (V2 0 0) ctm+                    Just (P2 x y) -> displaceCenter (V2 x y) ctm+    +    +--------------------------------------------------------------------------------+-- Construction+++-- | 'trapezium'  : @ base_width * height * bottom_left_ang * +--     bottom_right_ang -> Shape @+--+--+trapezium :: (Real u, Floating u, FromPtSize u) +          => u -> u -> Radian -> Radian -> Shape u (Trapezium u)+trapezium bw h lang rang = +    makeShape (mkTrapezium bw h lang rang) (mkTrapeziumPath bw h lang rang)+++-- | 'ztrapezium'  : @ base_width * height -> Trapezium @+--+--+ztrapezium :: (Real u, Floating u, FromPtSize u) +           => u -> u -> Shape u (Trapezium u)+ztrapezium bw h = trapezium bw h ang ang+  where+    ang = d2r (60::Double)+++--------------------------------------------------------------------------------+++mkTrapezium :: (Real u, Fractional u) +            => u -> u -> Radian -> Radian -> LocThetaCF u (Trapezium u)+mkTrapezium bw h lang rang = promoteR2 $ \ctr theta -> +    pure $ Trapezium { tz_ctm           = makeShapeCTM ctr theta+                     , tz_base_width    = bw+                     , tz_height        = h+                     , tz_base_l_ang    = lang+                     , tz_base_r_ang    = rang+                     }+++mkTrapeziumPath :: (Real u, Floating u, FromPtSize u) +                => u -> u -> Radian -> Radian -> LocThetaCF u (Path u)+mkTrapeziumPath bw h lang rang = promoteR2 $ \ctr theta -> +    roundCornerShapePath $ map (rotateAbout theta ctr) +                         $ tzPath bw h lang rang ctr+++tzPath :: (Real u, Floating u) +       => u -> u -> Radian -> Radian -> LocCoordPath u+tzPath bw h lang rang (P2 x y) = [ bl, br, tr, tl ]+  where+    half_base = 0.5 * bw+    hh        = 0.5 * h+    br        = P2 (x + half_base ) (y - hh)+    bl        = P2 (x - half_base ) (y - hh)+    tr        = displaceVec (rightSideVec h rang) br+    tl        = displaceVec (leftSideVec h lang) bl+++tzPoints :: (Real u, Floating u) +               => u -> u -> Radian -> Radian -> [Point2 u]+tzPoints bw h lang rang = [ bl, br, tr, tl ]+  where+    half_base = 0.5 * bw+    hh        = 0.5 * h+    bl        = P2 (-half_base) (-hh)+    br        = P2 half_base    (-hh)+    tr        = displaceVec (rightSideVec h rang) br+    tl        = displaceVec (leftSideVec h lang) bl++++-- | Calculate the vector that produces the upper-left point given+-- the lower-left point.+--+-- Note - expects ang value 0 < ang < 180, though does not check...+-- +leftSideVec :: Floating u => u -> Radian -> Vec2 u+leftSideVec h lang | lang <  0.5*pi = less_ninety+                   | lang == 0.5*pi = vvec h+                   | otherwise      = grtr_ninety+  where+    less_ninety = let dist = h / (fromRadian $ sin lang) in avec lang dist+    grtr_ninety = let theta = lang - (0.5*pi) +                      dist  = h / (fromRadian $ cos theta) +                  in avec lang dist+++++-- | Calculate the vector that produces the upper-right point given+-- the lower-right point.+--+-- Note - expects ang value 0 < ang < 180, though does not check...+-- +rightSideVec :: Floating u => u -> Radian -> Vec2 u+rightSideVec h rang | rang <  0.5*pi = less_ninety+                    | rang == 0.5*pi = vvec h+                    | otherwise      = grtr_ninety+  where+    less_ninety = let dist  = h / (fromRadian $ sin rang) in avec (pi - rang) dist+    grtr_ninety = let theta = rang - (0.5*pi) +                      dist  = h / (fromRadian $ cos theta) +                  in avec (pi - rang) dist+

@@ -0,0 +1,226 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# 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.Paths+import Wumpus.Drawing.Shapes.Base++import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic+import Wumpus.Basic.Geometry.Quadrant+import Wumpus.Basic.Geometry.Paths+import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative+++++-- Datatype++-- | An isosceles triangle, oriented /upwards/.+--+data Triangle u = Triangle +      { tri_ctm         :: ShapeCTM u+      , tri_height      :: !u+      , tri_base_width  :: !u+      , tri_syn_props   :: SyntheticProps u+      }+      +data SyntheticProps u = SyntheticProps+      { tri_hmajor      :: u           +      , tri_hminor      :: u+      , tri_base_ang    :: Radian+      , tri_apex_ang    :: Radian+      }+++type DTriangle = Triangle Double++type instance DUnit (Triangle u) = u+++--------------------------------------------------------------------------------+-- Affine trans++mapTriangleCTM :: (ShapeCTM u -> ShapeCTM u) +               -> Triangle u -> Triangle u+mapTriangleCTM f = (\s i -> s { tri_ctm = f i }) <*> tri_ctm++instance Num u => Scale (Triangle u) where+  scale sx sy = mapTriangleCTM (scale sx sy)+++instance Rotate (Triangle u) where+  rotate ang = mapTriangleCTM (rotate ang)+                  ++instance (Real u, Floating u) => RotateAbout (Triangle u) where+  rotateAbout ang pt = mapTriangleCTM (rotateAbout ang pt)+++instance Num u => Translate (Triangle u) where+  translate dx dy = mapTriangleCTM (translate dx dy)+++--------------------------------------------------------------------------------+-- Anchors++-- | 'runDisplaceCenter' : @ ( half_base_width +--                           * height_minor +--                           * height_major +--                           * base_ang -> Vec ) * traingle -> Point @+--+runDisplaceCenter :: (Real u, Floating u)+                  => (u -> u -> u -> Radian -> Vec2 u) -> Triangle u -> Point2 u+runDisplaceCenter fn (Triangle { tri_ctm        = ctm+                               , tri_base_width = bw+                               , tri_syn_props  = syn }) =  +    displaceCenter (fn (0.5*bw) hminor hmajor base_ang) ctm+  where+    hminor   = tri_hminor syn        +    hmajor   = tri_hmajor syn+    base_ang = tri_base_ang syn++++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 $ \_ _ hmaj _ -> V2 0 hmaj+++instance (Real u, Floating u) => BottomCornerAnchor (Triangle u) where+  bottomLeftCorner  = runDisplaceCenter $ \hbw hmin _ _  -> V2 (-hbw) (-hmin)+  bottomRightCorner = runDisplaceCenter $ \hbw hmin _ _  -> V2  hbw   (-hmin)+++-- east and west should be parallel to the centroid.+--++instance (Real u, Floating u) => CardinalAnchor (Triangle u) where+  north = runDisplaceCenter $ \_   _    hmaj _    -> V2 0 hmaj+  south = runDisplaceCenter $ \_   hmin _    _    -> V2 0 (-hmin)+  east  = runDisplaceCenter $ \hbw hmin _    ang  -> findEast hbw hmin ang+  west  = runDisplaceCenter $ \hbw hmin _    ang  -> findWest hbw hmin ang+++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 :: Fractional u => u -> u -> Radian -> Vec2 u+findEast half_base_width hminor base_ang = V2 xdist 0+  where+    b1    = hminor / (fromRadian $ tan base_ang)+    xdist = half_base_width - b1++findWest :: Fractional u => u -> u -> Radian -> Vec2 u+findWest hbw hm ang = let (V2 xdist 0) = findEast hbw hm ang in V2 (-xdist) 0 ++++instance (Real u, Floating 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) => RadialAnchor (Triangle u) where+  radialAnchor theta = runDisplaceCenter $ \hbw hmin hmaj _ -> +                         triangleRadialVector hbw hmin hmaj theta+       +    +--------------------------------------------------------------------------------+-- Construction++-- | 'triangle'  : @ base_width * height -> Shape @+--+--+triangle :: (Real u, Floating u, FromPtSize u) +         => u -> u -> Shape u (Triangle u)+triangle bw h =+    let props  = synthesizeProps bw h+        hminor = tri_hminor props+        hmajor = tri_hmajor props+    in makeShape (mkTriangle bw h props) (mkTrianglePath bw hminor hmajor)++++++mkTriangle :: (Real u, Fractional u) +           => u -> u -> SyntheticProps u -> LocThetaCF u (Triangle u)+mkTriangle bw h props = promoteR2 $ \ctrd theta -> +    pure $ Triangle { tri_ctm        = makeShapeCTM ctrd theta+                    , tri_base_width = bw+                    , tri_height     = h +                    , tri_syn_props  = props+                    }+++synthesizeProps :: (Real u, Fractional u) => u -> u -> SyntheticProps u+synthesizeProps bw h = +    SyntheticProps { tri_hmajor      = hmajor+                   , tri_hminor      = hminor+                   , tri_base_ang    = base_ang+                   , tri_apex_ang    = apex_ang+                   }+  where+    half_base   = 0.5 * bw +    hminor      = h / 3+    hmajor      = 2 * hminor +    base_ang    = atan $ toRadian (h / half_base)+    apex_ang    = 2 * ((pi/4) - base_ang)++++mkTrianglePath :: (Real u, Floating u, FromPtSize u) +               => u -> u -> u -> LocThetaCF u (Path u)+mkTrianglePath bw hminor hmajor = promoteR2 $ \ctr theta -> +    roundCornerShapePath $ map (rotateAbout theta ctr) +                         $ trianglePath bw hminor hmajor ctr+++trianglePath :: (Real u, Floating u) +             => u -> u -> u -> LocCoordPath u+trianglePath bw hminor hmajor (P2 x y) = [br, apx, bl]+  where+    half_base = 0.5 * bw+    br        = P2 (x + half_base ) (y - hminor)+    apx       = P2 x (y + hmajor)+    bl        = P2 (x - half_base ) (y - hminor)+

@@ -0,0 +1,166 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Text.Base+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Helpers for working with measured / advance text.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Text.Base+  ( ++    advtext+  , textVector+  , charVector++  , multilineHeight+  , textObjectPos+  , borderedTextObjectPos++  , centerToBaseline+  , centerSpinePoints++  ) where++import Wumpus.Drawing.Chains++import Wumpus.Basic.Kernel                      -- package: wumpus-basic++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Text.GlyphIndices++import Data.VectorSpace                         -- package: vector-space++import Control.Applicative+import Data.Char+import qualified Data.Map               as Map+import Data.Maybe +++-- | Single line text, returning its advance vector.+--+advtext :: FromPtSize u => EscapedText -> AdvGraphic u+advtext esc = lift0R1 (textVector esc) >>= \v -> replaceAns v $ escapedline esc+++-- kernchar versions to do...+++textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u)+textVector esc = +    cwLookupTable >>= \table -> +       let cs = destrEscapedText id esc +       in return $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs+     +charVector :: FromPtSize u => EscapedChar -> DrawingInfo (AdvanceVec u)+charVector ch = cwLookupTable >>= \table -> return $ charWidth table ch+   ++-- | This is outside the Drawing context as we don\'t want to get+-- the @cwLookupTable@ for every char.+--+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+++--------------------------------------------------------------------------------+-- Measurement and start points for multiline text+++-- | Height of multiline text is cap_height to descender for the +-- first line, then baseline-to-baseline span for the remaining+-- lines.+--+multilineHeight :: (Real u, Floating u, FromPtSize u) +                   => Int -> DrawingInfo u+multilineHeight line_count +    | line_count < 1  = return 0+    | line_count == 1 = glyphVerticalSpan+    | otherwise       = fn <$> glyphVerticalSpan <*> baselineSpacing+  where+    fn h1 bspan = let rest_spans = bspan * fromIntegral (line_count - 1)+                  in h1 + rest_spans++++-- | Height of multiline text is cap_height to descender for the +-- first line, then baseline-to-baseline span for the remaining+-- lines.+-- +-- The answer is in centerform, i.e.:+--+-- > ObjectPos  half_width  half_width  half_height  half_height +--+textObjectPos :: (Real u, Floating u, FromPtSize u) +                   => Int -> u -> DrawingInfo (ObjectPos u)+textObjectPos line_count w =+    fmap (0.5*) (multilineHeight line_count) >>= \hh ->+    let hw    = 0.5 * w+    in return $ ObjectPos hw hw hh hh +++-- | Variant of 'textObjectPos' where the calculation includes+-- margins around all four sides of the enclosing rectangle.+--+-- Margin sizes are taken from the 'text_margin' field in the +-- 'DrawingContext'.+--+borderedTextObjectPos :: (Real u, Floating u, FromPtSize u) +                      => Int -> u -> DrawingInfo (ObjectPos u)+borderedTextObjectPos line_count w =+    multilineHeight line_count >>= \h ->+    getTextMargin >>= \(xsep,ysep) -> +    let hw    = (2 * xsep) + (0.5 * w)+        hh    = (2 * ysep) + (0.5 * h)+    in return $ ObjectPos hw hw hh hh ++++-- | Calculate the distance from the center of a one-line textbox +-- to the baseline. Note the height of a textbox is @vspan@ which +-- is cap_height + descender+--+centerToBaseline :: (Fractional u, FromPtSize u) => DrawingInfo u+centerToBaseline = +    (\ch vspan -> ch - 0.5 * vspan) <$> glyphCapHeight <*> glyphVerticalSpan++-- | All drawing is done on a spine that plots points from the +-- first line of text. The spine is calculated from its center and+-- has to account for the inclination.+--+centerSpinePoints :: Floating u +                  => Int -> Radian -> LocChain u+centerSpinePoints n theta+    | n <= 1    = promoteR1 $ \ctr -> return [ctr]+    | otherwise = promoteR1 $ \ctr -> +                    baselineSpacing >>= \h1 -> +                    let dist_top = h1 * centerCount n+                        top      = thetaNorthwards dist_top theta ctr    +                    in return (take n $ iterate (thetaSouthwards h1 theta) top)+++-- | Count the steps from the center to an end:+--+-- >+-- > 1 = 0     .+-- > 2 = 0.5   .__.+-- > 3 = 1     .__.__.+-- > 4 = 1.5   .__.__.__.+-- >+--+centerCount :: Fractional u => Int -> u+centerCount i = (fromIntegral i) / 2 - 0.5

@@ -0,0 +1,207 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Drawing.Text.Text+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Left-to-right text.+-- +--------------------------------------------------------------------------------++module Wumpus.Drawing.Text.CatText+  ( +   +    CatText+  , leftAlign+  , centerAlign+  , rightAlign++  , blank+  , space+  , string+  , (<>)+  , (<+>) ++  , fontColour++  ) where++import Wumpus.Drawing.Chains+import Wumpus.Drawing.Text.Base++import Wumpus.Basic.Kernel                      -- package: wumpus-basic+import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl )+import qualified Wumpus.Basic.Utils.JoinList as JL++import Wumpus.Core                              -- package: wumpus-core++import Data.Char ( ord )++-- Need to know line width (horizontal) and line count (vertical) +-- to render...+--+-- Can obviously access line count if we avoid avoid operators +-- for vertical composition operator and delegate it to rendering+-- instead:+--+-- > rightAlign :: [CatText u] -> PosImage u (BoundingBox u)+--++-- A CatPrim returns a drawing function (AdvGraphic) to be used+-- drawing final rendering.+--+type CatPrim u = CF (u, AdvGraphic u)++newtype CatText u = CatText { getCatText :: JoinList (CatPrim u) }++++-- | 'HMove' : @ half_max_width * line_width -> Horizontal_Displacement @+--+type HMove u = u -> u -> u++leftAMove :: Num u => HMove u+leftAMove half_max _ = negate half_max+ +centerAMove :: Fractional u => HMove u+centerAMove _ elt_w = negate $ 0.5 * elt_w++rightAMove :: Num u => HMove u+rightAMove half_max elt_w = half_max - elt_w++++leftAlign :: (Real u, FromPtSize u, Floating u) +          => [CatText u] -> PosImage u (BoundingBox u)+leftAlign = drawMulti leftAMove++centerAlign :: (Real u, FromPtSize u, Floating u) +            => [CatText u] -> PosImage u (BoundingBox u)+centerAlign = drawMulti centerAMove++rightAlign :: (Real u, FromPtSize u, Floating u) +           => [CatText u] -> PosImage u (BoundingBox u)+rightAlign = drawMulti rightAMove++++drawMulti :: (Real u, FromPtSize u, Floating u) +          => HMove u -> [CatText u] -> PosImage u (BoundingBox u)+drawMulti moveF xs = promoteR2 $ \start rpos -> +    evalAllLines xs                     >>= \all_lines -> +    centerToBaseline                    >>= \down -> +    borderedTextObjectPos line_count (fst all_lines) >>= \opos ->+    let chn   = centerSpinePoints line_count 0 +        gs    = positionHLines moveF down all_lines +        gf    = unchainZip emptyLocGraphic gs chn+        posG  = makePosImage opos gf+        bbox  = objectPosBounds start rpos opos+    in replaceAns bbox $ atStartPos posG start rpos     +  where+    line_count    = length xs++positionHLines :: Fractional u +               => HMove u -> u -> (u,[(u, AdvGraphic u)]) -> [LocGraphic u]+positionHLines mkH down (max_w,xs) = map fn xs+  where+    half_max       = 0.5 * max_w+    moveF w1       = let v = vec (mkH half_max w1) (-down) +                     in moveStart $ displaceVec v +    fn (elt_w, gf) = ignoreAns $ moveF elt_w $ gf+++evalAllLines :: (Num u, Ord u) +             => [CatText u] -> DrawingInfo (u, [(u, AdvGraphic u)])+evalAllLines = fmap post . mapM evalLine+  where+    post xs = let mx = foldr (\(a,_) x -> max a x) 0 xs in (mx,xs)+            +++++evalLine :: Num u => CatText u -> DrawingInfo (u, AdvGraphic u)+evalLine ct = case viewl $ getCatText ct of+    EmptyL -> return (0,  replaceAns (hvec 0) $ emptyLocGraphic)+    af :< rest -> af >>= \a -> go a (viewl rest)+  where+    go acc     EmptyL     = return acc+    go (dx,af) (mf :< ms) = let moveF = moveStart (displaceH dx)+                            in mf >>= \(u,gf) -> +                               go (dx+u, af `oplus` moveF gf) (viewl ms)++++++-- | Build a blank CatText with no output and a 0 width vector.+--+blank :: Num u => CatText u+blank = catOne $ return (0, replaceAns (hvec 0) $ emptyLocGraphic)++-- | Note - a space character is not draw in the output, instead +-- 'space' advances the width vector by the width of a space in +-- the current font.+--+space :: FromPtSize u => CatText u+space = catOne $ +   charVector (CharEscInt $ ord ' ') >>= \v -> +   return (advanceH v, replaceAns v $ emptyLocGraphic)++-- | Build a CatText from a string.+--+string :: FromPtSize u => String -> CatText u+string = catOne . stringPrim+++infixr 6 <>, <+>++-- | Concatenate two CatTexts separated with no spacing.+--+(<>) :: CatText u -> CatText u -> CatText u+a <> b = CatText $ JL.join (getCatText a) (getCatText b) +++-- | Concatenate two CatTexts separated with a space.+--+(<+>) :: FromPtSize u => CatText u -> CatText u -> CatText u+a <+> b = a <> space <> b ++++-- Note - @fill@ combinators cf. @wl-pprint@ (but left and right) +-- will be very useful.+--+-- Also PosImages can be inlined in text...+--++catOne :: CatPrim u -> CatText u+catOne = CatText . JL.one +++stringPrim :: FromPtSize u => String -> CatPrim u+stringPrim = escapedPrim . escapeString++escapedPrim :: FromPtSize u => EscapedText -> CatPrim u+escapedPrim esc = textVector esc >>= \v -> +                  return (vector_x v, replaceAns v $ escapedline esc)+++catMap :: (AdvGraphic u -> AdvGraphic u) -> CatText u -> CatText u+catMap f = CatText . fmap (fmap (\(u,ag) -> (u, f $ ag))) . getCatText++catlocal :: DrawingContextF -> CatText u -> CatText u+catlocal fn = catMap (localize fn)+++fontColour :: RGBi -> CatText u -> CatText u+fontColour rgb = catlocal (strokeColour rgb)++

@@ -4,385 +4,285 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Drawing.Text.LRText--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2011 -- 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.+-- Left-to-right measured text that supports radial inclination.+-- Caveat - rendering at any degree other than the horizontal may+-- not look good in PostScript or SVG. -- --- \*\* 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).+-- Note - LRText does not use the 'text_margin' setting from the +-- 'DrawingContext'.+--+-- \*\* WARNING \*\* - the API for this module needs some polish.+-- --  --------------------------------------------------------------------------------  module Wumpus.Drawing.Text.LRText   (  -    baseCenterLine-  , baseLeftLine-  , baseRightLine--  , rbaseCenterLine-  , rbaseLeftLine-  , rbaseRightLine--  , ctrCenterLine-  , baseCenterEscChar+    singleLine+  , escSingleLine+  , rsingleLine+  , rescSingleLine    , multiAlignLeft   , multiAlignCenter   , multiAlignRight -  , rmultiAlignLeft-  , rmultiAlignCenter-  , rmultiAlignRight- +  , textAlignCenter+  , textAlignLeft+  , textAlignRight    ) where +import Wumpus.Drawing.Chains+import Wumpus.Drawing.Text.Base -import Wumpus.Basic.Kernel+import Wumpus.Basic.Kernel                      -- package: wumpus-basic  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). --+-- Note - margins are not added to the text. This seems to be the +-- right thing to do in the case of rotated text, where the ortho+-- projection of the rectangle already can add spacing between +-- the RectPos and the actual text.+--  +------------------- --- One line of multiline text+-- | One line of multiline text ---data OnelineText u = OnelineText EscapedText (AdvanceVec u)-+data OnelineText u = OnelineText +        { text_content        :: EscapedText+        , oneline_adv         :: AdvanceVec u+        } --- | max_width * oneline_text -> LocThetaGraphic+-- Design note - using a LocThetaImage could be used instead, but+-- as the angle of inclination is interior to the final type the +-- it is used explicitly. ---type LocThetaDrawOneline u = u -> OnelineText u -> LocThetaGraphic u+type OnelineDrawF u = +    Radian -> AdvanceVec u -> OnelineText u -> LocImage u (BoundingBox 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-       +singleLine :: (Real u, Floating u, FromPtSize u) +           => String -> PosImage u (BoundingBox u)+singleLine ss = onelineDraw onelineACenter 0 (escapeString ss) +escSingleLine :: (Real u, Floating u, FromPtSize u) +              => EscapedText -> PosImage u (BoundingBox u)+escSingleLine = onelineDraw onelineACenter 0 --- | 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+rsingleLine :: (Real u, Floating u, FromPtSize u) +            => Radian -> String -> PosImage u (BoundingBox u)+rsingleLine theta ss = onelineDraw onelineACenter theta (escapeString ss) +rescSingleLine :: (Real u, Floating u, FromPtSize u) +               => Radian -> EscapedText -> PosImage u (BoundingBox u)+rescSingleLine = onelineDraw onelineACenter +multiAlignLeft :: (Real u, Floating u, FromPtSize u) +               => Radian -> String -> PosImage u (BoundingBox u)+multiAlignLeft theta ss = +   drawMultiline onelineALeft theta (map escapeString $ lines ss) +multiAlignCenter :: (Real u, Floating u, FromPtSize u) +               => Radian -> String -> PosImage u (BoundingBox u)+multiAlignCenter theta ss = +   drawMultiline onelineACenter theta (map escapeString $ lines ss) --- 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))-    +multiAlignRight :: (Real u, Floating u, FromPtSize u) +               => Radian -> String -> PosImage u (BoundingBox u)+multiAlignRight theta ss = +   drawMultiline onelineARight theta (map escapeString $ lines ss)  +textAlignLeft :: (Real u, Floating u, FromPtSize u) +              => String -> LocImage u (BoundingBox u)+textAlignLeft ss = multiAlignLeft 0 ss `startPos` CENTER +textAlignCenter :: (Real u, Floating u, FromPtSize u) +               => String -> LocImage u (BoundingBox u)+textAlignCenter ss = multiAlignCenter 0 ss `startPos` CENTER  +textAlignRight :: (Real u, Floating u, FromPtSize u) +               => String -> LocImage u (BoundingBox u)+textAlignRight ss = multiAlignRight 0 ss `startPos` CENTER   --- 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 +-- Note - inclination is not part of the ContextFunction... +drawMultiline :: (Real u, Floating u, FromPtSize u) +              => OnelineDrawF u -> Radian -> [EscapedText] +              -> PosImage u (BoundingBox u)+drawMultiline _     _     []  = lift1R2 emptyBoundedLocGraphic+drawMultiline drawF theta [x] = onelineDraw drawF theta x+drawMultiline drawF theta xs  = promoteR2 $ \start rpos ->+    linesToInterims xs >>= \(max_adv, ones) -> +    rotObjectPos theta line_count (advanceH max_adv) >>= \opos -> +    let chn   = centerSpinePoints line_count theta+        gs    = map (drawF theta max_adv) ones+        gf    = unchainZip emptyBoundedLocGraphic gs chn+        posG  = makePosImage opos gf+    in  atStartPos posG start rpos     +  where+    line_count = length xs   --- | Draw 1 line...------ Impilict point is baseline-left.--- -baseLeftLine :: (Real u, Floating u, FromPtSize u) -              => String -> BoundedLocGraphic u-baseLeftLine ss = rbaseLeftLine ss `rot` 0-+onelineDraw :: (Real u, Floating u, FromPtSize u) +            => OnelineDrawF u -> Radian -> EscapedText -> PosImage u (BoundingBox u)+onelineDraw drawF theta esc = promoteR2 $ \start rpos ->+    onelineEscText esc        >>= \otext -> +    rotObjectPos theta 1 (advanceH $ oneline_adv otext) >>= \opos  -> +    let max_adv = oneline_adv otext +        gf      = drawF theta max_adv otext+        posG    = makePosImage opos gf+    in  atStartPos posG start rpos   --- | Draw 1 line...------ Impilict point is baseline-center.+-- | LR text needs the objectPos under rotation. ---baseCenterLine :: (Real u, Floating u, FromPtSize u) -               => String -> BoundedLocGraphic u-baseCenterLine ss = rbaseCenterLine ss `rot` 0+rotObjectPos :: (Real u, Floating u, FromPtSize u) +             => Radian -> Int -> u -> DrawingInfo (ObjectPos u)+rotObjectPos theta line_count max_w =+    fmap (orthoObjectPos theta) $ textObjectPos line_count max_w    +     --- | Draw 1 line...------ Impilict point is baseline-right.+-- | Note - this returns the answer in center form, regardless+-- of whether the input was in center form.+-- +-- So it is probably not a general enough function for the +-- PosImage library. ---baseRightLine :: (Real u, Floating u, FromPtSize u) -              => String -> BoundedLocGraphic u-baseRightLine ss = rbaseRightLine ss `rot` 0+orthoObjectPos :: (Real u, Floating u) +               => Radian -> ObjectPos u -> ObjectPos u+orthoObjectPos theta (ObjectPos xmin xmaj ymin ymaj) = +    ObjectPos bbox_hw bbox_hw bbox_hh bbox_hh+  where+    input_hw  = 0.5 * (xmin + xmaj)+    input_hh  = 0.5 * (ymin + ymaj)+    bbox0     = BBox (P2 (-input_hw) (-input_hh)) (P2 input_hw input_hh)+    bbox1     = retraceBoundary (rotateAbout theta zeroPt) bbox0+    bbox_hw   = 0.5 * (boundaryWidth bbox1)+    bbox_hh   = 0.5 * (boundaryHeight bbox1)   -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.+-- | Draw left-aligned text. Effictively this is: ---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+-- > Leftwards for the half the max vector+-- >+-- > Down to the baseline from the center.+--+onelineALeft :: (Real u, Floating u, FromPtSize u)  +             => OnelineDrawF u +onelineALeft theta max_adv otext = promoteR1 $ \ctr -> +    centerToBaseline >>= \down -> +    atRot (orthoBB max_adv) ctr theta >>= \bbox -> +    let pt = move down theta ctr +    in replaceAns bbox $ atRot (rescapedline $ text_content otext) pt theta   where-    body = onelineAlg centerToCenter drawCenterAligned (wrapEscChar esc)----+    vec1      = negateV $ 0.5 *^ max_adv+    move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang  --- | max_width * interim_text * theta -> (Point -> Point)+-- | Draw center-aligned text. Effictively this is: ---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+-- > Leftwards for the half the width vector+-- >+-- > Down to the baseline from the center.+--+onelineACenter :: (Real u, Floating u, FromPtSize u)  +               => OnelineDrawF u+onelineACenter theta max_adv otext = promoteR1 $ \ctr -> +    centerToBaseline >>= \down -> +    atRot (orthoBB max_adv) ctr theta >>= \bbox ->  +    let pt = move down theta ctr +    in replaceAns bbox $ atRot (rescapedline $ text_content otext) pt theta   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--+    vec1      = negateV $ 0.5 *^ oneline_adv otext+    move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang  --- | @ana@ is an /anacrusis/ factor - if there are even points--- half the baseline_spacing is added to get the top point+-- | Draw right-aligned text. Effictively this is: ---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 *) +-- > Rightwards for the half the max vector+-- >+-- > Leftwards for the width vector+-- >+-- > Down to the baseline from the center.+--+onelineARight :: (Real u, Floating u, FromPtSize u)  +              => OnelineDrawF u+onelineARight theta max_adv otext = promoteR1 $ \ctr -> +    centerToBaseline >>= \down -> +    atRot (orthoBB max_adv) ctr theta >>= \bbox -> +    let pt = move down theta ctr +    in replaceAns bbox $ atRot (rescapedline $ text_content otext) pt theta   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-        +    vec1      = (0.5 *^ max_adv) ^-^ oneline_adv otext+    move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang  -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 +-- Note - for multiline text, the bounding box (of one line) is +-- always the same size regardless of the alignment of the textlines.+--+orthoBB :: (Real u, Floating u, FromPtSize u) +        => AdvanceVec u -> LocThetaDrawingInfo u (BoundingBox u)+orthoBB (V2 w _) = promoteR2 $ \ctr theta -> +    glyphVerticalSpan >>= \h ->+    let bl  = ctr .-^ V2 (0.5 * w) (0.5 * h)+        bb1 = boundingBox bl (bl .+^ V2 w h)+        bb2 = retraceBoundary (rotateAbout theta ctr) bb1+    in return bb2  + --------------------------------------------------------------------------------  -- This isn't worth the complexity to get down to one traversal... +-- | Turn the input list of lines of 'EscapedText' into +-- 'OnelineText' and return the result list twinned with the +-- largest 'AdvanceVec'.+-- linesToInterims :: (FromPtSize u, Ord u) -                => String -> DrawingInfo (AdvanceVec u, [OnelineText u])-linesToInterims = fmap post . mapM (onelineEscText . escapeString) . lines+                => [EscapedText] -> DrawingInfo (AdvanceVec u, [OnelineText u])+linesToInterims = fmap post . mapM onelineEscText   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 @@ -390,20 +290,3 @@ 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

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

@@ -1,5 +1,5 @@ name:             wumpus-drawing-version:          0.1.0+version:          0.2.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -38,6 +38,16 @@   .   Changelog:   .+  v0.1.0 to 0.2.0:+  .+  * Added new Shapes.+  .+  * Move Geometry modules to Wumpus-Basic.+  .+  * Re-implemented Chains.+  .+  * Re-implemented LR-Text. Added CatText.+  .   v0.1.0:   .   * Initial release - this is a split from @Wumpus-Basic@ making @@ -73,7 +83,8 @@   demo/FontPic.hs,   demo/LeftRightText.hs,   demo/PetriNet.hs,-  demo/PictureCompo.hs,+  demo/SingleLine.hs,+  demo/SampleShapes.hs,   demo/Symbols.hs,   demo/TableChains.hs @@ -81,11 +92,9 @@   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.43.0  && <  0.44.0,+                      wumpus-basic    == 0.16.0       exposed-modules:@@ -99,8 +108,7 @@     Wumpus.Drawing.Colour.X11Colours,     Wumpus.Drawing.Dots.AnchorDots,     Wumpus.Drawing.Dots.Marks,-    Wumpus.Drawing.Geometry.Intersection,-    Wumpus.Drawing.Geometry.Paths,+    Wumpus.Drawing.Grids,     Wumpus.Drawing.Paths,     Wumpus.Drawing.Paths.Base,     Wumpus.Drawing.Paths.Connectors,@@ -111,7 +119,17 @@     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.Shapes.Trapezium,+    Wumpus.Drawing.Shapes.Semicircle,+    Wumpus.Drawing.Shapes.Semiellipse,+    Wumpus.Drawing.Shapes.Triangle,+    Wumpus.Drawing.Text.Base,+    Wumpus.Drawing.Text.CatText,     Wumpus.Drawing.Text.LRText,     Wumpus.Drawing.Text.SafeFonts,     Wumpus.Drawing.Turtle.TurtleClass,