diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs
--- a/demo/ArrowCircuit.hs
+++ b/demo/ArrowCircuit.hs
@@ -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"
diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs
new file mode 100644
--- /dev/null
+++ b/demo/Arrowheads.hs
@@ -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
+  
+
diff --git a/demo/Connectors.hs b/demo/Connectors.hs
new file mode 100644
--- /dev/null
+++ b/demo/Connectors.hs
@@ -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
+  
+
diff --git a/demo/DotPic.hs b/demo/DotPic.hs
--- a/demo/DotPic.hs
+++ b/demo/DotPic.hs
@@ -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?
diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs
--- a/demo/PetriNet.hs
+++ b/demo/PetriNet.hs
@@ -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
diff --git a/demo/Symbols.hs b/demo/Symbols.hs
--- a/demo/Symbols.hs
+++ b/demo/Symbols.hs
@@ -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
diff --git a/src/Wumpus/Basic/Arrows/Connectors.hs b/src/Wumpus/Basic/Arrows/Connectors.hs
--- a/src/Wumpus/Basic/Arrows/Connectors.hs
+++ b/src/Wumpus/Basic/Arrows/Connectors.hs
@@ -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
+
+
+
+
 
diff --git a/src/Wumpus/Basic/Arrows/Tips.hs b/src/Wumpus/Basic/Arrows/Tips.hs
--- a/src/Wumpus/Basic/Arrows/Tips.hs
+++ b/src/Wumpus/Basic/Arrows/Tips.hs
@@ -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
diff --git a/src/Wumpus/Basic/Dots.hs b/src/Wumpus/Basic/Dots.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Dots.hs
+++ /dev/null
@@ -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
diff --git a/src/Wumpus/Basic/Dots/AnchorDots.hs b/src/Wumpus/Basic/Dots/AnchorDots.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Dots/AnchorDots.hs
@@ -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
diff --git a/src/Wumpus/Basic/Dots/Marks.hs b/src/Wumpus/Basic/Dots/Marks.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Dots/Marks.hs
@@ -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) 
+
diff --git a/src/Wumpus/Basic/Dots/Primitive.hs b/src/Wumpus/Basic/Dots/Primitive.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Dots/Primitive.hs
+++ /dev/null
@@ -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) 
-
diff --git a/src/Wumpus/Basic/Graphic.hs b/src/Wumpus/Basic/Graphic.hs
--- a/src/Wumpus/Basic/Graphic.hs
+++ b/src/Wumpus/Basic/Graphic.hs
@@ -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
diff --git a/src/Wumpus/Basic/Graphic/Base.hs b/src/Wumpus/Basic/Graphic/Base.hs
--- a/src/Wumpus/Basic/Graphic/Base.hs
+++ b/src/Wumpus/Basic/Graphic/Base.hs
@@ -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) 
 
 
diff --git a/src/Wumpus/Basic/Graphic/DirectionContext.hs b/src/Wumpus/Basic/Graphic/DirectionContext.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Graphic/DirectionContext.hs
+++ /dev/null
@@ -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)
diff --git a/src/Wumpus/Basic/Graphic/Drawing.hs b/src/Wumpus/Basic/Graphic/Drawing.hs
--- a/src/Wumpus/Basic/Graphic/Drawing.hs
+++ b/src/Wumpus/Basic/Graphic/Drawing.hs
@@ -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
 
diff --git a/src/Wumpus/Basic/Graphic/PrimGraphic.hs b/src/Wumpus/Basic/Graphic/PrimGraphic.hs
--- a/src/Wumpus/Basic/Graphic/PrimGraphic.hs
+++ b/src/Wumpus/Basic/Graphic/PrimGraphic.hs
@@ -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
diff --git a/src/Wumpus/Basic/Paths.hs b/src/Wumpus/Basic/Paths.hs
--- a/src/Wumpus/Basic/Paths.hs
+++ b/src/Wumpus/Basic/Paths.hs
@@ -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
 
diff --git a/src/Wumpus/Basic/Paths/Base.hs b/src/Wumpus/Basic/Paths/Base.hs
--- a/src/Wumpus/Basic/Paths/Base.hs
+++ b/src/Wumpus/Basic/Paths/Base.hs
@@ -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. 
diff --git a/src/Wumpus/Basic/Paths/Connectors.hs b/src/Wumpus/Basic/Paths/Connectors.hs
--- a/src/Wumpus/Basic/Paths/Connectors.hs
+++ b/src/Wumpus/Basic/Paths/Connectors.hs
@@ -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 
diff --git a/src/Wumpus/Basic/Paths/ControlPoints.hs b/src/Wumpus/Basic/Paths/ControlPoints.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Paths/ControlPoints.hs
@@ -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
+
diff --git a/src/Wumpus/Basic/Paths/RoundCorners.hs b/src/Wumpus/Basic/Paths/RoundCorners.hs
--- a/src/Wumpus/Basic/Paths/RoundCorners.hs
+++ b/src/Wumpus/Basic/Paths/RoundCorners.hs
@@ -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
diff --git a/src/Wumpus/Basic/Shapes/Base.hs b/src/Wumpus/Basic/Shapes/Base.hs
--- a/src/Wumpus/Basic/Shapes/Base.hs
+++ b/src/Wumpus/Basic/Shapes/Base.hs
@@ -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)
 
 
diff --git a/src/Wumpus/Basic/Shapes/Derived.hs b/src/Wumpus/Basic/Shapes/Derived.hs
--- a/src/Wumpus/Basic/Shapes/Derived.hs
+++ b/src/Wumpus/Basic/Shapes/Derived.hs
@@ -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) 
 
 
diff --git a/src/Wumpus/Basic/Shapes/Plaintext.hs b/src/Wumpus/Basic/Shapes/Plaintext.hs
--- a/src/Wumpus/Basic/Shapes/Plaintext.hs
+++ b/src/Wumpus/Basic/Shapes/Plaintext.hs
@@ -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
diff --git a/src/Wumpus/Basic/Text/LRText.hs b/src/Wumpus/Basic/Text/LRText.hs
--- a/src/Wumpus/Basic/Text/LRText.hs
+++ b/src/Wumpus/Basic/Text/LRText.hs
@@ -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
diff --git a/src/Wumpus/Basic/Utils/Combinators.hs b/src/Wumpus/Basic/Utils/Combinators.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Utils/Combinators.hs
@@ -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
+
diff --git a/src/Wumpus/Basic/Utils/Intersection.hs b/src/Wumpus/Basic/Utils/Intersection.hs
--- a/src/Wumpus/Basic/Utils/Intersection.hs
+++ b/src/Wumpus/Basic/Utils/Intersection.hs
@@ -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
 
 
 
diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs
--- a/src/Wumpus/Basic/VersionNumber.hs
+++ b/src/Wumpus/Basic/VersionNumber.hs
@@ -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)
diff --git a/wumpus-basic.cabal b/wumpus-basic.cabal
--- a/wumpus-basic.cabal
+++ b/wumpus-basic.cabal
@@ -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,