wumpus-basic 0.11.0 → 0.12.0

raw patch · 30 files changed

+2074/−1077 lines, 30 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• demo/ArrowCircuit.hs +10/−10
• demo/Arrowheads.hs +88/−0
• demo/Connectors.hs +79/−0
• demo/DotPic.hs +47/−40
• demo/PetriNet.hs +7/−5
• demo/Symbols.hs +1/−1
• src/Wumpus/Basic/Arrows/Connectors.hs +47/−37
• src/Wumpus/Basic/Arrows/Tips.hs +280/−60
• src/Wumpus/Basic/Dots.hs +0/−231
• src/Wumpus/Basic/Dots/AnchorDots.hs +232/−0
• src/Wumpus/Basic/Dots/Marks.hs +227/−0
• src/Wumpus/Basic/Dots/Primitive.hs +0/−233
• src/Wumpus/Basic/Graphic.hs +0/−2
• src/Wumpus/Basic/Graphic/Base.hs +235/−25
• src/Wumpus/Basic/Graphic/DirectionContext.hs +0/−140
• src/Wumpus/Basic/Graphic/Drawing.hs +40/−44
• src/Wumpus/Basic/Graphic/PrimGraphic.hs +42/−31
• src/Wumpus/Basic/Paths.hs +2/−0
• src/Wumpus/Basic/Paths/Base.hs +11/−0
• src/Wumpus/Basic/Paths/Connectors.hs +147/−27
• src/Wumpus/Basic/Paths/ControlPoints.hs +189/−0
• src/Wumpus/Basic/Paths/RoundCorners.hs +8/−9
• src/Wumpus/Basic/Shapes/Base.hs +109/−47
• src/Wumpus/Basic/Shapes/Derived.hs +120/−100
• src/Wumpus/Basic/Shapes/Plaintext.hs +6/−7
• src/Wumpus/Basic/Text/LRText.hs +2/−6
• src/Wumpus/Basic/Utils/Combinators.hs +92/−0
• src/Wumpus/Basic/Utils/Intersection.hs +17/−2
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +34/−18

@@ -38,20 +38,20 @@           pic1 :: Picture Double  pic1 = liftToPictureU $ execDrawing times_ctx $ do-    a1 <- drawi $ strokedShape $ translate 0   72 $ rrectangle 12 66 30+    a1 <- drawi $ strokedShape $ rrectangle 12 66 30 `at` P2 0 72     atext a1 "CONST 0"-    a2 <- drawi $ strokedShape $ translate 120 60 $ circle 16+    a2 <- drawi $ strokedShape $ circle 16 `at` P2 120 60     atext a2 "IF"-    a3 <- drawi $ strokedShape $ translate 240 28 $ circle 16+    a3 <- drawi $ strokedShape $ circle 16 `at` P2 240 28     atext a3 "+1"-    a4 <- drawi $ strokedShape $ translate 120  0 $ rectangle 66 30+    a4 <- drawi $ strokedShape $ rectangle 66 30 `at` P2 120 0     atext a4 "DELAY 0"-    connWith connect (east a1) (east a1 .+^ hvec 76)-    connWith connect (east a2) (east a2 .+^ hvec 180)-    connWith connect (north a2 .+^ vvec 40) (north a2)-    connWith connect (north a3 .+^ vvec 16) (north a3)  -    connWith vhconn  (south a3) (east a4)-    connWith (hvhconn (-30)) (west a4)  (southwest a2)+    connWith connLine (east a1) (east a1 .+^ hvec 76)+    connWith connLine (east a2) (east a2 .+^ hvec 180)+    connWith connLine (north a2 .+^ vvec 40) (north a2)+    connWith connLine (north a3 .+^ vvec 16) (north a3)  +    connWith connRightVH  (south a3) (east a4)+    connWith (connRightHVH (-30)) (west a4)  (southwest a2)     ptext (P2  40  10) "next"     ptext (P2 152 100) "reset"     ptext (P2 252  72) "output"

@@ -0,0 +1,88 @@+{-# OPTIONS -Wall #-}++module Arrowheads where+++import Wumpus.Basic.Arrows+import Wumpus.Basic.Chains+import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths hiding ( length )++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Monad+import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    demo01++pt2 :: Point2 Double+pt2 = P2 100 10+++demo01 :: IO ()+demo01 = do +    writeEPS_latin1 "./out/arrowheads01.eps" pic1+    writeSVG_latin1 "./out/arrowheads01.svg" pic1++pic1 :: Picture Double+pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ arrtable++arrtable :: [(Arrowhead Double, Arrowhead Double)]+arrtable = +    [ (tri90,       tri90)+    , (tri60,       tri60)+    , (tri45,       tri45)+    , (otri90,      otri90)+    , (otri60,      otri60)+    , (otri45,      otri45)+    , (revtri90,    revtri90)+    , (revtri60,    revtri60)+    , (revtri45,    revtri45)+    , (orevtri90,   orevtri90)+    , (orevtri60,   orevtri60)+    , (orevtri45,   orevtri45)+    , (barb90,      barb90)+    , (barb60,      barb60)+    , (barb45,      barb45)+    , (revbarb90,   revbarb90)+    , (revbarb60,   revbarb60)+    , (revbarb45,   revbarb45)+    , (perp,        perp)+    , (bracket,     bracket)+    , (diskTip,     diskTip)+    , (odiskTip,    odiskTip)+    , (squareTip,   squareTip)+    , (osquareTip,  osquareTip)+    , (diamondTip,  diamondTip)+    , (odiamondTip, odiamondTip)+    , (curveTip,    curveTip)+    , (revcurveTip, revcurveTip)+    ]++tableGraphic :: (Real u, Floating u, FromPtSize u) +             => [(Arrowhead u, Arrowhead u)] -> Drawing u ()+tableGraphic tips = zipWithM_ makeArrowDrawing tips ps+  where+    ps = unchain (coordinateScalingContext 120 24) $ tableDown 20 4+++ +std_ctx :: DrawingContext+std_ctx = fillColour peru $ standardContext 18++++makeArrowDrawing :: (Real u, Floating u, FromPtSize u) +                 => (Arrowhead u, Arrowhead u) -> Point2 u -> Drawing u ()+makeArrowDrawing (arrl,arrr) p0 = +    drawi_ $ strokeConnector (leftrightArrow connLine arrl arrr) p0 p1+  where+    p1 = p0 .+^ hvec 100+  +

@@ -0,0 +1,79 @@+{-# OPTIONS -Wall #-}++module Connectors where+++import Wumpus.Basic.Arrows+import Wumpus.Basic.Chains+import Wumpus.Basic.Colour.SVGColours+import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths hiding ( length )++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Monad+import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    demo01++pt2 :: Point2 Double+pt2 = P2 100 10+++demo01 :: IO ()+demo01 = do +    writeEPS_latin1 "./out/connectors01.eps" pic1+    writeSVG_latin1 "./out/connectors01.svg" pic1++pic1 :: Picture Double+pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ conntable++conntable :: [ConnectorPath Double]+conntable = +    [ connLine+    , connRightVH+    , connRightHV+    , connRightVHV 15+    , connRightHVH 15+    , connIsosceles 25+    , connIsosceles (-25)+    , connIsosceles2 15+    , connIsosceles2 (-15)+    , connLightningBolt 15+    , connLightningBolt (-15)+    , connIsoscelesCurve 25+    , connIsoscelesCurve (-25)+    , connSquareCurve+    , connUSquareCurve+    , connTrapezoidCurve 40 0.5+    , connTrapezoidCurve (-40) 0.5+    , connZSquareCurve   +    , connUZSquareCurve   +    ]++tableGraphic :: (Real u, Floating u, FromPtSize u) +             => [ConnectorPath u] -> Drawing u ()+tableGraphic conns = zipWithM_ makeConnDrawing conns ps+  where+    ps = unchain (coordinateScalingContext 120 52) $ tableDown 10 6+++ +std_ctx :: DrawingContext+std_ctx = fillColour peru $ standardContext 18++++makeConnDrawing :: (Real u, Floating u, FromPtSize u) +                 => ConnectorPath u -> Point2 u -> Drawing u ()+makeConnDrawing conn p0 = +    drawi_ $ strokeConnector (dblArrow conn curveTip) p0 p1+  where+    p1 = p0 .+^ vec 100 40+  +

@@ -3,13 +3,16 @@ module DotPic where  +import Wumpus.Basic.Chains import Wumpus.Basic.Colour.SVGColours-import Wumpus.Basic.Dots+import Wumpus.Basic.Dots.AnchorDots import Wumpus.Basic.Graphic-import Wumpus.Basic.PictureLanguage -import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Core                              -- package: wumpus-core +import Data.AffineSpace                         -- package: vector-space++import Control.Monad import System.Directory  main :: IO ()@@ -23,55 +26,59 @@  demo01 :: IO () demo01 = do -    writeEPS_latin1 "./out/dots01.eps" pic-    writeSVG_latin1 "./out/dots01.svg" pic-  where -    pic :: Picture Double-    pic = extendBoundary 10 10 $-          uniformScale 2       $ -            vsepA VLeft 10 p1 [p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14-                              ,p15,p16,p17]-    -    p1  = makeDotPic dotHLine       points-    p2  = makeDotPic dotVLine       points-    p3  = makeDotPic dotX           points-    p4  = makeDotPic dotPlus        points   -    p5  = makeDotPic dotCross       points-    p6  = makeDotPic dotDiamond     points-    p7  = makeDotPic dotDisk        points-    p8  = makeDotPic dotSquare      points-    p9  = makeDotPic dotCircle      points-    p10 = makeDotPic dotPentagon    points-    p11 = makeDotPic dotStar        points-    p12 = makeDotPic dotAsterisk    points-    p13 = makeDotPic dotOPlus       points-    p14 = makeDotPic dotOCross      points-    p15 = makeDotPic dotFOCross     points-    p16 = makeDotPic dotFDiamond    points-    p17 = makeDotPic (dotText "AA") points+    writeEPS_latin1 "./out/dots01.eps" pic1+    writeSVG_latin1 "./out/dots01.svg" pic1++pic1 :: Picture Double+pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ +    [ dotHLine+    , dotVLine+    , dotX+    , dotPlus+    , dotCross+    , dotDiamond+    , dotDisk+    , dotSquare+    , dotCircle+    , dotPentagon+    , dotStar+    , dotAsterisk+    , dotOPlus+    , dotOCross+    , dotFOCross+    , dotFDiamond+    , dotText "%" +    ]+++tableGraphic :: (Real u, Floating u, FromPtSize u) +             => [DotLocImage u] -> Drawing u ()+tableGraphic imgs = zipWithM_ makeDotDrawing imgs ps+  where+    ps = unchain (coordinateScalingContext 1 36) $ tableDown (length imgs) 1++   std_ctx :: DrawingContext-std_ctx = fillColour peru $ standardContext 12+std_ctx = fillColour peru $ standardContext 24 -points :: [Point2 Double]-points = [P2 0 0, P2 32 10, P2 64 0, P2 96 10]  --- Note - order of drawing is may need to change with future--- revisions.----makeDotPic :: (Real u, Floating u, FromPtSize u) -           => DotLocImage u -> [Point2 u] -> Picture u-makeDotPic dotImg xs = liftToPictureU $ execDrawing std_ctx $ do +makeDotDrawing :: (Real u, Floating u, FromPtSize u) +              => DotLocImage u -> Point2 u -> Drawing u ()+makeDotDrawing dotF pt = do      dashline-    mapM_ (\pt -> drawi $ dotImg `ati` pt) xs+    mapM_ (\v -> drawi $ dotF `at` pt .+^ v) displacements   where-    dashline = localize attrUpd (draw $ openStroke $ vertexPath xs)+    all_pts  = map (pt .+^) displacements+    dashline = localize attrUpd (draw $ openStroke $ vertexPath all_pts)      attrUpd  :: DrawingContext -> DrawingContext     attrUpd  =  dashPattern (evenDashes 1) . strokeColour cadet_blue  +displacements :: Num u => [Vec2 u]+displacements = [V2 0 0, V2 64 20, V2 128 0, V2 192 20]   -- Should these produce a DashPattern or a StrokeAttr?

@@ -81,11 +81,12 @@  place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m)        => u -> u -> m (Circle u)-place x y = greenFill $ drawi $ borderedShape $ translate x y $ circle 14+place x y = greenFill $ drawi $ borderedShape $ circle 14 `at` P2 x y  transition :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m)             => u -> u -> m (Rectangle u)-transition x y = greenFill $ drawi $ borderedShape $ translate x y $ rectangle 32 22+transition x y = +    greenFill $ drawi $ borderedShape $ rectangle 32 22 `at` P2 x y   @@ -93,20 +94,21 @@ connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m          , Real u, Floating u, FromPtSize u )        => Point2 u -> Point2 u -> m ()-connector' p0 p1 = drawi_ $ strokeConnector (rightArrow connect tri45) p0 p1+connector' p0 p1 = +    drawi_ $ strokeConnector (rightArrow connLine tri45) p0 p1   connectorC :: ( Real u, Floating u, FromPtSize u              , DrawingCtxM m, TraceM m, u ~ MonUnit m )            => u -> Point2 u -> Point2 u -> m () connectorC v p0 p1 = -    drawi_ $ strokeConnector (rightArrow (vhvconn v) tri45) p0 p1+    drawi_ $ strokeConnector (rightArrow (connRightVHV v) tri45) p0 p1  connectorD :: ( Real u, Floating u, FromPtSize u              , DrawingCtxM m, TraceM m, u ~ MonUnit m )            => u -> Point2 u -> Point2 u -> m () connectorD u p0 p1 = -    drawi_ $ strokeConnector (rightArrow (joint u) tri45) p0 p1+    drawi_ $ strokeConnector (rightArrow (connIsosceles u) tri45) p0 p1   lblParensParens :: Num u => LocGraphic u

@@ -2,7 +2,7 @@  module Symbols where -import Wumpus.Basic.Graphic hiding ( perpendicular )+import Wumpus.Basic.Graphic import Wumpus.Basic.SafeFonts import Wumpus.Basic.Text.LRSymbol import Wumpus.Basic.Text.LRText

@@ -12,9 +12,6 @@ -- -- Draw arrows. ----- \*\* WARNING \*\* - the types are /wrong/ here and need more --- thought.---  --------------------------------------------------------------------------------  module Wumpus.Basic.Arrows.Connectors@@ -37,9 +34,9 @@  import Wumpus.Core                      -- package: wumpus-core -import Data.Monoid+import Control.Applicative --- An arrowhead always know how to draws itself (filled tri, +-- An arrowhead always know how to draw itself (filled triangle,  -- stroked barb, etc.) -- -- A Path might will typically be drawn with openStroke,@@ -51,9 +48,6 @@ -- another type.  --- larrow :: Arrowhead u -> ConnectorPath u -> WrappedConnector u-- data Connector u = Connector        { connector_path  :: ConnectorPath u       , opt_left_arrow  :: Maybe (Arrowhead u)@@ -98,39 +92,55 @@               }  ++ strokeConnector :: (Real u, Floating u)                  => Connector u -> ConnectorImage u (Path u)-strokeConnector (Connector cpF opt_la opt_ra) = \p0 p1 ->-    let pathc = cpF p0 p1 in -    (fn pathc opt_la p0 opt_ra p1) >>= \grafic ->-    intoImage (return pathc) grafic+strokeConnector (Connector cpF opt_la opt_ra) p0 p1 =+    tipEval opt_la (directionL pathc) p0 >>= \(dl,gfL) -> +    tipEval opt_ra (directionR pathc) p1 >>= \(dr,gfR) ->+    intoImage (pure pathc) (gfR $ gfL $ drawP $ shortenPath dl dr pathc)    where-    fn pathc ma p0 mb p1 = do -       (path1,tipl) <- applyTipL ma p0 pathc-       (path2,tipr) <- applyTipR mb p1 path1-       return $ (openStroke $ toPrimPath path2) `mappend` tipl `mappend` tipr-   +    pathc       = cpF p0 p1+    drawP       = openStroke . toPrimPath    +-- for Paths.Base ?+--+shortenPath :: (Real u , Floating u) =>  u  -> u -> Path u -> Path u+shortenPath l r = shortenL l .  shortenR r  -applyTipL :: (Real u, Floating u) -          => Maybe (Arrowhead u) -> Point2 u -> Path u -          -> DrawingR (Path u, Graphic u)-applyTipL Nothing    _   pathc = return (pathc,mempty)-applyTipL (Just arw) ptL pathc = -    retract_dist arw >>= \ dx -> -    if dx > 0 then return (shortenL dx pathc, grafik) -              else return (pathc, grafik)-  where-    grafik = (arrow_draw arw) (directionL pathc) ptL -applyTipR :: (Real u, Floating u) -          => Maybe (Arrowhead u) -> Point2 u -> Path u -          -> DrawingR (Path u, Graphic u)-applyTipR Nothing    _   pathc = return (pathc,mempty)-applyTipR (Just arw) ptR pathc = -    retract_dist arw >>= \dx -> -    if dx > 0 then return (shortenR dx pathc, grafik) -              else return (pathc, grafik)-  where-    grafik = (arrow_draw arw) (directionR pathc) ptR +-- 'tipEval' is a bit of an oddity. It has to evaluate the +-- Arrowhead / Image in the DrawingCtx to get the retract +-- distance. But doing so evaluates the tips to PrimGraphics, thus +-- it has to wrap the tips back up as Graphics with @pure@ so they +-- can be concatenated to the drawn path as GraphicTrafos.+--+-- The Arrowhead type could be changed, so rather than returning +-- an Image (retract_distance, PrimGraphic) it returns +-- (retract_distance, GraphicTrafo) but that would burden all +-- arrowheads with some extra complexity.+-- +-- In short - the code here works but it isn\'t exemplary, and it +-- doesn\'t show whether or not GraphicTrafo is a valuable type or+-- if it is implemented correctly (as GraphicTrafo could having+-- different implementations according to how it regards the +-- DrawingCtx).+--++tipEval :: Num u +        => Maybe (Arrowhead u) -> Radian -> Point2 u +        -> DrawingR (u, GraphicTrafoF u)+tipEval Nothing    _     _  = return (0,unmarked)+tipEval (Just arw) theta pt = getArrowhead arw theta pt >>= \(dx,prim) -> +                              return (dx, superior $ pure prim)++++unmarked :: GraphicTrafoF u+unmarked = id++++ 

@@ -13,16 +13,16 @@ -- Anchor points on shapes. -- -- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.+-- change significantly in future revisions. --  --------------------------------------------------------------------------------  module Wumpus.Basic.Arrows.Tips   (  -    Arrowhead(..)-  , arrowheadTip +    Arrowhead(..)+    , tri90   , tri60   , tri45@@ -30,17 +30,39 @@   , otri60   , otri45 +  , revtri90+  , revtri60+  , revtri45+  , orevtri90+  , orevtri60+  , orevtri45+   , barb90   , barb60   , barb45+  , revbarb90+  , revbarb60+  , revbarb45    , perp -  , rbracket+  , bracket +  , diskTip+  , odiskTip+  , squareTip+  , osquareTip+  , diamondTip+  , odiamondTip++  , curveTip+  , revcurveTip+   ) where  import Wumpus.Basic.Graphic+import Wumpus.Basic.Paths+import Wumpus.Basic.Utils.Combinators  import Wumpus.Core                      -- package: wumpus-core @@ -48,15 +70,19 @@  import Control.Applicative -data Arrowhead u = Arrowhead-      { retract_dist :: DrawingR u-      , arrow_draw   :: ThetaLocGraphic u -      } +-- | Encode an arrowhead as an image where the /answer/ is the+-- retract distance.+--+-- The retract distance is context sensitive - usually just on+-- the markHeight (or halfMarkHeight) so it has to be calculated+-- w.r.t. the DrawingCtx.+--+newtype Arrowhead u = Arrowhead { getArrowhead :: ThetaLocImage u u } -arrowheadTip :: Arrowhead u -> Radian -> LocGraphic u-arrowheadTip (Arrowhead _ gf) theta = gf theta ++ -- | Tiplen is length of the tip \*along the line it follows\*.  -- -- > |\@@ -94,7 +120,7 @@     vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len   -{-+ -- | This one is for triangles when the tip height and tip width -- are known. --@@ -107,118 +133,312 @@     rtheta       = pi + theta        -- theta in the opposite direction     vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len     vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len --}    -mark_height_plus_line_width :: (Fractional u, FromPtSize u) => DrawingR u-mark_height_plus_line_width = +{-+markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u+markHeightPlusLineWidth =      (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth+-}  +markHeightLessLineWidth :: (Fractional u, FromPtSize u) => DrawingR u+markHeightLessLineWidth = +    (\h lw -> h - realToFrac lw) <$> markHeight <*> lineWidth ++-- noRetract ignores both the angle and the point.+--+-- Its common for the rectraction not to care about the angle or +-- the point and only care about the DrawingCtx.+--+noRetract :: Num u => ThetaLocDrawingR u u+noRetract = rlift2 $ pure 0 +++ --------------------------------------------------------------------------------  -- | Tripoints takes the \*tip length\* is the mark height. -- -- This means that the 90deg tip has a tip width greater-than the -- mark height (but that is okay - seemingly this is how TikZ --- does it!).+-- does it). -- tripointsByAngle :: (Floating u, FromPtSize u)                  => Radian ->  ThetaLocDrawingR u (Point2 u, Point2 u)-tripointsByAngle triang theta tip = +tripointsByAngle triang theta pt =      (\h -> let (vupper,vlower) = triVecsByAngle h (0.5*triang) theta-           in  (tip .+^ vupper, tip .+^ vlower))+           in  (pt .+^ vupper, pt .+^ vlower))       <$> markHeight  -{-+revtripointsByAngle :: (Floating u, FromPtSize u)+                    => Radian +                    -> ThetaLocDrawingR u (Point2 u, Point2 u, Point2 u)+revtripointsByAngle triang theta pt = +    (\h -> let theta'          = circularModulo $ pi+theta +               (vupper,vlower) = triVecsByAngle h (0.5*triang) theta'+               back_tip        = pt .-^ avec theta h +           in (back_tip .+^ vupper, back_tip, back_tip .+^ vlower) )+      <$> markHeight++ tripointsByDist :: (Real u, Floating u, FromPtSize u)-                => (u -> u) -> (u -> u)  -                -> ThetaLocDrawingR u (Point2 u, Point2 u)-tripointsByDist lenF halfwidthF theta tip = -    (\h -> let (vup,vlo) = triVecsByDist (lenF h) (halfwidthF $ 0.5*h) theta-           in  (tip .+^ vup, tip .+^ vlo))+                => ThetaLocDrawingR u (Point2 u, Point2 u)+tripointsByDist theta pt = +    (\h -> let (vup,vlo) = triVecsByDist h (0.5*h) theta+           in  (pt .+^ vup, pt .+^ vlo))       <$> markHeight--}  +revtripointsByDist :: (Real u, Floating u, FromPtSize u)+                   => ThetaLocDrawingR u (Point2 u, Point2 u, Point2 u)+revtripointsByDist theta pt = +    (\h -> let theta'    = circularModulo $ pi+theta +               (vup,vlo) = triVecsByDist h (0.5*h) theta'+               back_tip  = pt .-^ avec theta h +           in  (back_tip .+^ vup, back_tip, back_tip .+^ vlo))+      <$> markHeight ++ -- width = xchar_height -- filled with stroke colour! -triAng :: (Floating u, Real u, FromPtSize u)+triTLG :: (Floating u, Real u, FromPtSize u)        => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u-triAng triang gf theta pt = -    tripointsByAngle triang theta pt >>= \(u,v) -> -    localize bothStrokeColour (gf $  vertexPath [pt,u,v])+triTLG triang drawF = tripointsByAngle triang `bindR2` \(u,v) -> +    rlift1 $ \pt -> localize bothStrokeColour $ drawF $ vertexPath [pt,u,v]   --- TODO - maybe filling needs to use swapColours + tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri90 = Arrowhead markHeight (triAng (pi/2) filledPath)+tri90 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/2) filledPath)   tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri60 = Arrowhead markHeight (triAng (pi/3) filledPath)+tri60 = Arrowhead $+    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/3) filledPath)   tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-tri45 = Arrowhead markHeight (triAng (pi/4) filledPath)+tri45 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/4) filledPath)  otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri90 = Arrowhead mark_height_plus_line_width (triAng (pi/2) closedStroke)+otri90 = Arrowhead $+    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/2) closedStroke)  otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri60 = Arrowhead mark_height_plus_line_width (triAng (pi/3) closedStroke)+otri60 = Arrowhead $   +    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/3) closedStroke)  otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-otri45 = Arrowhead mark_height_plus_line_width (triAng (pi/4) closedStroke)+otri45 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeight) (triTLG (pi/4) closedStroke)   -barbAng :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u-barbAng ang theta pt = -    tripointsByAngle ang theta pt >>= \(u,v) -> -    openStroke (vertexPath [u,pt,v])+-- width = xchar_height+-- filled with stroke colour! +revtriTLG :: (Floating u, Real u, FromPtSize u)+          => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u+revtriTLG triang drawF = revtripointsByAngle triang `bindR2` \(u,pt,v) -> +    rlift2 $ localize bothStrokeColour $ drawF $ vertexPath [u,pt,v] ++revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+revtri90 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeightLessLineWidth) +                      (revtriTLG (pi/2) filledPath)++revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+revtri60 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeightLessLineWidth) +                      (revtriTLG (pi/3) filledPath)++revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+revtri45 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeightLessLineWidth) +                      (revtriTLG (pi/4) filledPath)+++orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+orevtri90 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeightLessLineWidth) +                      (revtriTLG (pi/2) closedStroke)++orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+orevtri60 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeightLessLineWidth) +                      (revtriTLG (pi/3) closedStroke)++orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+orevtri45 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeightLessLineWidth) +                      (revtriTLG (pi/4) closedStroke)+++barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u+barbTLG ang = tripointsByAngle ang `bindR2` \(u,v) -> +    rlift1 $ \pt -> openStroke $ vertexPath [u,pt,v]++ barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb90 = Arrowhead (pure 0) (barbAng (pi/2))+barb90 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/2))  barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb60 = Arrowhead (pure 0) (barbAng (pi/3))+barb60 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/3))   barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u-barb45 = Arrowhead (pure 0) (barbAng (pi/4))+barb45 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/4))   -perpAng :: (Floating u, FromPtSize u) => ThetaLocGraphic u-perpAng theta pt =  -    markHeight >>= \ h -> -    let v = makeV h in openStroke $ vertexPath [ pt .+^ v, pt .-^ v]-  where-    makeV h  = avec (theta + pi/2) (0.5 * h)+revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u+revbarbTLG ang = revtripointsByAngle ang `bindR2` \(u,pt,v) -> +    rlift2 $ openStroke $ vertexPath [u,pt,v] +revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+revbarb90 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/2)) ++revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+revbarb60 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/3))++revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u+revbarb45 = Arrowhead $ +    intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/4))+++perpTLG :: (Floating u, FromPtSize u) => ThetaLocGraphic u+perpTLG = bindAskR2 markHalfHeight $ \hh ->+    \theta pt -> let p0 = displacePerpendicular   hh  theta pt+                     p1 = displacePerpendicular (-hh) theta pt  +                 in straightLineBetween p0 p1++ perp :: (Floating u, FromPtSize u) => Arrowhead u-perp = Arrowhead (pure 0) perpAng+perp = Arrowhead $ intoThetaLocImage noRetract perpTLG -rbracketAng :: (Floating u, FromPtSize u) => ThetaLocGraphic u-rbracketAng theta pt = markHalfHeight >>= \hh -> -   runDirection theta $ -     displacePerp   hh  pt >>= \p1 ->-     displacePara (-hh) p1 >>= \p0 ->-     displacePerp (-hh) pt >>= \p2 ->-     displacePara (-hh) p2 >>= \p3 ->-     return (openStroke $ vertexPath [p0,p1,p2,p3]) -    -rbracket :: (Floating u, FromPtSize u) => Arrowhead u-rbracket = Arrowhead (pure 0) rbracketAng++bracketTLG :: (Floating u, FromPtSize u) => ThetaLocGraphic u+bracketTLG = bindAskR2 markHalfHeight $ \hh -> +    \theta pt -> let p1 = displacePerpendicular   hh  theta pt+                     p0 = displaceParallel      (-hh) theta p1+                     p2 = displacePerpendicular (-hh) theta pt+                     p3 = displaceParallel      (-hh) theta p2+                 in openStroke $ vertexPath [p0,p1,p2,p3]+++++bracket :: (Floating u, FromPtSize u) => Arrowhead u+bracket = Arrowhead $ intoThetaLocImage noRetract bracketTLG++diskTLG :: (Floating u, FromPtSize u) +        => (u -> Point2 u -> Graphic u) -> ThetaLocGraphic u+diskTLG drawF = bindAskR2 markHalfHeight $ \hh ->+    \theta pt -> let ctr = pt .-^ avec theta hh+                 in drawF hh ctr++diskTip :: (Floating u, FromPtSize u) => Arrowhead u+diskTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (diskTLG drawF)+  where+    drawF r pt = localize bothStrokeColour $ filledDisk r pt+++odiskTip :: (Floating u, FromPtSize u) => Arrowhead u+odiskTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (diskTLG drawF)+  where+    drawF r pt = strokedDisk r pt+++squareTLG :: (Floating u, FromPtSize u) +        => (PrimPath u -> Graphic u) -> ThetaLocGraphic u+squareTLG drawF = bindAskR2 markHalfHeight $ \hh ->+    \theta pt -> let p0 = displacePerpendicular     hh  theta pt+                     p3 = displacePerpendicular   (-hh) theta pt+                     p1 = displaceParallel      (-2*hh) theta p0+                     p2 = displaceParallel      (-2*hh) theta p3+                 in drawF $ vertexPath [p0,p1,p2,p3]++squareTip :: (Floating u, FromPtSize u) => Arrowhead u+squareTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (squareTLG drawF)+  where+    drawF = localize bothStrokeColour . filledPath+++osquareTip :: (Floating u, FromPtSize u) => Arrowhead u+osquareTip = Arrowhead $ +    intoThetaLocImage (rlift2 markHeight) (squareTLG closedStroke)+++diamondTLG :: (Floating u, FromPtSize u) +           => (PrimPath u -> Graphic u) -> ThetaLocGraphic u+diamondTLG drawF = bindAskR2 markHalfHeight $ \hh ->+    \theta pt -> let ctr = displaceParallel       (-2*hh) theta pt+                     p1  = displacePerpendicular     hh   theta ctr+                     p3  = displacePerpendicular   (-hh)  theta ctr+                     p2  = displaceParallel       (-4*hh) theta pt+                 in drawF $ vertexPath [pt,p1,p2,p3]+++diamondTip :: (Floating u, FromPtSize u) => Arrowhead u+diamondTip = Arrowhead $ +    intoThetaLocImage (rlift2 $ fmap (2*) markHeightLessLineWidth) +                      (diamondTLG drawF)+  where+    drawF = localize bothStrokeColour . filledPath+++odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u+odiamondTip = Arrowhead $ +    intoThetaLocImage (rlift2 $ fmap (2*) markHeight) (diamondTLG closedStroke)+++-- Note - points flipped to get the second trapezium to +-- draw /underneath/.+--+curveTLG :: (Real u, Floating u, FromPtSize u) => ThetaLocGraphic u+curveTLG theta pt = +    markHalfHeight           >>= \hh        -> +    tripointsByDist theta pt >>= \(tup,tlo) -> +    let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup+        (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt +        tpath   = curve tup u2 u1 pt `append` curve pt l1 l2 tlo+    in localize (joinRound . capRound) +                (openStroke $ toPrimPath $ tpath)++curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u+curveTip = Arrowhead $ +    intoThetaLocImage (rlift2 $ fmap realToFrac lineWidth) curveTLG+++-- Note - points flipped to get the second trapezium to +-- draw /underneath/.+--+revcurveTLG :: (Real u, Floating u, FromPtSize u) => ThetaLocGraphic u+revcurveTLG theta pt = +    markHalfHeight              >>= \hh           -> +    revtripointsByDist theta pt >>= \(tup,p1,tlo) -> +    let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup+        (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1+        tpath   = curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo+    in localize (joinRound . capRound) +                (openStroke $ toPrimPath $ tpath)++revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u+revcurveTip = Arrowhead $ +    intoThetaLocImage (rlift2 markHeight) revcurveTLG

@@ -1,231 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Dots--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Dots with anchors.------ In many cases a surrounding circle is used to locate anchor--- points - this could be improved to use the actual dot border --- at some point.--------------------------------------------------------------------------------------module Wumpus.Basic.Dots-  ( --  -- * Existential anchor type-    DotAnchor- -  , DotLocImage-  , DDotLocImage--  -- * Dots with anchor points-  , dotChar-  , dotText-  , dotHLine-  , dotVLine-  , dotX-  , dotPlus-  , dotCross-  , dotDiamond-  , dotFDiamond--  , dotDisk-  , dotSquare-  , dotCircle-  , dotPentagon-  , dotStar--  , dotAsterisk-  , dotOPlus-  , dotOCross-  , dotFOCross--  ) where--import Wumpus.Basic.Anchors-import Wumpus.Basic.Dots.Primitive-import Wumpus.Basic.Graphic-import Wumpus.Basic.Utils.Intersection--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Applicative----- An existential thing that supports anchors.--- This means any dot can retun the same (opaque) structure------ But it does mean that which anchor class are supported is --- fixed - the datatype needs a field for each one.--- Supporting north, southeast etc. will also be tedious...----data DotAnchor u = forall s.  -                    DotAnchor { center_anchor   :: Point2 u-                              , radial_anchor   :: Radian   -> Point2 u-                              , cardinal_anchor :: Cardinal -> Point2 u }--data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW-  deriving (Eq,Show) --type instance DUnit (DotAnchor u) = u--instance CenterAnchor (DotAnchor u) where-  center (DotAnchor ca _ _) = ca--instance RadialAnchor (DotAnchor u) where-   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----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---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) ----- 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) ---rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u-rectangleAnchor hw hh ctr = -    DotAnchor { center_anchor   = ctr-              , radial_anchor   = fn  -              , cardinal_anchor = rectCardinal hw hh ctr }-  where-    fn theta =  maybe ctr id $ findIntersect ctr theta -                             $ rectangleLines ctr hw hh--rectangleLDO :: (Real u, Floating u) -             => u -> u -> LocDrawingR u (DotAnchor u)-rectangleLDO w h pt = pure $ rectangleAnchor (w*0.5) (h*0.5) pt---circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u-circleAnchor rad ctr = DotAnchor ctr -                                 (\theta -> ctr .+^ (avec theta rad))-                                 (radialCardinal rad ctr)--circleLDO :: (Floating u, FromPtSize u) => LocDrawingR u (DotAnchor u)-circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> markHeight --------------------------------------------------------------------------------------type DotLocImage u = LocImage u (DotAnchor u) --type DDotLocImage = DotLocImage Double --dotChar :: (Floating u, Real u, FromPtSize u) -        => Char -> DotLocImage u-dotChar ch pt = monoTextDimensions [ch] >>= \(w,h) -> -                intoLocImage (rectangleLDO w h) (markChar ch) pt---dotText :: (Floating u, Real u, FromPtSize u) -        => String -> DotLocImage u -dotText ss pt = monoTextDimensions ss >>= \(w,h) -> -                intoLocImage (rectangleLDO w h) (markText ss) pt---dotHLine :: (Floating u, FromPtSize u) => DotLocImage u-dotHLine = intoLocImage circleLDO markHLine---dotVLine :: (Floating u, FromPtSize u) => DotLocImage u-dotVLine = intoLocImage circleLDO markVLine---dotX :: (Floating u, FromPtSize u) => DotLocImage u-dotX = intoLocImage circleLDO markX--dotPlus :: (Floating u, FromPtSize u) => DotLocImage u-dotPlus = intoLocImage circleLDO markPlus--dotCross :: (Floating u, FromPtSize u) => DotLocImage u-dotCross = intoLocImage circleLDO markCross--dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u-dotDiamond = intoLocImage circleLDO markDiamond--dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u-dotFDiamond = intoLocImage circleLDO markFDiamond----dotDisk :: (Floating u, FromPtSize u) => DotLocImage u-dotDisk = intoLocImage circleLDO markDisk---dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u-dotSquare pt = markHeight >>= \ h ->-               intoLocImage (rectangleLDO h h) markSquare pt-----dotCircle :: (Floating u, FromPtSize u) => DotLocImage u-dotCircle = intoLocImage circleLDO markCircle---dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u-dotPentagon = intoLocImage circleLDO markPentagon--dotStar :: (Floating u, FromPtSize u) => DotLocImage u-dotStar = intoLocImage circleLDO markStar---dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u-dotAsterisk = intoLocImage circleLDO markAsterisk--dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u-dotOPlus = intoLocImage circleLDO markOPlus--dotOCross :: (Floating u, FromPtSize u) => DotLocImage u-dotOCross = intoLocImage circleLDO markOCross--dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u-dotFOCross = intoLocImage circleLDO markFOCross

@@ -0,0 +1,232 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Dots.AnchorDots+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Dots with anchors.+--+-- In many cases a surrounding circle is used to locate anchor+-- points - this could be improved to use the actual dot border +-- at some point.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Dots.AnchorDots+  ( ++  -- * Existential anchor type+    DotAnchor+ +  , DotLocImage+  , DDotLocImage++  -- * Dots with anchor points+  , dotChar+  , dotText+  , dotHLine+  , dotVLine+  , dotX+  , dotPlus+  , dotCross+  , dotDiamond+  , dotFDiamond++  , dotDisk+  , dotSquare+  , dotCircle+  , dotPentagon+  , dotStar++  , dotAsterisk+  , dotOPlus+  , dotOCross+  , dotFOCross++  ) where++import Wumpus.Basic.Anchors+import Wumpus.Basic.Dots.Marks+import Wumpus.Basic.Graphic+import Wumpus.Basic.Utils.Combinators+import Wumpus.Basic.Utils.Intersection++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative+++-- An existential thing that supports anchors.+-- This means any dot can retun the same (opaque) structure+--+-- But it does mean that which anchor class are supported is +-- fixed - the datatype needs a field for each one.+-- Supporting north, southeast etc. will also be tedious...+--+data DotAnchor u = forall s.  +                    DotAnchor { center_anchor   :: Point2 u+                              , radial_anchor   :: Radian   -> Point2 u+                              , cardinal_anchor :: Cardinal -> Point2 u }++data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW+  deriving (Eq,Show) ++type instance DUnit (DotAnchor u) = u++instance CenterAnchor (DotAnchor u) where+  center (DotAnchor ca _ _) = ca++instance RadialAnchor (DotAnchor u) where+   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++++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+++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) +++-- 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) +++rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u+rectangleAnchor hw hh ctr = +    DotAnchor { center_anchor   = ctr+              , radial_anchor   = fn  +              , cardinal_anchor = rectCardinal hw hh ctr }+  where+    fn theta =  maybe ctr id $ findIntersect ctr theta +                             $ rectangleLines ctr hw hh++rectangleLDO :: (Real u, Floating u) +             => u -> u -> LocDrawingR u (DotAnchor u)+rectangleLDO w h pt = pure $ rectangleAnchor (w*0.5) (h*0.5) pt+++circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u+circleAnchor rad ctr = DotAnchor ctr +                                 (\theta -> ctr .+^ (avec theta rad))+                                 (radialCardinal rad ctr)++circleLDO :: (Floating u, FromPtSize u) => LocDrawingR u (DotAnchor u)+circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> markHeight ++++--------------------------------------------------------------------------------++type DotLocImage u = LocImage u (DotAnchor u) ++type DDotLocImage = DotLocImage Double ++dotChar :: (Floating u, Real u, FromPtSize u) +        => Char -> DotLocImage u+dotChar ch = bindAsk (monoTextDimensions [ch]) $  \(w,h) -> +    intoLocImage (rectangleLDO w h) (markChar ch)+++dotText :: (Floating u, Real u, FromPtSize u) +        => String -> DotLocImage u +dotText ss = bindAsk (monoTextDimensions ss) $ \(w,h) -> +    intoLocImage (rectangleLDO w h) (markText ss) +++dotHLine :: (Floating u, FromPtSize u) => DotLocImage u+dotHLine = intoLocImage circleLDO markHLine+++dotVLine :: (Floating u, FromPtSize u) => DotLocImage u+dotVLine = intoLocImage circleLDO markVLine+++dotX :: (Floating u, FromPtSize u) => DotLocImage u+dotX = intoLocImage circleLDO markX++dotPlus :: (Floating u, FromPtSize u) => DotLocImage u+dotPlus = intoLocImage circleLDO markPlus++dotCross :: (Floating u, FromPtSize u) => DotLocImage u+dotCross = intoLocImage circleLDO markCross++dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u+dotDiamond = intoLocImage circleLDO markDiamond++dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u+dotFDiamond = intoLocImage circleLDO markFDiamond++++dotDisk :: (Floating u, FromPtSize u) => DotLocImage u+dotDisk = intoLocImage circleLDO markDisk+++dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u+dotSquare = bindAsk markHeight $ \ h ->+    intoLocImage (rectangleLDO h h) markSquare+++++dotCircle :: (Floating u, FromPtSize u) => DotLocImage u+dotCircle = intoLocImage circleLDO markCircle+++dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u+dotPentagon = intoLocImage circleLDO markPentagon++dotStar :: (Floating u, FromPtSize u) => DotLocImage u+dotStar = intoLocImage circleLDO markStar+++dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u+dotAsterisk = intoLocImage circleLDO markAsterisk++dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u+dotOPlus = intoLocImage circleLDO markOPlus++dotOCross :: (Floating u, FromPtSize u) => DotLocImage u+dotOCross = intoLocImage circleLDO markOCross++dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u+dotFOCross = intoLocImage circleLDO markFOCross

@@ -0,0 +1,227 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Dots.Marks+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Marks - dots without anchor handles.+--+-- \*\* WARNING \*\* - names are expected to change - filled and+-- background-filled marks need a naming convention.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Dots.Marks+  ( +++  -- * Marks+    markChar+  , markText++  , markHLine+  , markVLine+  , markX+  , markPlus+  , markCross+  , markDiamond+  , markFDiamond+  , markBDiamond +  , markDisk+  , markSquare+  , markCircle  +  , markPentagon+  , markStar+  , markAsterisk+  , markOPlus+  , markOCross+  , markFOCross+++  ) where+++import Wumpus.Basic.Graphic+import Wumpus.Basic.Utils.Combinators++import Wumpus.Core                      -- package: wumpus-core++import Data.AffineSpace                 -- package: vector-space+import Data.VectorSpace++import Control.Applicative+import Data.List++-- Marks should be the height of a lower-case letter...++-- NOTES+--+-- TikZ has both stroked and bordered (filled and outline-stroked)+-- marks e.g. square and square*+--+++-- | 'polygonPoints' : @ num_points * radius * center -> [point] @ +--+polygonPoints :: Floating u => Int -> u -> Point2 u -> [Point2 u]+polygonPoints 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+++++shiftOrigin :: Num u => u -> u -> LocGraphic u -> LocGraphic u+shiftOrigin dx dy f = \pt -> f (displace dx dy pt)++markChar :: (Fractional u, Ord u, FromPtSize u) => Char -> LocGraphic u+markChar ch = markText [ch]+++++markText :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u+markText ss = centermonoTextline ss++++++-- | Supplied point is the center.+--+axialLine :: Fractional u => Vec2 u -> LocGraphic u+axialLine v = localPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)+++markHLine :: (Fractional u, FromPtSize u) => LocGraphic u +markHLine = bindAsk markHeight $ \h -> axialLine (hvec h)+++markVLine :: (Fractional u, FromPtSize u) => LocGraphic u +markVLine = bindAsk markHeight $ \h -> axialLine (vvec h) +++markX :: (Fractional u, FromPtSize u) => LocGraphic u+markX = bindAsk markHeight $ \h -> +    let w = 0.75 * h in axialLine (vec w h) `oplus` axialLine (vec (-w) h)++++markPlus :: (Fractional u, FromPtSize u) =>  LocGraphic u+markPlus = markVLine `oplus` markHLine+++markCross :: (Floating u, FromPtSize u) =>  LocGraphic u+markCross = bindAsk markHeight $ \h ->  +    (axialLine $ avec ang h) `oplus` (axialLine $ avec (-ang) h)+  where+    ang = pi*0.25  ++-- needs horizontal pinch...++pathDiamond :: (Fractional u, FromPtSize u) +            => Point2 u -> DrawingR (PrimPath u)+pathDiamond pt = (\h -> let hh    = 0.66 * h; hw = 0.5 * h +                        in vertexPath [dvs hh, dve hw,dvn hh, dvw hw])+                   <$> markHeight+  where+    dvs hh = pt .+^ vvec (-hh)+    dve hw = pt .+^ hvec hw+    dvn hh = pt .+^ vvec hh+    dvw hw = pt .+^ hvec (-hw)++++markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markDiamond = pathDiamond `bindInto` closedStroke  ++markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markFDiamond = pathDiamond `bindInto` filledPath+++-- Note - the (const . fn) composition doesn\'t /tell/ much about+-- what is going on - though obviously it can be decoded - make +-- the function obvious to the second argument. +-- +-- A named combinator might be better.+--++markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u+markBDiamond = pathDiamond `bindInto` borderedPath+++-- | Note disk is filled.+--+markDisk :: (Fractional u, FromPtSize u) => LocGraphic u+markDisk = bindAsk markHalfHeight filledDisk ++++markSquare :: (Fractional u, FromPtSize u) => LocGraphic u+markSquare = bindAsk markHeight $ \h -> +    let d = 0.5*(-h) in shiftOrigin d d $ strokedRectangle h h+    +++markCircle :: (Fractional u, FromPtSize u) => LocGraphic u+markCircle = bindAsk markHalfHeight strokedDisk +++markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u+markBCircle = bindAsk markHalfHeight borderedDisk ++++markPentagon :: (Floating u, FromPtSize u) => LocGraphic u+markPentagon = bindAsk markHeight $ \h ->+    closedStroke . vertexPath . polygonPoints 5 (0.5*h)++ +++markStar :: (Floating u, FromPtSize u) => LocGraphic u +markStar pt = markHeight >>= \h -> +              let ps = polygonPoints 5 (0.5*h) pt in step $ map fn ps+  where+    fn p1       = openStroke $ path pt [lineTo p1] +    step (x:xs) = oconcat x xs+    step _      = error "markStar - unreachable"+++-- Note - relies on the functional instance of OPlus++markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u+markAsterisk = bindAsk markHeight $ \h -> +    lineF1 h `oplus` lineF2 h `oplus` lineF3 h+  where+    ang       = (pi*2) / 6+    lineF1 z  = axialLine (vvec z)+    lineF2 z  = axialLine (avec ((pi*0.5) + ang)    z)+    lineF3 z  = axialLine (avec ((pi*0.5) + ang + ang) z)++++markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u+markOPlus = markCircle `oplus` markPlus+++markOCross :: (Floating u, FromPtSize u) => LocGraphic u+markOCross = markCircle `oplus` markCross+++markFOCross :: (Floating u, FromPtSize u) => LocGraphic u+markFOCross = markCross `oplus` markBCircle +++-- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u+-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) +

@@ -1,233 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Dots.Primitive--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Marks - dots without anchor handles.------ \*\* WARNING \*\* - names are expected to change - filled and--- background-filled marks need a naming convention.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Dots.Primitive-  ( ---  -- * Marks-    markChar-  , markText--  , markHLine-  , markVLine-  , markX-  , markPlus-  , markCross-  , markDiamond-  , markFDiamond-  , markBDiamond -  , markDisk-  , markSquare-  , markCircle  -  , markPentagon-  , markStar-  , markAsterisk-  , markOPlus-  , markOCross-  , markFOCross---  ) where---import Wumpus.Basic.Graphic--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space-import Data.VectorSpace--import Control.Applicative-import Data.List-import Data.Monoid---- Marks should be the height of a lower-case letter...---- NOTES------ TikZ has both stroked and bordered (filled and outline-stroked)--- marks e.g. square and square*-------- | 'polygonPoints' : @ num_points * radius * center -> [point] @ ----polygonPoints :: Floating u => Int -> u -> Point2 u -> [Point2 u]-polygonPoints 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------ | A mark is the height of a lowercase \'x\'.--- -standardSize :: FromPtSize u => (u -> LocGraphic u) -> LocGraphic u-standardSize f = \pt -> markHeight >>= \h -> f h pt--halfHeightSize :: (Fractional u, FromPtSize u) -               => (u -> LocGraphic u) -> LocGraphic u-halfHeightSize f = \pt -> markHeight >>= \h -> f (h * 0.5) pt----shiftOrigin :: Num u => u -> u -> LocGraphic u -> LocGraphic u-shiftOrigin dx dy f = \pt -> f (displace dx dy pt)--markChar :: (Fractional u, Ord u, FromPtSize u) => Char -> LocGraphic u-markChar ch = markText [ch]------- Note - eta-expanded (?)----markText :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u-markText ss = centermonoTextline ss-------- | Supplied point is the center.----axialLine :: Fractional u => Vec2 u -> LocGraphic u-axialLine v = localPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)----markHLine :: (Fractional u, FromPtSize u) => LocGraphic u -markHLine = standardSize $ \h -> axialLine (hvec h)-    --markVLine :: (Fractional u, FromPtSize u) => LocGraphic u -markVLine = standardSize $ \h -> axialLine (vvec h) ---markX :: (Fractional u, FromPtSize u) => LocGraphic u-markX = standardSize $ \h -> -    let w = 0.75 * h -    in mappend <$> axialLine (vec w h) <*> axialLine (vec (-w) h)----markPlus :: (Fractional u, FromPtSize u) =>  LocGraphic u-markPlus = mappend <$> markVLine <*> markHLine---markCross :: (Floating u, FromPtSize u) =>  LocGraphic u-markCross = standardSize $ \h -> -    mappend <$> axialLine (avec ang h) <*> axialLine (avec (-ang) h)-  where-    ang = pi*0.25  ------ needs horizontal pinch...--pathDiamond :: (Fractional u, FromPtSize u) -            => Point2 u -> DrawingR (PrimPath u)-pathDiamond pt = (\h -> let hh    = 0.66 * h; hw = 0.5 * h -                        in vertexPath [dvs hh, dve hw,dvn hh, dvw hw])-                   <$> markHeight-  where-    dvs hh = pt .+^ vvec (-hh)-    dve hw = pt .+^ hvec hw-    dvn hh = pt .+^ vvec hh-    dvw hw = pt .+^ hvec (-hw)----markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markDiamond = \pt -> pathDiamond pt >>= closedStroke  --markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markFDiamond = \pt -> pathDiamond pt >>= filledPath  --markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u-markBDiamond = \pt -> pathDiamond pt >>= borderedPath----- | Note disk is filled.----markDisk :: (Fractional u, FromPtSize u) => LocGraphic u-markDisk = halfHeightSize filledDisk ----markSquare :: (Fractional u, FromPtSize u) => LocGraphic u-markSquare = standardSize (\h -> let d = 0.5*(-h) in -                                 shiftOrigin d d $ strokedRectangle h h) -    ---markCircle :: (Fractional u, FromPtSize u) => LocGraphic u-markCircle = halfHeightSize strokedDisk ---markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u-markBCircle = halfHeightSize borderedDisk ----markPentagon :: (Floating u, FromPtSize u) => LocGraphic u-markPentagon pt = markHeight >>= \h ->-                  closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt-- ---markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar pt = markHeight >>= \h -> -              let ps = polygonPoints 5 (0.5*h) pt in mconcat $ map fn ps-  where-    fn p1  = openStroke $ path pt [lineTo p1] -----markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u-markAsterisk = standardSize $ \h -> -    (\a b c -> a `mappend` b `mappend` c) <$> lineF1 h <*> lineF2 h <*> lineF3 h-  where-    ang       = (pi*2) / 6-    lineF1 z  = axialLine (vvec z)-    lineF2 z  = axialLine (avec ((pi*0.5) + ang)    z)-    lineF3 z  = axialLine (avec ((pi*0.5) + ang + ang) z)----markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u-markOPlus = mappend <$> markCircle <*> markPlus---markOCross :: (Floating u, FromPtSize u) => LocGraphic u-markOCross = mappend <$> markCircle <*> markCross---markFOCross :: (Floating u, FromPtSize u) => LocGraphic u-markFOCross = liftA2 mappend markCross markBCircle ----- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u--- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) -

@@ -18,7 +18,6 @@ module Wumpus.Basic.Graphic   (     module Wumpus.Basic.Graphic.Base-  , module Wumpus.Basic.Graphic.DirectionContext   , module Wumpus.Basic.Graphic.Drawing   , module Wumpus.Basic.Graphic.DrawingContext   , module Wumpus.Basic.Graphic.PrimGraphic@@ -27,7 +26,6 @@   ) where  import Wumpus.Basic.Graphic.Base-import Wumpus.Basic.Graphic.DirectionContext import Wumpus.Basic.Graphic.Drawing import Wumpus.Basic.Graphic.DrawingContext import Wumpus.Basic.Graphic.PrimGraphic

@@ -1,4 +1,6 @@ {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -41,15 +43,22 @@  module Wumpus.Basic.Graphic.Base   (-    ++  -- A semigroup class.+    OPlus(..)+  , oconcat+  , anterior    +  , superior+   -- * Drawing monads.-    MonUnit+  , MonUnit   , TraceM(..)   , DrawingCtxM(..)   , asksDC     , PointSupplyM(..) +   -- * Base types   , HPrim   , hprimToList@@ -62,12 +71,23 @@   , LocDrawingR   , DLocDrawingR +  , DrawingTrafoF +   , runDrawingR +  , PrimGraphic+  , getPrimGraphic+  , wrapPrim++  , collectH+   , Graphic   , DGraphic-  +  , GraphicTrafoF +  , superiorGraphic+  , anteriorGraphic  +   , runGraphic   , xlinkGraphic @@ -76,6 +96,12 @@    , Image   , DImage++  , ImageTrafoF+  , intoImageTrafo+  , imageTrafoDrawing+  , imageTrafoGraphic+   , LocImage   , DLocImage @@ -100,9 +126,13 @@   , ThetaLocImage   , DThetaLocImage +  , intoThetaLocImage++   ) where  import Wumpus.Basic.Graphic.DrawingContext+import Wumpus.Basic.Utils.Combinators import Wumpus.Basic.Utils.HList  import Wumpus.Core                      -- package: wumpus-core@@ -112,6 +142,50 @@ import Data.Monoid  ++infixr 6 `oplus`++-- | A Semigroup class.+-- +class OPlus t where+  oplus :: t -> t -> t++oconcat :: OPlus t => t -> [t] -> t+oconcat t = step t+  where+    step ac []     = ac+    step ac (x:xs) = step (ac `oplus` x) xs++anterior :: OPlus t => t -> (t -> t)+anterior a = (a `oplus`)++superior :: OPlus t => t -> (t -> t)+superior a = (`oplus` a)+++++-- Note - this produces tall-skinny trees in Wumpus-core.+-- This does not impact on the generated PostScript but it is +-- (probably) inefficient for traversals in Wumpus.+--+-- There is scope to modify the Primitive type in Wumpus-Core +-- (make Group indepenent of XLink) so wider trees can be made.++instance OPlus (Primitive u) where+  a `oplus` b = primGroup [a,b]++instance (OPlus a, OPlus b) => OPlus (a,b) where+  (a,b) `oplus` (a',b') = (a `oplus` a', b `oplus` b')+++instance OPlus a => OPlus (r -> a) where+  f `oplus` g = \x -> f x `oplus` g x++-- The functional instance (r -> a) also covers (r1 -> r2 -> a),+-- (r1 -> r2 -> r3 -> a) etc.++ -------------------------------------------------------------------------------- -- Monadic drawing @@ -166,7 +240,7 @@ -- representation, and a Hughes list which supports -- efficient concatenation is wise. ---newtype HPrim u = HPrim { getHPrim :: H (PrimElement u) }+newtype HPrim u = HPrim { getHPrim :: H (Primitive u) }  -- Note - only a Monoid instance for HPrim - they cannot be  -- shown, fmapped etc.@@ -176,11 +250,11 @@   ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb  -hprimToList :: HPrim u -> [PrimElement u]+hprimToList :: HPrim u -> [Primitive u] hprimToList = toListH . getHPrim  -singleH :: PrimElement u -> HPrim u+singleH :: Primitive u -> HPrim u singleH = HPrim . wrapH   -- | Point transformation function.@@ -206,6 +280,11 @@ instance Functor DrawingR where   fmap f ma = DrawingR $ \ctx -> f $ getDrawingR ma ctx  ++instance OPlus a => OPlus (DrawingR a)  where+  fa `oplus` fb = DrawingR $ \ctx -> +                      getDrawingR fa ctx `oplus` getDrawingR fb ctx+ -- The monoid instance seems sensible... -- instance Monoid a => Monoid (DrawingR a) where @@ -247,26 +326,112 @@ type DLocDrawingR a = LocDrawingR Double a  +type DrawingTrafoF a = DrawingR a -> DrawingR a+++++-- Affine instances - cannot be manufactured. There is no +-- DUnit @u@ to get a handle on.+--+ -------------------------------------------------------------------------------- +-- As of version 0.36.0, Wumpus-Core supports grouping primitives+-- together (a common operation in vector drawing editors). +--+-- For Wumpus-Basic this means e.g. a line with arrowheads can +-- still be a primitive.+--+-- Still, we wrap Primitive as a newtype...+-- --- Simple drawing - representing one or more prims+newtype PrimGraphic u = PrimGraphic { getPrimGraphic :: Primitive u }+  deriving (Eq,Show) -type Graphic u = DrawingR (HPrim u)+type instance DUnit (PrimGraphic u) = u +instance OPlus (PrimGraphic u) where+  oplus a b = PrimGraphic $ getPrimGraphic a `oplus` getPrimGraphic b+++-- Affine transformations++instance (Real u, Floating u) => Rotate (PrimGraphic u) where+  rotate ang = PrimGraphic . rotate ang . getPrimGraphic+++instance (Real u, Floating u) => RotateAbout (PrimGraphic u) where+  rotateAbout ang pt = PrimGraphic . rotateAbout ang pt . getPrimGraphic+++instance Num u => Scale (PrimGraphic u) where+  scale sx sy = PrimGraphic . scale sx sy . getPrimGraphic+++instance Num u => Translate (PrimGraphic u) where+  translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic+++wrapPrim :: Primitive u -> PrimGraphic u +wrapPrim = PrimGraphic++collectH :: PrimGraphic u -> HPrim u+collectH = singleH . getPrimGraphic++--------------------------------------------------------------------------------++-- Simple drawing - produce a primitive, access the DrawingContext+-- if required.++type Graphic u = DrawingR (PrimGraphic u)+ type DGraphic = Graphic Double +type instance DUnit (Graphic u) = u -runGraphic :: DrawingContext -> Graphic u -> HPrim u++runGraphic :: DrawingContext -> Graphic u -> PrimGraphic u runGraphic ctx gf = (getDrawingR gf) ctx   xlinkGraphic :: XLink -> Graphic u -> Graphic u xlinkGraphic xlink gf = DrawingR $ \ctx -> -    let xs = hprimToList $ runGraphic ctx gf -    in (singleH $ xlinkGroup xlink xs)+    let a = runGraphic ctx gf +    in PrimGraphic $ xlinkGroup xlink [getPrimGraphic a]  +-- Affine instances++instance (Real u, Floating u) => Rotate (Graphic u) where+  rotate ang = liftA (rotate ang) +++instance (Real u, Floating u) => RotateAbout (Graphic u) where+  rotateAbout ang pt = liftA (rotateAbout ang pt)+++instance Num u => Scale (Graphic u) where+  scale sx sy = liftA (scale sx sy)+++instance Num u => Translate (Graphic u) where+  translate dx dy = liftA (translate dx dy)+++++type GraphicTrafoF u = Graphic u -> Graphic u++anteriorGraphic :: Graphic u -> GraphicTrafoF u+anteriorGraphic = anterior++superiorGraphic :: Graphic u -> GraphicTrafoF u+superiorGraphic = superior++++ --------------------------------------------------------------------------------  @@ -290,32 +455,72 @@ -- typical example - nodes are drawing but the also support  -- taking anchor points. ---type Image u a = DrawingR (a, HPrim u)+type Image u a = DrawingR (a, PrimGraphic u)  type DImage a = Image Double a -type LocImage u a = Point2 u -> Image u a+type instance DUnit (Image u a) = u -type DLocImage a = LocImage Double a -runImage :: DrawingContext -> Image u a -> (a,HPrim u)++runImage :: DrawingContext -> Image u a -> (a, PrimGraphic u) runImage ctx img = (getDrawingR img) ctx   intoImage :: DrawingR a -> Graphic u -> Image u a-intoImage f g = DrawingR $ \ctx -> -    let a = getDrawingR f ctx; o = getDrawingR g ctx in (a,o)+intoImage f g = forkA f g  +-- Affine instances++instance (Real u, Floating u, Rotate a, DUnit a ~ u) => +    Rotate (Image u a) where+  rotate ang = liftA (prod (rotate ang) (rotate ang))+++instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => +    RotateAbout (Image u a) where+  rotateAbout ang pt = liftA (prod (rotateAbout ang pt) (rotateAbout ang pt))+++instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where+  scale sx sy = liftA (prod (scale sx sy) (scale sx sy))+++instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where+  translate dx dy = liftA (prod (translate dx dy) (translate dx dy))++++type ImageTrafoF u a = Image u a -> Image u a+++++intoImageTrafo :: DrawingTrafoF a -> GraphicTrafoF u -> ImageTrafoF u a+intoImageTrafo df gf img = img >>= \(a,prim) -> +    intoImage (df $ pure a) (gf $ pure prim)++imageTrafoDrawing :: DrawingTrafoF a -> ImageTrafoF u a+imageTrafoDrawing df = intoImageTrafo df id++imageTrafoGraphic :: GraphicTrafoF u -> ImageTrafoF u a+imageTrafoGraphic gf = intoImageTrafo id gf++++type LocImage u a = Point2 u -> Image u a++type DLocImage a = LocImage Double a+ intoLocImage :: LocDrawingR u a -> LocGraphic u -> LocImage u a-intoLocImage f g pt = DrawingR $ \ctx -> -    let a = getDrawingR (f pt) ctx; o = getDrawingR (g pt) ctx in (a,o)+intoLocImage f g pt = forkA (f pt) (g pt)   xlinkImage :: XLink -> Image u a -> Image u a xlinkImage xlink img = DrawingR $ \ctx -> -    let (a,hp) = runImage ctx img -    in (a, singleH $ xlinkGroup xlink $ hprimToList hp)+    let (a,pg) = runImage ctx img +    in (a, PrimGraphic $ xlinkGroup xlink [getPrimGraphic pg])  -------------------------------------------------------------------------------- --@@ -331,9 +536,12 @@  type DConnectorGraphic = ConnectorGraphic Double --- | ConImage is a connector drawn between two points +-- | ConnectorImage is a connector drawn between two points  -- constructing an Image. --+-- Usually the answer type of a ConnectorImage will be a Path so+-- the Points ar @midway@, @atstart@ etc. can be taken on it.+-- type ConnectorImage u a = Point2 u -> Point2 u -> Image u a  type DConnectorImage a = ConnectorImage Double a@@ -342,9 +550,7 @@ intoConnectorImage :: ConnectorDrawingR u a                     -> ConnectorGraphic u                     -> ConnectorImage u a-intoConnectorImage f g p1 p2 = DrawingR $ \ctx -> -    let a = getDrawingR (f p1 p2) ctx; o = getDrawingR (g p1 p2) ctx in (a,o)-+intoConnectorImage f g p1 p2 = forkA (f p1 p2) (g p1 p2)   type ThetaLocDrawingR u a = Radian -> LocDrawingR u a @@ -362,5 +568,9 @@ type DThetaLocImage a = ThetaLocImage Double a   +intoThetaLocImage :: ThetaLocDrawingR u a +                  -> ThetaLocGraphic u +                  -> ThetaLocImage u a+intoThetaLocImage f g theta pt = forkA (f theta pt) (g theta pt)   

@@ -1,140 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Graphic.DirectionContext--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Reader monad over (angular) direction.-----------------------------------------------------------------------------------------module Wumpus.Basic.Graphic.DirectionContext-  (--    DirectionM(..)-  , Direction-  , runDirection-  , DirectionT-  , runDirectionT--  , displacePerp-  , displacePara--  ) where--import Wumpus.Basic.Graphic.Base--import Wumpus.Core				-- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Applicative----- Should this use MonUnit for consistency ??--class Monad m => DirectionM m where-  localTheta    :: Radian -> m a -> m a-  asksTheta     :: (Radian -> a) -> m a -  parallel      :: Floating u => u -> m (Vec2 u)-  perpendicular :: Floating u => u -> m (Vec2 u)------newtype Direction a = Direction { getDirection :: Radian -> a }----instance Functor Direction where-  fmap f ma = Direction $ \r -> let a = getDirection ma r in f a--instance Applicative Direction where-  pure a    = Direction $ \_ -> a-  mf <*> ma = Direction $ \r -> let f = getDirection mf r-                                    a = getDirection ma r-             			in (f a)--instance Monad Direction where-  return a = Direction $ \_ -> a-  m >>= k  = Direction $ \r -> let a = getDirection m r-    	     	               in (getDirection . k) a r----runDirection :: Radian -> Direction a -> a-runDirection theta sf = (getDirection sf) theta---instance DirectionM Direction where-  localTheta theta ma = Direction $ \_ -> getDirection ma theta-  asksTheta fn        = Direction $ \r -> fn r-  parallel d          = Direction $ \r -> avec (circularModulo r) d-  perpendicular d     = Direction $ \r -> -                          avec (circularModulo $ (0.5*pi) + r) d  -------------------------------------------------------------------------------------- Transformer--newtype DirectionT m a = DirectionT { getDirectionT :: Radian -> m a }--type instance MonUnit (DirectionT m) = MonUnit m--instance Monad m => Functor (DirectionT m) where-  fmap f ma = DirectionT $ \r -> getDirectionT ma r >>= \a -> return (f a)--instance Monad m => Applicative (DirectionT m) where-  pure a    = DirectionT $ \_ -> return a-  mf <*> ma = DirectionT $ \r -> getDirectionT mf r >>= \f -> -                                 getDirectionT ma r >>= \a ->-             			 return (f a)--instance Monad m => Monad (DirectionT m) where-  return a = DirectionT $ \_ -> return a-  m >>= k  = DirectionT $ \r -> getDirectionT m r >>= \a -> -    	     	      	     	(getDirectionT . k) a r----instance Monad m => DirectionM (DirectionT m) where-  localTheta theta ma = DirectionT $ \_ -> getDirectionT ma theta-  asksTheta fn        = DirectionT $ \r -> return (fn r)-  parallel d          = DirectionT $ \r -> return (avec (circularModulo r) d)-  perpendicular d     = DirectionT $ \r -> -                          return (avec (circularModulo $ (0.5*pi) + r) d)----- Cross instances - needed to run SalingT /locally/ in Drawing.--instance DrawingCtxM m => DrawingCtxM (DirectionT m) where-  askDC           = DirectionT $ \_ -> askDC >>= \dctx -> return dctx-  localize ctx mf = DirectionT $ \r -> localize ctx (getDirectionT mf r)---instance (Monad m, TraceM m) => TraceM (DirectionT m) where-  trace a  = DirectionT $ \_ -> trace a ------runDirectionT :: Radian -> DirectionT m a -> m a-runDirectionT theta sf = (getDirectionT sf) theta-------------------------------------------------------------------------------------displacePerp :: (DirectionM m, Floating u) => u -> Point2 u -> m (Point2 u)-displacePerp u pt = perpendicular u >>= \v -> return (pt .+^ v)---displacePara :: (DirectionM m, Floating u) => u -> Point2 u -> m (Point2 u)-displacePara u pt = parallel u >>= \v -> return (pt .+^ v)

@@ -49,7 +49,6 @@   , xdrawi_    , at-  , ati    , node   , nodei@@ -59,7 +58,7 @@  import Wumpus.Basic.Graphic.Base import Wumpus.Basic.Graphic.DrawingContext- +-- import Wumpus.Basic.Utils.HList   import Wumpus.Core                              -- package: wumpus-core @@ -79,10 +78,10 @@   newtype Drawing u a   = Drawing { -          getDrawing :: DrawingContext -> HPrim u -> (a, HPrim u) }+          getDrawing :: DrawingContext -> (a, HPrim u) }  newtype DrawingT u m a = DrawingT { -          getDrawingT :: DrawingContext -> HPrim u -> m (a, HPrim u) }+          getDrawingT :: DrawingContext -> m (a, HPrim u) }   @@ -94,45 +93,47 @@ -- Functor  instance Functor (Drawing u) where-  fmap f ma = Drawing $ \ctx s -> -                let (a,s1) = getDrawing ma ctx s in (f a,s1)+  fmap f ma = Drawing $ \ctx -> +                let (a,w) = getDrawing ma ctx in (f a,w)   instance Monad m => Functor (DrawingT u m) where-  fmap f ma = DrawingT $ \ctx s -> -                getDrawingT ma ctx s >>= \(a,s1) -> return (f a,s1)+  fmap f ma = DrawingT $ \ctx -> +                getDrawingT ma ctx >>= \(a,w) -> return (f a,w)    -- Applicative  instance Applicative (Drawing u) where-  pure a    = Drawing $ \_   s -> (a, s)-  mf <*> ma = Drawing $ \ctx s -> let (f,s1) = getDrawing mf ctx s-                                      (a,s2) = getDrawing ma ctx s1-                                 in (f a, s2)+  pure a    = Drawing $ \_   -> (a, mempty)+  mf <*> ma = Drawing $ \ctx -> let (f,w1) = getDrawing mf ctx+                                    (a,w2) = getDrawing ma ctx+                                in (f a, w1 `mappend` w2)   instance Monad m => Applicative (DrawingT u m) where-  pure a    = DrawingT $ \_   s -> return (a, s)-  mf <*> ma = DrawingT $ \ctx s -> getDrawingT mf ctx s  >>= \(f,s1) ->-                                   getDrawingT ma ctx s1 >>= \(a,s2) ->-                                   return (f a, s2)+  pure a    = DrawingT $ \_   -> return (a,mempty)+  mf <*> ma = DrawingT $ \ctx -> getDrawingT mf ctx >>= \(f,w1) ->+                                 getDrawingT ma ctx >>= \(a,w2) ->+                                 return (f a, w1 `mappend` w2)  -- Monad  instance Monad (Drawing u) where-  return a  = Drawing $ \_   s -> (a, s)-  ma >>= k  = Drawing $ \ctx s -> let (a,s1) = getDrawing ma ctx s-                                  in (getDrawing . k) a ctx s1+  return a  = Drawing $ \_   -> (a, mempty)+  ma >>= k  = Drawing $ \ctx -> let (a,w1) = getDrawing ma ctx+                                    (b,w2) = (getDrawing . k) a ctx+                                in (b,w1 `mappend` w2)                                    instance Monad m => Monad (DrawingT u m) where-  return a  = DrawingT $ \_   s -> return (a, s)-  ma >>= k  = DrawingT $ \ctx s -> getDrawingT ma ctx s       >>= \(a,s1) ->-                                   (getDrawingT . k) a ctx s1+  return a  = DrawingT $ \_   -> return (a, mempty)+  ma >>= k  = DrawingT $ \ctx -> getDrawingT ma ctx      >>= \(a,w1) ->+                                 (getDrawingT . k) a ctx >>= \(b,w2) -> +                                 return (b, w1 `mappend` w2)                                    @@ -148,25 +149,25 @@ --   instance TraceM (Drawing u) where-  trace a = Drawing $ \_ s -> ((), s `mappend` a)+  trace a = Drawing $ \_ -> ((), a)   instance Monad m => TraceM (DrawingT u m) where-  trace a = DrawingT $ \_ s -> return ((), s `mappend` a)+  trace a = DrawingT $ \_ -> return ((), a)    -- DrawingCtxM  instance DrawingCtxM (Drawing u) where-  askDC           = Drawing $ \ctx s -> (ctx, s)-  localize upd ma = Drawing $ \ctx s -> getDrawing ma (upd ctx) s+  askDC           = Drawing $ \ctx -> (ctx, mempty)+  localize upd ma = Drawing $ \ctx -> getDrawing ma (upd ctx)    instance Monad m => DrawingCtxM (DrawingT u m) where-  askDC           = DrawingT $ \ctx s -> return (ctx,s)-  localize upd ma = DrawingT $ \ctx s -> getDrawingT ma (upd ctx) s+  askDC           = DrawingT $ \ctx -> return (ctx,mempty)+  localize upd ma = DrawingT $ \ctx -> getDrawingT ma (upd ctx)   @@ -182,7 +183,7 @@   runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u)-runDrawing ctx ma = getDrawing ma ctx mempty+runDrawing ctx ma = getDrawing ma ctx  -- | Run the drawing returning only the output it produces, drop -- any answer from the monadic computation.@@ -203,7 +204,7 @@   runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u) -runDrawingT ctx ma = getDrawingT ma ctx mempty+runDrawingT ctx ma = getDrawingT ma ctx  execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u) execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma@@ -302,7 +303,7 @@ -- This operation is analogeous to @tell@ in a Writer monad. --  draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()-draw gf = askDC >>= \ctx -> trace (runGraphic ctx gf)+draw gf = askDC >>= \ctx -> trace (collectH $ runGraphic ctx gf)  -- | Hyperlink version of 'draw'. --@@ -320,7 +321,7 @@ --  drawi ::  (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a drawi img = askDC >>= \ctx -> -            let (a,o) = runImage ctx img in trace o >> return a+            let (a,o) = runImage ctx img in trace (collectH o) >> return a  -- | Forgetful 'drawi'. --@@ -342,29 +343,24 @@ xdrawi_ xl img = xdrawi xl img >> return ()  -infixr 1 `at`, `ati`-at :: LocGraphic u -> Point2 u -> Graphic u+infixr 1 `at`+at :: (Point2 u -> a) -> Point2 u -> a at = ($) -ati :: LocImage u a -> Point2 u -> Image u a-ati = ($)  -{--infixl 1 `conn`-conn :: ConnectorImage u a -> Point2 u -> LocImage u a-conn = ($)--}  node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)       => LocGraphic u -> m ()-node gfL = askDC   >>= \ctx -> -           position >>= \pt  -> trace (runGraphic ctx $ gfL pt)+node gfL = askDC    >>= \ctx -> +           position >>= \pt  -> +           trace (collectH $ runGraphic ctx $ gfL pt)   nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m)       => LocImage u a -> m a nodei imgL = askDC   >>= \ctx ->               position >>= \pt  -> -             let (a,o) = runImage ctx (imgL pt) in trace o >> return a+             let (a,o) = runImage ctx (imgL pt) +             in trace (collectH o) >> return a 

@@ -21,15 +21,14 @@ module Wumpus.Basic.Graphic.PrimGraphic   (     drawGraphic-  , drawGraphicU -   , openStroke   , closedStroke   , filledPath   , borderedPath      , textline+  , rtextline   , centermonoTextline   , textlineMulti   , hkernline@@ -46,7 +45,12 @@   , displace   , hdisplace   , vdisplace+  , parallelvec+  , perpendicularvec+  , displaceParallel+  , displacePerpendicular +   , straightLine   , straightLineBetween   , curveBetween@@ -77,25 +81,12 @@ import Data.VectorSpace  import Control.Applicative-import Control.Monad import Data.Foldable ( foldrM )-import Data.Monoid   drawGraphic :: (Real u, Floating u, FromPtSize u) -            => DrawingContext -> Graphic u -> Maybe (Picture u)-drawGraphic ctx gf = post $ runGraphic ctx gf-  where-    post hf = let xs = hprimToList hf in -              if null xs then Nothing else Just (frame xs)--drawGraphicU :: (Real u, Floating u, FromPtSize u) -             => DrawingContext -> Graphic u -> Picture u-drawGraphicU ctx gf = post $ runGraphic ctx gf-  where-    post hf = let xs = hprimToList hf in -              if null xs then errK else frame xs-    errK    = error "drawGraphicU - empty Graphic."+            => DrawingContext -> Graphic u -> Picture u+drawGraphic ctx gf = frame [getPrimGraphic $ runGraphic ctx gf]   @@ -104,20 +95,20 @@  openStroke :: Num u => PrimPath u -> Graphic u openStroke pp = -    withStrokeAttr $ \rgb attr -> singleH $ ostroke rgb attr pp+    withStrokeAttr $ \rgb attr -> wrapPrim $ ostroke rgb attr pp  closedStroke :: Num u => PrimPath u -> Graphic u closedStroke pp = -    withStrokeAttr $ \rgb attr -> singleH $ cstroke rgb attr pp+    withStrokeAttr $ \rgb attr -> wrapPrim $ cstroke rgb attr pp  filledPath :: Num u => PrimPath u -> Graphic u-filledPath pp = withFillAttr $ \rgb -> singleH $ fill rgb pp+filledPath pp = withFillAttr $ \rgb -> wrapPrim $ fill rgb pp                     borderedPath :: Num u => PrimPath u -> Graphic u borderedPath pp = -    withBorderedAttr $ \frgb attr srgb -> singleH $ fillStroke frgb attr srgb pp+    withBorderedAttr $ \frgb attr srgb -> wrapPrim $ fillStroke frgb attr srgb pp   -- Note - clipping needs a picture as well as a path, so there is@@ -131,8 +122,13 @@  textline :: Num u => String -> LocGraphic u textline ss baseline_left =-    withTextAttr $ \rgb attr -> singleH $ textlabel rgb attr ss baseline_left+    withTextAttr $ \rgb attr -> wrapPrim $ textlabel rgb attr ss baseline_left +rtextline :: Num u => String -> ThetaLocGraphic u+rtextline ss theta baseline_left =+    withTextAttr $ \rgb attr -> +      wrapPrim $ rtextlabel rgb attr ss theta baseline_left+ -- | As 'textline' but the supplied point is the /center/. -- -- Centered is inexact - it is calculated with monospaced font@@ -151,23 +147,24 @@ -- left-aligned. -- textlineMulti :: Fractional u => [String] -> LocGraphic u-textlineMulti xs baseline_left = liftM snd $ +textlineMulti xs baseline_left =       baselineSpacing >>= \dy -> -    foldrM (foldStep dy) (baseline_left,mempty) xs+    foldrM (foldStep dy) (baseline_left,[]) xs >>= \(_,gs) ->+    return (wrapPrim $ primGroup gs)   where-    foldStep dy str (pt,gfic) = (\a -> (pt .+^ vvec dy, a `mappend` gfic))-                                    <$> textline str pt+    foldStep dy str (pt,ac) = (\a -> (pt .+^ vvec dy, (getPrimGraphic a) : ac)) +                                <$> textline str pt                                    hkernline :: Num u => [KerningChar u] -> LocGraphic u hkernline ks baseline_left = -    withTextAttr $ \rgb attr -> singleH $ hkernlabel rgb attr ks baseline_left+    withTextAttr $ \rgb attr -> wrapPrim $ hkernlabel rgb attr ks baseline_left         vkernline :: Num u => [KerningChar u] -> LocGraphic u vkernline ks baseline_left = -    withTextAttr $ \rgb attr -> singleH $ vkernlabel rgb attr ks baseline_left+    withTextAttr $ \rgb attr -> wrapPrim $ vkernlabel rgb attr ks baseline_left     @@ -176,18 +173,18 @@  strokedEllipse :: Num u => u -> u -> LocGraphic u strokedEllipse hw hh pt =  -    withStrokeAttr $ \rgb attr -> singleH $ strokeEllipse rgb attr hw hh pt+    withStrokeAttr $ \rgb attr -> wrapPrim $ strokeEllipse rgb attr hw hh pt      filledEllipse :: Num u => u -> u -> LocGraphic u filledEllipse hw hh pt =  -    withFillAttr $ \rgb -> singleH $ fillEllipse rgb hw hh pt+    withFillAttr $ \rgb -> wrapPrim $ fillEllipse rgb hw hh pt     borderedEllipse :: Num u => u -> u -> LocGraphic u borderedEllipse hw hh pt =      withBorderedAttr $ \frgb attr srgb -> -      singleH $ fillStrokeEllipse frgb attr srgb hw hh pt+      wrapPrim $ fillStrokeEllipse frgb attr srgb hw hh pt  -------------------------------------------------------------------------------- @@ -210,6 +207,20 @@  vdisplace :: Num u => u -> Point2 u -> Point2 u vdisplace dy (P2 x y) = P2 x (y+dy)++++parallelvec :: Floating u => u -> Radian -> Vec2 u+parallelvec d r         = avec (circularModulo r) d++perpendicularvec :: Floating u => u -> Radian -> Vec2 u+perpendicularvec d r    = avec (circularModulo $ (0.5*pi) + r) d++displaceParallel :: Floating u => u -> Radian -> Point2F u+displaceParallel d r pt = pt .+^ parallelvec d r++displacePerpendicular :: Floating u => u -> Radian -> Point2F u+displacePerpendicular d r pt = pt .+^ perpendicularvec d r   localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u

@@ -20,10 +20,12 @@     module Wumpus.Basic.Paths.Base   , module Wumpus.Basic.Paths.Connectors   , module Wumpus.Basic.Paths.Construction+  , module Wumpus.Basic.Paths.ControlPoints    ) where  import Wumpus.Basic.Paths.Base import Wumpus.Basic.Paths.Connectors import Wumpus.Basic.Paths.Construction+import Wumpus.Basic.Paths.ControlPoints 

@@ -30,6 +30,7 @@   , pconcat   , line   , curve+  , pivot   , traceLinePoints   , traceCurvePoints   , curveByAngles@@ -118,6 +119,7 @@ type instance DUnit (PathSeg u) = u  +infixr 1 `append`  length :: Num u => Path u -> u length (Path u _ _ _) = u@@ -160,6 +162,15 @@       => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u  curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3                     in Path v p0 (S.singleton $ CurveSeg v p0 p1 p2 p3) p3++-- | A draw a /straight line/ of length 0 at the supplied point. +--+-- This is /might/ be useful in concatenating curved paths+-- as it introduces and extra control point.+-- +pivot :: Floating u => Point2 u -> Path u +pivot p0 = Path 0 p0 (S.singleton $ LineSeg 0 p0 p0) p0+  -- | 'traceLinePoints' throws a runtime error if the supplied list -- is empty. 

@@ -12,8 +12,8 @@ -- -- Library of connector paths... ----- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions.+-- \*\* WARNING \*\* this module is experimental and may change +-- significantly in future revisions. --  -------------------------------------------------------------------------------- @@ -21,19 +21,32 @@   (       ConnectorPath-  , connect-  , vhconn-  , hvconn-  , vhvconn-  , hvhconn-  , curveconn-  , joint+  , DConnectorPath +  , connLine +  , connRightVH+  , connRightHV+  , connRightVHV+  , connRightHVH +  , connIsosceles+  , connIsosceles2+  , connLightningBolt+++  , connIsoscelesCurve+  , connSquareCurve+  , connUSquareCurve++  , connTrapezoidCurve+  , connZSquareCurve+  , connUZSquareCurve+   ) where  import Wumpus.Basic.Paths.Base+import Wumpus.Basic.Paths.ControlPoints  import Wumpus.Core                              -- package: wumpus-core @@ -41,46 +54,153 @@  import Prelude hiding ( length ) ++ type ConnectorPath u = Point2 u -> Point2 u -> Path u -connect :: Floating u => ConnectorPath u-connect = line+type DConnectorPath = ConnectorPath Double -vhconn :: Floating u => ConnectorPath u-vhconn p1@(P2 x1 _) p2@(P2 _ y2) = +--------------------------------------------------------------------------------++-- | Connect with a straight line.+--+connLine :: Floating u => ConnectorPath u+connLine = line++-- | Right-angled connector - go vertical, then go horizontal.+--+connRightVH :: Floating u => ConnectorPath u+connRightVH p1@(P2 x1 _) p2@(P2 _ y2) =      let mid = P2 x1 y2 in traceLinePoints [p1, mid, p2] -hvconn :: Floating u => ConnectorPath u-hvconn p1@(P2 _ y1) p2@(P2 x2 _) = +-- | Right-angled connector - go horizontal, then go vertical.+--+connRightHV :: Floating u => ConnectorPath u+connRightHV p1@(P2 _ y1) p2@(P2 x2 _) =      let mid = P2 x2 y1 in traceLinePoints [p1, mid, p2] -vhvconn :: Floating u => u -> ConnectorPath u-vhvconn v p1@(P2 x1 _) p2@(P2 x2 _) = traceLinePoints [p1, a1, a2, p2]+-- | Right-angled connector - go vertical for the supplied +-- distance, go horizontal, go vertical again for the +-- remaining distance.+-- +connRightVHV :: Floating u => u -> ConnectorPath u+connRightVHV v p1@(P2 x1 _) p2@(P2 x2 _) = traceLinePoints [p1, a1, a2, p2]   where     a1 = p1 .+^ vvec v     a2 = a1 .+^ hvec (x2 - x1)  -hvhconn :: Floating u => u -> ConnectorPath u-hvhconn h p1@(P2 _ y1) p2@(P2 _ y2) = traceLinePoints [p1,a1,a2,p2]+-- | Right-angled connector - go horizontal for the supplied +-- distance, go verical, go horizontal again for the +-- remaining distance.+-- +connRightHVH :: Floating u => u -> ConnectorPath u+connRightHVH h p1@(P2 _ y1) p2@(P2 _ y2) = traceLinePoints [p1,a1,a2,p2]   where     a1 = p1 .+^ hvec h     a2 = a1 .+^ vvec (y2 - y1) -curveconn :: (Floating u, Ord u) => Radian -> Radian -> ConnectorPath u-curveconn r1 r2 p1 p2 = curveByAngles p1 r1 r2 p2 --joint :: (Real u, Floating u) => u -> ConnectorPath u -joint u p1@(P2 x1 y1) p2@(P2 x2 y2) = -    traceLinePoints [p1, mid_pt .+^ avec perp_ang u, p2]+-- | /Triangular/ joint.+-- +-- @u@ is the altitude of the triangle.+--+connIsosceles :: (Real u, Floating u) => u -> ConnectorPath u +connIsosceles dy p1 p2 = traceLinePoints [p1, mid_pt, p2]   where-    mid_pt    = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1))-    perp_ang  = (pi*0.5) + direction (pvec p2 p1) +    mid_pt  = midpointIsosceles dy p1 p2   +-- | Double /triangular/ joint.+-- +-- @u@ is the altitude of the triangle.+--+connIsosceles2 :: (Real u, Floating u) => u -> ConnectorPath u +connIsosceles2 u p1 p2 = traceLinePoints [ p1, cp1, cp2, p2 ]+  where+    (cp1,cp2) = dblpointIsosceles u p1 p2 ++-- | /Lightning bolt/ joint - a two joint connector with an /axis/+-- perpendicular to the connector direction.+-- +-- @u@ is the half length of the of the axis.+--+connLightningBolt :: (Real u, Floating u) => u -> ConnectorPath u +connLightningBolt u p1 p2 = traceLinePoints [ p1, cp1, cp2, p2 ]+  where+    cp1 = midpointIsosceles   u  p1 p2+    cp2 = midpointIsosceles (-u) p1 p2+ --------------------------------------------------------------------------------  ++-- | Form a curve inside an isosceles triangle. +--+-- The two Bezier control points take the same point - the+-- altitude of the triangle. The curve tends to be quite shallow+-- relative to the altitude.+--+-- @u@ is the altitude of the triangle.+--+connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u +connIsoscelesCurve u p1 p2 = traceCurvePoints [p1, control_pt, control_pt, p2]+  where+    control_pt  = midpointIsosceles u p1 p2+    +++-- | Form a curve inside a square. +--+-- The two Bezier control points take the /top/ corners. The+-- curve tends to be very deep.+-- +connSquareCurve :: (Real u, Floating u) => ConnectorPath u +connSquareCurve p1 p2 = traceCurvePoints [p1, cp1, cp2, p2]+  where+    (cp1,cp2) = squareFromBasePoints p1 p2++-- | Form a curve inside a square. +--+-- As per 'connSquareCurve' but the curve is drawn /underneath/+-- the line formed between the start and end points.+-- +-- (Underneath is modulo the direction, of course).+-- +connUSquareCurve :: (Real u, Floating u) => ConnectorPath u +connUSquareCurve p1 p2 = traceCurvePoints [p1, cp1, cp2, p2]+  where+    (cp1,cp2) = usquareFromBasePoints p1 p2++++-- | altitude * ratio_to_base +--+-- Form a curve inside a trapeziod.+-- +connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u +connTrapezoidCurve u ratio_to_base p1 p2 = traceCurvePoints [p1, cp1, cp2, p2]+  where+    (cp1,cp2)  = trapezoidFromBasePoints u ratio_to_base p1 p2+++-- | Make a curve within a square, following the corner points as+-- a Z.+--+connZSquareCurve :: (Real u, Floating u) => ConnectorPath u +connZSquareCurve p1 p2 = traceCurvePoints [p1,cp1,cp2,p2]+   where+     (cp1,cp2)  = squareFromCornerPoints p1 p2 +      +-- | Make a curve within a square, following the corner points as+-- a Z.+--+-- The order of tracing flips the control points, so this is an+-- /underneath/ version of 'connZSquareCurve'.+-- +connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u +connUZSquareCurve p1 p2 = traceCurvePoints [p1,cp2,cp1,p2]+   where+     (cp1,cp2)  = squareFromCornerPoints p1 p2 

@@ -0,0 +1,189 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Paths.ControlPoints+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Collection of point manufacturing functions.+--+-- \*\* WARNING \*\* this module is experimental and may change +-- significantly in future revisions.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Paths.ControlPoints+  ( ++    midpointIsosceles+  , dblpointIsosceles++  , rectangleFromBasePoints+  , squareFromBasePoints+  , usquareFromBasePoints++  , trapezoidFromBasePoints++  , squareFromCornerPoints++  ) where++import Wumpus.Basic.Graphic++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++++-- | 'midpointIsosceles' : +-- @ altitude * start_pt * end_pt -> mid_pt @+--+-- Triangular midpoint.+-- +-- @u@ is the altitude of the triangle - negative values of u +-- form the triangle below the line.+--+midpointIsosceles :: (Real u, Floating u) +                  => u -> Point2 u -> Point2 u -> Point2 u+midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = +    mid_pt .+^ avec perp_ang u+  where+    mid_pt    = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1))+    perp_ang  = (pi*0.5) + direction (pvec p1 p2) ++++-- | 'dblpointIsosceles' : +-- @ altitude * start_pt * end_pt * (third_pt, two_thirds_pt) @+-- +-- Double triangular joint - one joint at a third of the line+-- length, the other at two thirds.+-- +dblpointIsosceles :: (Real u, Floating u) +                      => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u)  +dblpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = +    (mid1 .+^ avec perp_ang u, mid2 .-^ avec perp_ang u)+  where+    mid1      = P2 (x1 + 0.33*(x2-x1)) (y1 + 0.33*(y2-y1))+    mid2      = P2 (x1 + 0.66*(x2-x1)) (y1 + 0.66*(y2-y1))+    perp_ang  = (pi*0.5) + direction (pvec p1 p2) +++--------------------------------------------------------------------------------++++-- | 'rectangleFromBasePoints' : +-- @ altitude * start_pt * end_pt * (top_left, top_right) @+-- +-- Control points forming a rectangle. +--+-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@.+--+rectangleFromBasePoints :: (Real u, Floating u) +                  => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u)+rectangleFromBasePoints u p1 p2 = (cp1, cp2)+  where+    base_vec  = pvec p1 p2+    theta     = direction base_vec+    cp1       = displacePerpendicular u theta p1+    cp2       = displacePerpendicular u theta p2+++-- | 'squareFromBasePoints' : +-- @ start_pt -> end_pt -> (top_left, top_right) @+-- +-- Control points forming a square - side_len derived from the +-- distance between start and end points.+--+-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@.+--+squareFromBasePoints :: (Real u, Floating u) +                     => Point2 u -> Point2 u -> (Point2 u, Point2 u)+squareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2+  where+    side_len  = vlength $ pvec p1 p2+++-- | 'usquareFromBasePoints' : +-- @ start_pt -> end_pt -> (bottom_left, bottom_right) @+-- +-- Control points forming a square - side_len derived from the +-- distance between start and end points.+--+-- As per 'squareFromBasePoints' but the square is drawn +-- /underneath/ the line formed between the start and end points.+-- (Underneath is modulo the direction, of course).+--+-- The two manufactured control points form the /bottom/ corners, +-- so the supplied points map as @start_point == top_left@ and +-- @end_point == top_right@.+-- +usquareFromBasePoints :: (Real u, Floating u) +                      => Point2 u -> Point2 u -> (Point2 u, Point2 u)+usquareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2+  where+    side_len  = negate $ vlength $ pvec p1 p2++++++-- | 'trapezoidFromBasePoints' : +-- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @+--+-- Control points form an isosceles trapezoid.+--+-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@.+-- +trapezoidFromBasePoints :: (Real u, Floating u) +                        => u -> u -> Point2 u -> Point2 u +                        -> (Point2 u, Point2 u) +trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2)+  where+    base_vec  = pvec p1 p2+    base_len  = vlength base_vec+    theta     = direction base_vec+    half_ulen = 0.5 * ratio_to_base * base_len+    base_mid  = displaceParallel (0.5 * base_len) theta p1+    ubase_mid = displacePerpendicular u theta base_mid+    cp1       = displaceParallel (-half_ulen) theta ubase_mid+    cp2       = displaceParallel   half_ulen  theta ubase_mid+++++-- | 'squareFromCornerPoints' : +-- @ altitude * start_pt * end_pt * (top_left, bottom_right) @+-- +-- Control points forming a square bisected by the line from +-- start_pt to end_pt. +--+-- The two manufactured control points form the top_left and+-- bottom_right corners, so the supplied points map as +-- @start_point == bottom_left@ and @end_point == top_right@.+--+squareFromCornerPoints :: (Real u, Floating u) +                       => Point2 u -> Point2 u -> (Point2 u, Point2 u) +squareFromCornerPoints p1 p2 = (cp1, cp2)+  where+    base_vec  = pvec p1 p2+    half_len  = 0.5 * (vlength base_vec)+    theta     = direction base_vec+    base_mid  = displaceParallel half_len theta p1+    cp1       = displacePerpendicular   half_len  theta base_mid+    cp2       = displacePerpendicular (-half_len) theta base_mid+

@@ -32,7 +32,6 @@  import Data.AffineSpace                         -- package: vector-space -import Data.Monoid  -- | The length of the control-point vector wants to be slighly  -- longer than half of /d/ (d - being the distance between the @@ -88,28 +87,28 @@ illustratePath = localize (strokeColour black) . step1 . pathViewL   where     step1 (PathOneL e)  = drawPath1 e-    step1 (e :<< se)    = drawPathBoth e `mappend` rest (pathViewL se)+    step1 (e :<< se)    = drawPathBoth e `oplus` rest (pathViewL se)      rest (PathOneL e)   = drawPath1 e-    rest (e :<< se)     = drawPath1 e `mappend` rest (pathViewL se)+    rest (e :<< se)     = drawPath1 e `oplus` rest (pathViewL se)  drawPathBoth :: Fractional u => PathSegment u -> Graphic u-drawPathBoth pa@(Line1 p1 _)      = drawPath1 pa `mappend` pathPoint p1-drawPathBoth pa@(Curve1 p1 _ _ _) = drawPath1 pa `mappend` pathPoint p1+drawPathBoth pa@(Line1 p1 _)      = drawPath1 pa `oplus` pathPoint p1+drawPathBoth pa@(Curve1 p1 _ _ _) = drawPath1 pa `oplus` pathPoint p1  drawPath1 :: Fractional u => PathSegment u -> Graphic u drawPath1 (Line1 p1 p2)        = -    straightLineBetween p1 p2 `mappend` pathPoint p2+    straightLineBetween p1 p2 `oplus` pathPoint p2  drawPath1 (Curve1 p1 p2 p3 p4) =  -    mconcat [bezierCtrl p1 p2, bezierCtrl p4 p3, curveBetween p1 p2 p3 p4-                             , pathPoint p4 ]+    oconcat (bezierCtrl p1 p2) [ bezierCtrl p4 p3, curveBetween p1 p2 p3 p4+                               , pathPoint p4 ]   bezierCtrl :: Fractional u => Point2 u -> Point2 u -> Graphic u bezierCtrl p1 p2 =      localize (strokeColour light_steel_blue . fillColour red) $-      straightLineBetween p1 p2 `mappend` filledDisk 1 p2+      straightLineBetween p1 p2 `oplus` filledDisk 1 p2   pathPoint :: Num u => Point2 u -> Graphic u

@@ -23,7 +23,10 @@   (   -    Shape(..)+    Shape+  , LocShape+  , makeShape+   , ShapeConstructor    , borderedShape@@ -31,12 +34,14 @@   , strokedShape    -- * ShapeCTM -  , ShapeCTM(..)-  , identityCTM--  , ctmDisplace-  , ctmCenter+  , ShapeCTM+  , makeShapeCTM +  , ShapeGeom+  , runShapeGeom+  , askCTM+  , projectPoint+  , shapeCenter    ) where @@ -49,8 +54,6 @@ import Control.Applicative  --- | Note - this formulation prevents rounded corner shapes...--- -- Currently shapes that aren\'t paths: -- -- > Coordinate@@ -64,41 +67,64 @@ -- DrawingContext for the /shape/ -- +newtype ShapeR u a = ShapeR { getShapeR :: ShapeCTM u -> a }++runShapeR :: ShapeCTM u -> ShapeR u a -> a+runShapeR ctm sf = getShapeR sf ctm++ data Shape u t =  Shape -      { src_ctm   :: ShapeCTM u -      , path_fun  :: ShapeCTM u -> Path u-      , cons_fun   :: ShapeCTM u -> t u+      { shape_ctm   :: ShapeCTM u +      , path_fun    :: ShapeR u (Path u)+      , cons_fun    :: ShapeR u (t u)       }  type instance DUnit (Shape u sh) = u  +type LocShape u t = Point2 u -> Shape u t+ type ShapeConstructor u t = ShapeCTM u -> t u   +makeShape :: Num u +          => (ShapeCTM u -> Path u) -> (ShapeCTM u -> t u) -> LocShape u t+makeShape pf mkf = \pt -> Shape { shape_ctm = makeShapeCTM pt+                                , path_fun  = ShapeR pf+                                , cons_fun  = ShapeR mkf+                                }  ++shapeImage :: Num u => (PrimPath u -> Graphic u) -> Shape u t -> Image u (t u)+shapeImage drawF (Shape { shape_ctm = ctm, path_fun = pf, cons_fun = objf }) = +   intoImage (pure $ runShapeR ctm objf) +             (drawF $ toPrimPath $ runShapeR ctm pf)++ borderedShape :: Num u => Shape u t -> Image u (t u)-borderedShape (Shape { src_ctm = ctm, path_fun = pf, cons_fun = objf }) = -   intoImage (pure $ objf ctm) (borderedPath $ toPrimPath $ pf ctm)+borderedShape = shapeImage borderedPath  filledShape :: Num u => Shape u t -> Image u (t u)-filledShape (Shape { src_ctm = ctm, path_fun = pf, cons_fun = objf }) = -   intoImage (pure $ objf ctm) (filledPath $ toPrimPath $ pf ctm)+filledShape = shapeImage filledPath  strokedShape :: Num u => Shape u t -> Image u (t u)-strokedShape (Shape { src_ctm = ctm, path_fun = pf, cons_fun = objf }) = -   intoImage (pure $ objf ctm) (closedStroke $ toPrimPath $ pf ctm)+strokedShape = shapeImage closedStroke   + instance (Real u, Floating u) => Rotate (Shape u sh) where-  rotate r = updateCTM (rotateCTM r)+  rotate r = updateCTM (rotate r) +instance (Real u, Floating u) => RotateAbout (Shape u sh) where+  rotateAbout r pt = updateCTM (rotateAbout r pt)+ instance Num u => Scale (Shape u sh) where-  scale x y = updateCTM (scaleCTM x y)+  scale sx sy = updateCTM (scale sx sy)  instance Num u => Translate (Shape u sh) where-  translate x y = updateCTM (translateCTM x y)+  translate dx dy = updateCTM (translate dx dy) + updateCTM :: (ShapeCTM u -> ShapeCTM u) -> Shape u sh -> Shape u sh updateCTM fn (Shape ctm pf mkf) = Shape (fn ctm) pf mkf @@ -110,53 +136,89 @@ --  data ShapeCTM u = ShapeCTM -      { ctm_trans_x             :: !u-      , ctm_trans_y             :: !u+      { ctm_center              :: Point2 u       , ctm_scale_x             :: !u       , ctm_scale_y             :: !u       , ctm_rotation            :: Radian       }   deriving (Eq,Ord,Show) + type instance DUnit (ShapeCTM u) = u -identityCTM :: Num u => ShapeCTM u-identityCTM = ShapeCTM { ctm_trans_x  = 0 -                       , ctm_trans_y  = 0 -                       , ctm_scale_x  = 1-                       , ctm_scale_y  = 1-                       , ctm_rotation = 0 }+makeShapeCTM :: Num u => Point2 u -> ShapeCTM u+makeShapeCTM pt = ShapeCTM { ctm_center   = pt+                           , ctm_scale_x  = 1+                           , ctm_scale_y  = 1+                           , ctm_rotation = 0 }     -scaleCTM :: Num u => u -> u -> ShapeCTM u -> ShapeCTM u-scaleCTM sx sy = -    (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy })-      <*> ctm_scale_x <*> ctm_scale_y+instance Num u => Scale (ShapeCTM u) where+  scale sx sy = (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy })+                  <*> ctm_scale_x <*> ctm_scale_y  -rotateCTM :: Radian -> ShapeCTM u -> ShapeCTM u-rotateCTM ang1 = -    (\s ang -> s { ctm_rotation = circularModulo $ ang1+ang })-      <*> ctm_rotation+instance Rotate (ShapeCTM u) where+  rotate ang = (\s i -> s { ctm_rotation = circularModulo $ i+ang })+                  <*> ctm_rotation +instance (Real u, Floating u) => RotateAbout (ShapeCTM u) where+  rotateAbout ang pt = +    (\s ctr i -> s { ctm_rotation = circularModulo $ i+ang+                   , ctm_center   = rotateAbout ang pt ctr })+      <*> ctm_center <*> ctm_rotation -translateCTM :: Num u => u -> u -> ShapeCTM u -> ShapeCTM u-translateCTM dx dy = -    (\s x y -> s { ctm_trans_x = x+dx, ctm_trans_y = y+dy })-      <*> ctm_trans_x <*> ctm_trans_y +instance Num u => Translate (ShapeCTM u) where+  translate dx dy = (\s (P2 x y) -> s { ctm_center = P2 (x+dx) (y+dy) })+                      <*> ctm_center -ctmDisplace :: (Real u, Floating u) => Point2 u -> ShapeCTM u -> Point2 u-ctmDisplace (P2 x y) (ShapeCTM { ctm_trans_x  = dx, ctm_trans_y  = dy -                               , ctm_scale_x  = sx, ctm_scale_y  = sy-                               , ctm_rotation = theta }) = -    translate dx dy $ rotate theta $ P2 (sx*x) (sy*y) +-------------------------------------------------------------------------------- -ctmCenter :: (Real u, Floating u) => ShapeCTM u -> Point2 u-ctmCenter = ctmDisplace zeroPt+newtype ShapeGeom u a = ShapeGeom { getShapeGeom :: ShapeCTM u -> a }+++type instance MonUnit (ShapeGeom u) = u+++instance Functor (ShapeGeom u) where+  fmap f ma = ShapeGeom $ \ctx -> let a = getShapeGeom ma ctx in f a++instance Applicative (ShapeGeom u) where+  pure a    = ShapeGeom $ \_   -> a+  mf <*> ma = ShapeGeom $ \ctx -> let f = getShapeGeom mf ctx+                                      a = getShapeGeom ma ctx+             			  in (f a)++instance Monad (ShapeGeom u) where+  return a = ShapeGeom $ \_   -> a+  m >>= k  = ShapeGeom $ \ctx -> let a = getShapeGeom m ctx+    	     	                 in (getShapeGeom . k) a ctx++++runShapeGeom :: ShapeCTM u -> ShapeGeom u a -> a+runShapeGeom ctm mf = getShapeGeom mf ctm++askCTM :: ShapeGeom u (ShapeCTM u)+askCTM = ShapeGeom $ \ctm -> ctm++shapeCenter :: (Real u, Floating u) => ShapeGeom u (Point2 u)+shapeCenter = ShapeGeom $ \r -> ctm_center r+++++projectPoint :: (Real u, Floating u) => Point2 u -> ShapeGeom u (Point2 u)+projectPoint (P2 x y) = ShapeGeom $ +    \(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)  

@@ -33,13 +33,11 @@   , DCircle   , circle -   , Diamond   , DDiamond   , diamond   , rdiamond -   , Ellipse   , DEllipse   , ellipse@@ -56,11 +54,19 @@ import Wumpus.Core                              -- package: wumpus-core  import Data.AffineSpace                         -- package: vector-space +import Data.VectorSpace +import Control.Applicative -remapPoints :: (Real u, Floating u) => [Point2 u] -> ShapeCTM u -> [Point2 u]-remapPoints xs ctm = map (ctmDisplace `flip` ctm) xs +-- Note - Specific shapes - Rectangle, Circle, etc. - should _NOT_+-- have affine instances. +--+-- Transformations should only operate on the Shape type. Once a+-- Shape has been drawn the resultant Rectangle, Circle... cannot +-- be further transformed, as this would dis-associate the Anchors+-- from the Graphic.+--  -------------------------------------------------------------------------------- -- Rectangle@@ -74,55 +80,58 @@  type DRectangle = Rectangle Double + type instance DUnit (Rectangle u) = u  +runRectangle :: (u -> u -> ShapeGeom u a) -> Rectangle u -> a+runRectangle mf (Rectangle { rect_ctm =ctm, rect_hw = hw, rect_hh = hh }) = +   runShapeGeom ctm $ mf hw hh + instance (Real u, Floating u) => CenterAnchor (Rectangle u) where-  center = ctmCenter . rect_ctm+  center = runRectangle (\ _ _ -> shapeCenter)  -calcRectPoint :: (Real u, Floating u) -              => (u -> u -> Point2 u) -> Rectangle u -> Point2 u-calcRectPoint f (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) =-    let pt = f hw hh in ctmDisplace pt ctm- instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where-  north = calcRectPoint $ \ _  hh -> P2 0 hh-  south = calcRectPoint $ \ _  hh -> P2 0 (-hh)-  east  = calcRectPoint $ \ hw _  -> P2 hw 0-  west  = calcRectPoint $ \ hw _  -> P2 (-hw) 0+  north = runRectangle $ \_  hh -> projectPoint $ P2 0 hh+  south = runRectangle $ \_  hh -> projectPoint $ P2 0 (-hh)+  east  = runRectangle $ \hw _  -> projectPoint $ P2 hw 0+  west  = runRectangle $ \hw _  -> projectPoint $ P2 (-hw) 0  instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where-  northeast = calcRectPoint $ \ hw hh -> P2 hw hh-  southeast = calcRectPoint $ \ hw hh -> P2 hw (-hh)-  southwest = calcRectPoint $ \ hw hh -> P2 (-hw) (-hh)-  northwest = calcRectPoint $ \ hw hh -> P2 (-hw) hh+  northeast = runRectangle $ \hw hh -> projectPoint $ P2 hw hh+  southeast = runRectangle $ \hw hh -> projectPoint $ P2 hw (-hh)+  southwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) (-hh)+  northwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) hh   instance (Real u, Floating u) => RadialAnchor (Rectangle u) where-  radialAnchor theta rect@(Rectangle { rect_hw=hw, rect_hh=hh }) = -      maybe ctr id $ findIntersect ctr theta $ rectangleLines ctr hw hh -    where -      ctr = ctmCenter $ rect_ctm rect+  radialAnchor theta = runRectangle $ \hw hh -> +    projectPoint $ rectangleIntersect 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  + -- | 'rectangle'  : @ width * height -> shape @ ---rectangle :: (Real u, Floating u) => u -> u -> Shape u Rectangle+rectangle :: (Real u, Floating u) => u -> u -> LocShape u Rectangle rectangle w h = -    Shape { src_ctm   = identityCTM-          , path_fun  = traceLinePoints . rectanglePoints (0.5*w) (0.5*h)-          , cons_fun  = mkRectangle (0.5*w) (0.5*h)  -          }+    makeShape (traceLinePoints . rectanglePoints (0.5*w) (0.5*h))+              (mkRectangle (0.5*w) (0.5*h))+            -- | 'rectangle'  : @ round_length * width * height -> shape @ ---rrectangle :: (Real u, Floating u) => u -> u -> u -> Shape u Rectangle+rrectangle :: (Real u, Floating u) => u -> u -> u -> LocShape u Rectangle rrectangle round_dist w h = -    Shape { src_ctm   = identityCTM-          , path_fun  = roundEvery round_dist . rectanglePoints (0.5*w) (0.5*h)-          , cons_fun  = mkRectangle (0.5*w) (0.5*h)  -          }+    makeShape (roundEvery round_dist . rectanglePoints (0.5*w) (0.5*h))+              (mkRectangle (0.5*w) (0.5*h))+            @@ -132,11 +141,8 @@   --- Note - the Paths modules should define a function for building--- rectangles (and polygons, bezier curves / ellipses ...)--- rectanglePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]-rectanglePoints hw hh = remapPoints [ se, ne, nw, sw ]+rectanglePoints hw hh ctm = runShapeGeom ctm $ mapM projectPoint [se,ne,nw,sw]   where     se = P2   hw  (-hh)     ne = P2   hw    hh@@ -160,25 +166,20 @@  type instance DUnit (Circle u) = u -instance (Real u, Floating u) => CenterAnchor (Circle u) where-  center = ctmCenter . circ_ctm+runCircle :: (u -> ShapeGeom u a) -> Circle u -> a+runCircle mf (Circle { circ_ctm =ctm, circ_radius = radius }) = +   runShapeGeom ctm $ mf radius   -calcCircPoint :: (Real u, Floating u) -              => (u -> Point2 u) -> Circle u -> Point2 u-calcCircPoint f (Circle { circ_ctm = ctm, circ_radius = rad }) =-    let pt = f rad in ctmDisplace pt ctm-+instance (Real u, Floating u) => CenterAnchor (Circle u) where+  center = runCircle (\_ -> shapeCenter)  -instance (Real u, Floating u) => RadialAnchor (Circle u) where-  radialAnchor theta = calcCircPoint $ \r -> zeroPt .+^ avec theta r- instance (Real u, Floating u) => CardinalAnchor (Circle u) where-  north = calcCircPoint $ \r -> P2 0    r-  south = calcCircPoint $ \r -> P2 0  (-r)-  east  = calcCircPoint $ \r -> P2 r    0-  west  = calcCircPoint $ \r -> P2 (-r) 0+  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   instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where@@ -187,14 +188,18 @@   southwest = radialAnchor (1.25*pi)   northwest = radialAnchor (0.75*pi) ++instance (Real u, Floating u) => RadialAnchor (Circle u) where+  radialAnchor theta = runCircle $ \r -> projectPoint $ zeroPt .+^ avec theta r+++ -- | 'circle'  : @ radius -> shape @ ---circle :: (Real u, Floating u) => u -> Shape u Circle-circle radius = -    Shape { src_ctm  = identityCTM-          , path_fun = traceCurvePoints . circlePoints radius-          , cons_fun = mkCircle radius-          }+circle :: (Real u, Floating u) => u -> LocShape u Circle+circle radius = makeShape (traceCurvePoints . circlePoints radius)+                          (mkCircle radius)+             mkCircle :: u -> ShapeConstructor u Circle@@ -202,9 +207,8 @@   circlePoints :: (Real u, Floating u) => u -> ShapeCTM u -> [Point2 u]-circlePoints radius ctm = map fn all_points+circlePoints radius ctm = runShapeGeom ctm $ mapM projectPoint all_points   where-    fn pt       = ctmDisplace pt ctm     all_points  = bezierCircle 2 radius zeroPt   @@ -224,49 +228,65 @@ type instance DUnit (Diamond u) = u  ++runDiamond :: (u -> u -> ShapeGeom u a) -> Diamond u -> a+runDiamond mf (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = +   runShapeGeom ctm $ mf hw hh ++ instance (Real u, Floating u) => CenterAnchor (Diamond u) where-  center = ctmCenter . dia_ctm+  center = runDiamond (\_ _ -> shapeCenter) +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 +instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where+  northeast x = midpoint (north x) (east x)+  southeast x = midpoint (south x) (east x)+  southwest x = midpoint (south x) (west x)+  northwest x = midpoint (north x) (west x)   +instance (Real u, Floating u) => RadialAnchor (Diamond u) where+   radialAnchor = diamondIntersect -calcDiaPoint :: (Real u, Floating u) -             => (u -> u -> Point2 u) -> Diamond u -> Point2 u-calcDiaPoint f (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) =-    let pt = f hw hh in ctmDisplace pt ctm+-- Utils.Intersection needs improving... -instance (Real u, Floating u) => CardinalAnchor (Diamond u) where-  north = calcDiaPoint $ \ _  hh -> P2 0 hh-  south = calcDiaPoint $ \ _  hh -> P2 0 (-hh)-  east  = calcDiaPoint $ \ hw _  -> P2 hw 0-  west  = calcDiaPoint $ \ hw _  -> P2 (-hw) 0 +diamondIntersect :: (Real u, Floating u) +                 => Radian -> Diamond u -> Point2 u+diamondIntersect theta = runDiamond $ \hw hh ->  +    (\ctr ctm -> let ps = diamondPoints hw hh ctm +                 in maybe ctr id $ findIntersect ctr theta $ polygonLines ps)+      <$> shapeCenter <*> askCTM   +midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u+midpoint p1 p2 = let v = 0.5 *^ pvec p1 p2 in p1 .+^ v  -- | 'diamond'  : @ half_width * half_height -> shape @ -- -- Note - args might change to tull_width and full_height... ---diamond :: (Real u, Floating u) => u -> u -> Shape u Diamond+diamond :: (Real u, Floating u) => u -> u -> LocShape u Diamond diamond hw hh = -    Shape { src_ctm  = identityCTM-          , path_fun = traceLinePoints . diamondPoints hw hh-          , cons_fun = mkDiamond hw hh-          }+    makeShape (traceLinePoints . diamondPoints hw hh)+              (mkDiamond hw hh)+            -- | 'rdiamond'  : @ round_length * half_width * half_height -> shape @ -- -- Note - args might change to full_width and full_height... ---rdiamond :: (Real u, Floating u) => u -> u -> u -> Shape u Diamond+rdiamond :: (Real u, Floating u) => u -> u -> u -> LocShape u Diamond rdiamond round_dist hw hh = -    Shape { src_ctm  = identityCTM-          , path_fun = roundEvery round_dist . diamondPoints hw hh-          , cons_fun = mkDiamond hw hh-          }+    makeShape (roundEvery round_dist . diamondPoints hw hh)+              (mkDiamond hw hh)+            @@ -276,7 +296,7 @@   diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]-diamondPoints hw hh = remapPoints [ s, e, n, w ]+diamondPoints hw hh ctm = runShapeGeom ctm $ mapM projectPoint [ s, e, n, w ]   where     s = P2   0  (-hh)     e = P2   hw    0@@ -299,19 +319,24 @@ type instance DUnit (Ellipse u) = u  +runEllipse :: (u -> u -> ShapeGeom u a) -> Ellipse u -> a+runEllipse mf (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) = +   runShapeGeom ctm $ mf rx ry  -instance (Real u, Floating u) => CenterAnchor (Ellipse u) where-  center = ctmCenter . ell_ctm +-- | x_radius is the unit length.+--+scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t+scaleEll rx ry = scale 1 (ry/rx)  -calcEllPoint :: (Real u, Floating u) -              => (u -> Point2 u) -> Ellipse u -> Point2 u-calcEllPoint f (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) =-    let p   = f rx; p'  = scaleEll rx ry p-    in ctmDisplace p' ctm +instance (Real u, Floating u) => CenterAnchor (Ellipse u) where+  center = runEllipse $ \_ _ -> shapeCenter++ instance (Real u, Floating u) => RadialAnchor (Ellipse u) where-  radialAnchor theta = calcEllPoint $ \rx -> zeroPt .+^ avec theta rx+  radialAnchor theta = runEllipse $ \rx ry -> +    projectPoint $ scaleEll rx ry $ zeroPt .+^ avec theta rx   instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where@@ -330,26 +355,21 @@  -- | 'ellipse'  : @ x_radii * y_radii -> shape @ ---ellipse :: (Real u, Floating u) => u -> u -> Shape u Ellipse+ellipse :: (Real u, Floating u) => u -> u -> LocShape u Ellipse ellipse rx ry = -    Shape { src_ctm  = identityCTM-          , path_fun = traceCurvePoints . ellipsePoints rx ry-          , cons_fun = mkEllipse rx ry  -          }--+    makeShape (traceCurvePoints . ellipsePoints rx ry)+              (mkEllipse rx ry)+            mkEllipse :: (Real u, Floating u) => u -> u -> ShapeConstructor u Ellipse mkEllipse rx ry = \ctm -> Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry } + ellipsePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u] ellipsePoints rx ry ctm = -    map ((ctmDisplace `flip` ctm) . scaleEll rx ry) $ bezierCircle 2 rx zeroPt -+    runShapeGeom ctm $ mapM (projectPoint . scaleEll rx ry) all_points+  where+    all_points =  bezierCircle 2 rx zeroPt  --- | x_radius is the unit length.----scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t-scaleEll rx ry = scale 1 (ry/rx)   

@@ -121,18 +121,17 @@   +textCTM :: Num u => u -> u -> Radian -> ShapeCTM u+textCTM x y theta = rotate theta $ makeShapeCTM (P2 x y)+ oneLineRect :: (Fractional u, Ord u, FromPtSize u)          => Plaintext u -> DrawingR (PlaintextAnchor u) oneLineRect ptext =      monoTextDimensions (text_text ptext) >>= \(w,h) ->      return (PlaintextAnchor $ mkRectangle (0.5*w) (0.5*h) ctm)   where-    ctm = ShapeCTM { ctm_trans_x    = text_x ptext-                   , ctm_trans_y    = text_y ptext-                   , ctm_scale_x    = 1-                   , ctm_scale_y    = 1-                   , ctm_rotation   = text_ang ptext-                   }+    ctm = textCTM (text_x ptext) (text_y ptext) (text_ang ptext)+                     drawOneLine :: (Real u, Floating u, FromPtSize u)              => Plaintext u -> Graphic u @@ -147,4 +146,4 @@ rotTextline :: (Real u, Floating u) => Radian -> String -> LocGraphic u rotTextline theta ss baseline_left =      withTextAttr $ \rgb attr -> -        singleH $ rotatePrim theta $ textlabel rgb attr ss baseline_left+        wrapPrim $ rtextlabel rgb attr ss theta baseline_left

@@ -50,12 +50,10 @@  import Control.Applicative import Control.Monad-import Data.Monoid    - -- Need a note in wumpus-core and here about space:preserve  -- Note - if we have font change (e.g. to symbol font) then we @@ -120,11 +118,9 @@     let (a,st) = getLRText ma e1 st_zero      in mkline pt (acc_chr st) >>= \g1 ->        localize (fontface symbol) (mkline pt (acc_sym st)) >>= \g2 ->-       return (a,g1 `mappend` g2)+       return (a, g1 `oplus` g2)   where-    mkline pt h = case toListH h of-                   [] -> return mempty-                   xs -> hkernline xs pt+    mkline pt h = hkernline (toListH h) pt   execLRText :: (Num u, FromPtSize u) => LRText u a -> LocGraphic u

@@ -0,0 +1,92 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Utils.Combinators+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC+--+-- Combiantors - pairing, /static argument/ functions, ...+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Utils.Combinators+  (++  -- * Combinators+    fork+  , prod+  , forkA++  , bindR+  , bindAsk+  , bindInto+  , rlift1++  , bindR2+  , bindAskR2+  , rlift2+++  ) where++import Control.Applicative++fork :: (a -> b) -> (a -> c) -> a -> (b,c) +fork f g a = (f a, g a)++prod :: (a -> c) -> (b -> d) -> (a,b) -> (c,d) +prod f g (a,b) = (f a, g b)+++forkA :: Applicative f => f a -> f b -> f (a,b)+forkA af ab = (,) <$> af <*> ab ++++infixl 1 `bindR`, `bindR2`++-- Monadic bind with 1 static argument.+--+bindR :: Monad m => (r -> m a) -> (a -> r -> m b) -> r -> m b+bindR cxma cxmf = \x -> cxma x >>= \a -> cxmf a x++-- 'bindAsk' takes a monadic function oblivious to R1 upto bindR.+-- (lift and bind).+--+bindAsk :: Monad m => m a -> (a -> r1 -> m b) -> r1 -> m b +bindAsk ma cxmf r1 = ma >>= \a -> cxmf a r1+++-- 'bindInto' takes a monadic action dependent on R1 and binds+-- it into a mondic function oblivious to R1. +--+bindInto :: Monad m => (r1 -> m a) -> (a -> m b) -> r1 -> m b +bindInto cxma mf r1 = cxma r1 >>= \a -> mf a++rlift1 :: Monad m => m a -> (r -> m a)+rlift1 ma = \_ -> ma++++-- Monadic bind with 2 static arguments.+--+bindR2 :: Monad m +       => (r1 -> r2 -> m a) -> (a -> r1 -> r2 -> m b) -> r1 -> r2 -> m b+bindR2 cxma cxmf = \x y -> cxma x y >>= \a -> cxmf a x y+++-- 'bindAskR2' takes a monadic function oblivious to R1 and R2 upto bindR2.+-- (lift and bind).+--+bindAskR2 :: Monad m => m a -> (a -> r1 -> r2 -> m b) -> r1 -> r2 -> m b +bindAskR2 ma cxmf r1 r2 = ma >>= \a -> cxmf a r1 r2+++rlift2 :: Monad m => m a -> (r1 -> r2 -> m a)+rlift2 ma = \_ _ -> ma+

@@ -27,6 +27,7 @@   , intersection    , rectangleLines+  , polygonLines   , langle   )    where@@ -36,6 +37,13 @@ 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) @@ -108,7 +116,7 @@            => 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+                     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@@ -124,7 +132,6 @@   - 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@@ -132,6 +139,14 @@     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   

@@ -23,7 +23,7 @@  -- | Version number ----- > (0,11,0)+-- > (0,12,0) -- wumpus_basic_version :: (Int,Int,Int)-wumpus_basic_version = (0,11,0)+wumpus_basic_version = (0,12,0)

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.11.0+version:          0.12.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -19,23 +19,36 @@   @PrimGraphic@, @DrawingContext@) seem to support a good set   primitive functions, but the exact types of drawing objects do    not feel right at the moment. Other modules (Paths, Chains, -  Shapes) are essentially sketches and are expected to be-  substantially revised in subsequent updates.+  Shapes) are still being worked out and may be substantially +  revised in subsequent updates.   .-  Version 0.11.0 is an interim release. It is expected that the -  next release will substantially rework Shapes and likely change-  the @Graphic.Base@ types. As quite a large amount of code has -  already changed since version 0.10.0 (to support better -  arrowheads and connectors) it seems sensible to release 0.11.0 -  now, rather than have a huge delta after Shapes have been -  reworked again. The current versions of @Wumpus-Tree@ and -  @Wumpus-Microprint@ will work with version 0.11.0 if their -  respective @.cabal@ files are edited to bump the version number. -  There will be no matching releases to work automatically with -  version 0.11.0 of Wumpus-Basic.+  Version 0.12.0 extends the sets of arrowheads and connectors.+  Unfortunately Shapes are still undercooked.   .   Changelog:   .+  0.11.0 to 0.12.0:+  .+  * Changes Base types in  @Basic.Graphic@. The @Graphic@ and +    @Image@ types now produce (wrapped) @Primitives@, rather than +    Hughes lists of @Primitives@. This means they can now be +    transformed with the affine transformations. Removed the +    function @ati@, it is replaced by @at@.+  .+  * Added @Basic.Utils.Combinators@.+  .+  * Arrowheads and Connectors reworked - Arrowheads are now a +    functional type, Connectors use new Image combining +    operations from @Basic.Graphic.Base@.+  .+  * Path connectors re-worked and renamed. +  .+  * Dot hierarchy changed - @Basic.Dots@ becomes +    @Basic.Dots.AnchorDots@; @Basic.Dots.Primitive@ becomes+    @Basic.Dots.Marks@.+  .+  * @Basic.Shapes@ - internals reworked.+  .   0.10.0 to 0.11.0:   .    * Reworked arrowheads and connectors - connectors are now @@ -87,9 +100,11 @@   CHANGES,   LICENSE,   demo/ArrowCircuit.hs,+  demo/Arrowheads.hs,   demo/ClipPic.hs,   demo/ColourCharts.hs,   demo/ColourDefns.hs,+  demo/Connectors.hs   demo/DotPic.hs,   demo/FontPic.hs,   demo/PetriNet.hs,@@ -101,7 +116,7 @@   build-depends:      base            <  5,                        containers      >= 0.3     && <= 0.4,                        vector-space    >= 0.6,-                      wumpus-core     == 0.35.0+                      wumpus-core     == 0.36.0       exposed-modules:@@ -114,11 +129,10 @@     Wumpus.Basic.Chains.Derived,     Wumpus.Basic.Colour.SVGColours,     Wumpus.Basic.Colour.X11Colours,-    Wumpus.Basic.Dots,-    Wumpus.Basic.Dots.Primitive,+    Wumpus.Basic.Dots.AnchorDots,+    Wumpus.Basic.Dots.Marks,     Wumpus.Basic.Graphic,     Wumpus.Basic.Graphic.Base,-    Wumpus.Basic.Graphic.DirectionContext,     Wumpus.Basic.Graphic.Drawing,     Wumpus.Basic.Graphic.DrawingContext,     Wumpus.Basic.Graphic.PrimGraphic,@@ -130,6 +144,7 @@     Wumpus.Basic.Paths.Base,     Wumpus.Basic.Paths.Connectors,     Wumpus.Basic.Paths.Construction,+    Wumpus.Basic.Paths.ControlPoints,     Wumpus.Basic.Paths.RoundCorners,     Wumpus.Basic.SafeFonts,     Wumpus.Basic.Shapes,@@ -139,6 +154,7 @@     Wumpus.Basic.Shapes.Plaintext,     Wumpus.Basic.Text.LRSymbol,     Wumpus.Basic.Text.LRText,+    Wumpus.Basic.Utils.Combinators,     Wumpus.Basic.Utils.HList,     Wumpus.Basic.Utils.Intersection,     Wumpus.Basic.VersionNumber,