diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,4 +1,61 @@
 
+0.4.0 to 0.5.0
+  
+  * Re-implemented Text drawing. Some functionality moved to 
+    Wumpus-Basic.
+  
+  * Re-implemented monadic Path Builder.
+  
+0.3.0 to 0.4.0:
+  
+  * Simplified Trapezium shape so it only produces isosceles
+    Trapeziums.
+  
+  * Added Basis modules. These are \"mid-level\" modules similar 
+    to ones in @Wumpus.Basic.Kernel.Objects@, however they are 
+    considered less general so there are put here where they can 
+    be imported individually (and so not pollute the namespace).
+  
+  * Removed the Turtle modules. The new @LocTrace@ and @RefTrace@ 
+    modules supercede the Turtle modules.
+  
+0.2.0 to 0.3.0:
+
+  * Moved Turtle and Grids into the @Wumpus.Drawing.Extras@
+    name-space. Modules here are considered sketches.
+
+  * Re-implemented arrowheads and connectors.
+
+  * Re-implemented monadic path construction. This is now 
+    essentially \"turtle drawing\" with a path trace.
+
+  * Removed chains - a simplified implementation is now 
+    provided by Wumpus-Basic.
+
+  * Re-implemented and expanded Text.  
+
+0.1.0 to 0.2.0:
+
+  * Added new Shapes.
+
+  * Move Geometry modules to Wumpus-Basic.
+
+  * Re-implemented Chains.
+
+  * Re-implemented LR-Text. Added CatText.
+
 0.1.0:
 
-  * Initial split from Wumpus-Basic.
+  * Initial release - this is a split from @Wumpus-Basic@ making 
+    the (very prototypical - read sub-alpha, unstable...) modules 
+    in the @Drawing@ hierarchy a separate package.
+
+  * Simplified Chains - chains are now regular lists (though often
+    infinite). Drawings are made with chains using new zip-like
+    functions.
+
+  * Re-worked Shapes.
+
+  * Re-worked Arrow and Arrow Tip types.
+
+  * Re-worked ConnectorPaths.
diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs
--- a/demo/ArrowCircuit.hs
+++ b/demo/ArrowCircuit.hs
@@ -5,59 +5,43 @@
 -- Acknowledgment - the Arrow diagram is taken from Ross 
 -- Paterson\'s slides /Arrows and Computation/.
 
+-- NOTE - this example now rather out-of-date. Wumpus-Drawing has 
+-- some new features to make node/connector drawing a bit easier.
 
 module ArrowCircuit where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
-import Wumpus.Drawing.Arrows
-import Wumpus.Drawing.Paths 
+import Wumpus.Drawing.Connectors
+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C
 import Wumpus.Drawing.Shapes
-import Wumpus.Drawing.Text.LRText
-import Wumpus.Drawing.Text.SafeFonts
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
 
-import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
 
-import FontLoaderUtils
+import Wumpus.Core                              -- package: wumpus-core
 
 
-import Data.AffineSpace
+import Data.AffineSpace                         -- package: vector-space
 
 import System.Directory
 
 
 main :: IO ()
-main = do 
-    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help
-    createDirectoryIfMissing True "./out/"
-    maybe gs_failk  makeGSPicture  $ mb_gs
-    maybe afm_failk makeAfmPicture $ mb_afm
-  where
-    gs_failk  = putStrLn "No GhostScript font path supplied..."
-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."
-
-makeGSPicture :: FilePath -> IO ()
-makeGSPicture font_dir = do 
-    putStrLn "Using GhostScript metrics..."
-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"]
-    mapM_ putStrLn msgs
-    let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic
-    writeEPS "./out/arrow_circuit01.eps" pic1
-    writeSVG "./out/arrow_circuit01.svg" pic1 
+main = simpleFontLoader main1 >> return ()
 
-makeAfmPicture :: FilePath -> IO ()
-makeAfmPicture font_dir = do 
-    putStrLn "Using AFM 4.1 metrics..."
-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"]
-    mapM_ putStrLn msgs
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/"    
+    base_metrics <- loader [ Right times_roman_family ]
+    printLoadErrors base_metrics
     let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic
-    writeEPS "./out/arrow_circuit02.eps" pic1
-    writeSVG "./out/arrow_circuit02.svg" pic1 
+    writeEPS "./out/arrow_circuit.eps" pic1
+    writeSVG "./out/arrow_circuit.svg" pic1 
 
  
-makeCtx :: GlyphMetrics -> DrawingContext
-makeCtx = fontFace times_roman . metricsContext 11
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font times_roman . metricsContext 11
 
 
 
@@ -68,9 +52,12 @@
 
 -- Note `at` currently does not work for Shapes.
          
-circuit_pic :: CtxPicture Double 
-circuit_pic = drawTracing $ do
-    a1 <- drawi $ (strokedShape $ rrectangle 12 66 30) `at` P2 0 72
+circuit_pic :: CtxPicture
+circuit_pic = drawTracing body 
+
+body :: TraceDrawing Double ()
+body = do
+    a1 <- drawi $ rrectangle 12 66 30 `at` P2 0 72
     atext a1 "CONST 0"
     a2 <- drawi $ (strokedShape $ circle 16) `at` P2 120 60
     atext a2 "IF"
@@ -78,41 +65,73 @@
     atext a3 "+1"
     a4 <- drawi $ (strokedShape $ rectangle 66 30) `at` P2 120 0
     atext a4 "DELAY 0"
-    connWith connLine (east a1) (east a1 .+^ hvec 76)
-    connWith connLine (east a2) (east a2 .+^ hvec 180)
-    connWith connLine (north a2 .+^ vvec 40) (north a2)
-    connWith connLine (north a3 .+^ vvec 16) (north a3)  
-    connWith connRightVH  (south a3) (east a4)
-    connWith (connRightHVH (-30)) (west a4)  (southwest a2)
+    connWith conn_line (east a1) ((.+^ hvec 76) $ east a1)
+    connWith conn_line (east a2) ((.+^ hvec 180) $ east a2)
+    connWith conn_line ((.+^ vvec 40) $ north a2) (north a2)
+    connWith conn_line ((.+^ vvec 16) $ north a3) (north a3)  
+    connWith conna_right  (south a3) (east a4)
+    connWith conna_orthovbar    (west a4)  (southwest a2)
     ptext (P2  40  10) "next"
     ptext (P2 152 100) "reset"
     ptext (P2 252  72) "output"
     return ()
 
+    -- Note - need a variant of /bar/ that draws UDLR only.
 
+connWith :: ( Real u, Floating u, InterpretUnit u ) 
+         => ArrowConnector u -> Anchor u -> Anchor u -> TraceDrawing u ()
+connWith con a0 a1 = localize double_point_size $ 
+    drawc a0 a1 (ignoreAns con)
 
-connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m
-            , Real u, Floating u, FromPtSize u ) 
-         => ConnectorPath u -> Point2 u -> Point2 u -> m ()
-connWith con p0 p1 = localize doublesize $ 
-    drawi_ $ apply2R2 (rightArrow tri45 con) p0 p1
 
+atext :: ( CenterAnchor (t u), u ~ DUnit (t u)
+         , Real u, Floating u, InterpretUnit u)
+      => t u -> String -> TraceDrawing u ()
+atext ancr ss = 
+    draw $ textline CENTER ss `at` (center ancr)
 
-atext :: ( CenterAnchor t, DUnit t ~ u
-         , Real u, Floating u, FromPtSize u
-         , TraceM m, DrawingCtxM m, u ~ MonUnit m )
-      => t -> String -> m ()
-atext ancr ss = let pt = center ancr in
-   drawi_ $ ctrCenterLine ss `at` pt
 
+ptext :: (Floating u, InterpretUnit u) 
+      => Point2 u -> String -> TraceDrawing u ()
+ptext pt ss = localize (font_attr times_italic 14) $ 
+    draw $ textline CENTER ss `at` pt
 
-ptext :: ( Real u, Floating u, FromPtSize u
-         , TraceM m, DrawingCtxM m, u ~ MonUnit m )
-      => Point2 u -> String -> m ()
-ptext pt ss = localize (fontAttr times_italic 14) $ 
-    drawi_ $ ctrCenterLine ss `at` pt
 
+-- Note - return type is a LocImage not a shape...
+--
+rrectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+           => Double -> u -> u -> LocImage u (Rectangle u)
+rrectangle _r w h = strokedShape (rectangle w h)
+    -- This should have round corners but they are currently
+    -- disabled pending a re-think. 
+    {- localize (round_corner_factor r) $ -} 
 
-rrectangle :: (Real u, Floating u, FromPtSize u) 
-           => u -> u -> u -> LocShape u (Rectangle u)
-rrectangle r w h = localize (roundCornerFactor $ realToFrac r) (rectangle w h)
+
+
+-- Cf. Parsec\'s Token module...
+
+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ArrowConnector u
+conn_line =
+    renderConnectorConfig default_connector_props $ makeSglArrConn C.conn_line
+
+conna_orthovbar :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ArrowConnector u
+conna_orthovbar = 
+    renderConnectorConfig default_connector_props $ 
+      makeSglArrConn C.conna_orthovbar
+
+
+conna_right :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+            => ArrowConnector u
+conna_right = 
+    renderConnectorConfig default_connector_props $ makeSglArrConn C.conna_right
+
+
+makeSglArrConn :: ConnectorPathSpec u -> ConnectorConfig u
+makeSglArrConn cspec = 
+    ConnectorConfig
+      { conn_arrowl     = Nothing
+      , conn_arrowr     = Just tri45
+      , conn_path_spec  = cspec
+      }
diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs
--- a/demo/Arrowheads.hs
+++ b/demo/Arrowheads.hs
@@ -2,82 +2,106 @@
 
 module Arrowheads where
 
-
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Arrows
-import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
-import Wumpus.Drawing.Paths hiding ( length )
+import Wumpus.Drawing.Connectors
+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
 
-import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
 
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.Monoid
 import System.Directory
 
 main :: IO ()
-main = do 
-    createDirectoryIfMissing True "./out/"
-    let pic1 = runCtxPictureU std_ctx arrow_drawing
-    writeEPS "./out/arrowheads01.eps" pic1
-    writeSVG "./out/arrowheads01.svg" pic1
+main = simpleFontLoader main1 >> return ()
 
-arrow_drawing :: CtxPicture Double
-arrow_drawing = drawTracing $ localize (dashPattern unit_dash_pattern) 
-                            $ tableGraphic arrtable
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/"    
+    base_metrics <- loader [ Left helvetica ]
+    printLoadErrors base_metrics
+    let pic1 = runCtxPictureU (makeCtx base_metrics) arrow_drawing
+    writeEPS "./out/arrowheads.eps" pic1
+    writeSVG "./out/arrowheads.svg" pic1
 
-arrtable :: [(Arrowhead Double, Arrowhead Double)]
+
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font helvetica . metricsContext 14
+
+
+
+arrow_drawing :: CtxPicture
+arrow_drawing = 
+    drawTracing $ localize line_thick $ tableGraphic arrtable
+
+arrtable :: [(String, ArrowTip)]
 arrtable = 
-    [ (tri90,       tri90)
-    , (tri60,       tri60)
-    , (tri45,       tri45)
-    , (otri90,      otri90)
-    , (otri60,      otri60)
-    , (otri45,      otri45)
-    , (revtri90,    revtri90)
-    , (revtri60,    revtri60)
-    , (revtri45,    revtri45)
-    , (orevtri90,   orevtri90)
-    , (orevtri60,   orevtri60)
-    , (orevtri45,   orevtri45)
-    , (barb90,      barb90)
-    , (barb60,      barb60)
-    , (barb45,      barb45)
-    , (revbarb90,   revbarb90)
-    , (revbarb60,   revbarb60)
-    , (revbarb45,   revbarb45)
-    , (perp,        perp)
-    , (bracket,     bracket)
-    , (diskTip,     diskTip)
-    , (odiskTip,    odiskTip)
-    , (squareTip,   squareTip)
-    , (osquareTip,  osquareTip)
-    , (diamondTip,  diamondTip)
-    , (odiamondTip, odiamondTip)
-    , (curveTip,    curveTip)
-    , (revcurveTip, revcurveTip)
+    [ ("tri90",                 tri90)
+    , ("tri60",                 tri60)
+    , ("tri45",                 tri45)  
+    , ("otri90",                otri90)
+    , ("otri60",                otri60)
+    , ("otri45",                otri45)
+    , ("revtri90",              revtri90)
+    , ("revtri60",              revtri60)
+    , ("revtri45",              revtri45)
+    , ("orevtri90",             orevtri90)
+    , ("orevtri60",             orevtri60)
+    , ("orevtri45",             orevtri45)
+    , ("barb90",                barb90)
+    , ("barb60",                barb60)
+    , ("barb45",                barb45)
+    , ("revbarb90",             revbarb90)
+    , ("revbarb60",             revbarb60)
+    , ("revbarb45",             revbarb45)
+    , ("perp",                  perp)
+    , ("bracket",               bracket)
+    , ("diskTip",               diskTip)
+    , ("odiskTip",              odiskTip)
+    , ("squareTip",             squareTip)
+    , ("osquareTip",            osquareTip)
+    , ("diamondTip",            diamondTip)
+    , ("odiamondTip",           odiamondTip)
+    , ("diamondWideTip",        diamondWideTip)
+    , ("odiamondWideTip",       odiamondWideTip)
+    , ("curveTip",              curveTip)
+    , ("revcurveTip",           revcurveTip)    
     ]
 
-tableGraphic :: (Real u, Floating u, FromPtSize u) 
-             => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u ()
-tableGraphic tips = zipchainWith makeArrowDrawing tips ps
-  where
-    ps = tableDown 20 (120,24) (P2 0 480)
 
 
+tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double ()
+tableGraphic tips = 
+    drawl start $ distribColumnwiseTable 18 (180,24) $ map arrowGraphic tips
+  where
+    start   = P2 0 480
+
  
 std_ctx :: DrawingContext
-std_ctx = fillColour peru $ standardContext 18
+std_ctx = fill_colour peru $ standardContext 18
 
 
 
-makeArrowDrawing :: (Real u, Floating u, FromPtSize u) 
-                 => (Arrowhead u, Arrowhead u) -> LocGraphic u
-makeArrowDrawing (arrl,arrr) = 
-    promoteR1 $ \p0 -> forget $
-      connect (leftRightArrow arrl arrr connLine) p0 (mkP1 p0)
+-- Note - /null/ chain action needs a better type synonym name.
+--
+arrowGraphic :: (String, ArrowTip) -> LocGraphic Double
+arrowGraphic (name, utip) = aconn `mappend` lbl
   where
-    mkP1    = (.+^ hvec 100)
-    -- forget needs a better name, then adding to Wumpus-Basic.
-    forget  = fmap (replaceL uNil)  
+    aconn = ignoreAns $ promoteLoc $ \pt ->
+              connect (mkConn_line utip) pt (displace (hvec 60) pt)
+
+    lbl   = ignoreAns $ promoteLoc $ \pt -> 
+              textline WW name `at` (displace (hvec 66) pt)
+
+
+
+mkConn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+            => ArrowTip -> ArrowConnector u
+mkConn_line = rightArrowConnector default_connector_props C.conn_line
+
 
diff --git a/demo/Automata.hs b/demo/Automata.hs
new file mode 100644
--- /dev/null
+++ b/demo/Automata.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+module Automata where
+
+import Wumpus.Drawing.Connectors
+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C
+import Wumpus.Drawing.Extras.Loop
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Shapes
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
+import Wumpus.Drawing.Text.Base.Label
+
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import System.Directory
+
+
+
+main :: IO ()
+main = simpleFontLoader main1 >> return ()
+
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/"    
+    base_metrics <- loader [ Right times_roman_family  ]
+    printLoadErrors base_metrics
+    let pic1 = runCtxPictureU (makeCtx base_metrics) automata
+    writeEPS "./out/automata.eps" pic1
+    writeSVG "./out/automata.svg" pic1 
+
+
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = 
+    snap_grid_factors 60.0 60.0 . set_font times_roman . metricsContext 14
+
+
+automata :: CtxPicture
+automata = udrawTracing (0::Double) $ do
+    q0     <- nodei (8,0)   $ state "q0"
+    q1     <- drawi $ state "q1"      `mat` above_right_of q0
+    q2     <- drawi $ state "q2"      `mat` below_right_of q0
+    q3     <- drawi $ stopstate "q3"  `mat` below_right_of q1
+
+    s0     <- evalQuery $ left_of q0
+
+    draw $ label_midway_of SE (textline `flip` "0") $ straightconn q0 q1
+    draw $ label_midway_of SS (textline `flip` "0") $ arrloop (center q1) (north q1) 
+    draw $ label_midway_of SW (textline `flip` "1") $ straightconn q1 q3
+    draw $ label_midway_of NE (textline `flip` "1") $ straightconn q0 q2
+    draw $ label_midway_of NW (textline `flip` "0") $ straightconn q2 q3
+    draw $ label_midway_of NN (textline `flip` "1") $ arrloop (center q2) (south q2) 
+    draw $ label_atstart_of EE (textline `flip` "start") $ astraightconn s0 (west q0) 
+
+    return ()
+
+-- Monadic at - this is a hack that needs a rethink...
+-- 
+infixr 1 `mat`
+
+mat :: InterpretUnit u => LocImage u a -> Query u (Point2 u) -> Image u a
+mat img mq = liftQuery mq >>= \pt -> img `at` pt
+
+state :: String -> DLocImage DCircle
+state ss = 
+    localize (set_font times_italic) $ 
+        label_center_of (textline `flip` ss) $ strokedShape $ circle 20
+
+
+stopstate :: String -> DLocImage DCircle 
+stopstate ss = 
+    localize (set_font times_italic) $ 
+        label_center_of (textline `flip` ss) $ dblStrokedShape $ circle 20
+
+
+
+straightconn :: ( Real u, Floating u, InterpretUnit u, Tolerance u
+                , u ~ DUnit a, u ~ DUnit b
+                , CenterAnchor a, RadialAnchor a
+                , CenterAnchor b, RadialAnchor b
+                )
+             => a -> b -> Image u (AbsPath u)
+straightconn a b =
+    let (p0,p1) = radialConnectorPoints a b in connect conn_line p0 p1
+
+
+astraightconn :: ( Real u, Floating u, InterpretUnit u, Tolerance u)
+              => Anchor u -> Anchor u -> Image u (AbsPath u)
+astraightconn p0 p1 = connect conn_line p0 p1
+
+
+-- Note - there is a problem with @rightArrow@ as @loop@
+-- manufactures the start and end points...
+--
+arrloop :: ( Real u, Floating u, InterpretUnit u, Tolerance u)
+        => Anchor u -> Anchor u -> Image u (AbsPath u)
+arrloop ctr p1 = 
+    rightArrowPath $ loopPath zradius ctr zincl
+  where
+    v1      = pvec ctr p1
+    zradius = vlength v1
+    zincl   = vdirection v1
+
+
+-- Cf. Parsec\'s Token module...
+
+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+         => ArrowConnector u
+conn_line = rightArrowConnector default_connector_props C.conn_line tri45
+
+
+
+
+rightArrowPath :: (Real u, Floating u, InterpretUnit u)
+               => AbsPath u -> Image u (AbsPath u)
+rightArrowPath = arrowDecoratePath Nothing (Just tri45) 
diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs
--- a/demo/ClipPic.hs
+++ b/demo/ClipPic.hs
@@ -12,93 +12,132 @@
 
 module ClipPic where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
+import Wumpus.Drawing.Extras.Clip
 import Wumpus.Drawing.Paths
-import Wumpus.Drawing.Text.SafeFonts
+import Wumpus.Drawing.Text.StandardFontDefs
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
 
 import Data.AffineSpace                         -- package: vector-space
 
+import Data.Monoid
 import System.Directory
 
 
 main :: IO ()
 main = do 
     createDirectoryIfMissing True "./out/"
-    let pic = runCtxPictureU pic_drawing_ctx big_pic
-    writeEPS "./out/clip_pic.eps" pic
-    writeSVG "./out/clip_pic.svg" pic
+    let pic1 = runCtxPictureU std_ctx clip_pic
+    writeEPS "./out/clip_pic.eps" pic1
+    writeSVG "./out/clip_pic.svg" pic1
 
 
-pic_drawing_ctx :: DrawingContext
-pic_drawing_ctx = standardContext 14
+std_ctx :: DrawingContext
+std_ctx = standardContext 14
 
 
-big_pic :: DCtxPicture
-big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4]
+-- Note - currently the code is quite messy, path drawing needs 
+-- some convenience combinators.
 
-fillPath :: Num u => Path u -> Graphic u
-fillPath = filledPath . toPrimPath
+clip_pic :: CtxPicture
+clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do
+    drawl (P2   0 320) $ runPathSpec_ CFILL path01
+    drawl (P2 112 320) $ localize (fill_colour powder_blue) $ 
+                           runPathSpec_ CFILL path02
+    drawl (P2 384 416) $ runPathSpec_ CFILL path03
+    drawl (P2 328 512) $ runPathSpec_ CFILL path04
+    drawl (P2   0   0) $ clip1
+    drawl (P2 112   0) $ clip2
+    drawl (P2 384  96) $ clip3
+    drawl (P2 328 192) $ clip4
 
-pic1 :: DCtxPicture
-pic1 = drawTracing $
-         localize (fillColour medium_slate_blue) $ do
-            draw $ fillPath path01
-            localize (fillColour powder_blue) $ 
-                     draw $ fillPath path02
-            draw $ fillPath path03
-            draw $ fillPath path04
 
+-- PathSpec is overkill here...
+--
+extrPathSpec :: InterpretUnit u 
+             => PathSpec u a -> LocQuery u (AbsPath u)
+extrPathSpec spec = qpromoteLoc $ \pt ->
+    fmap post $ qapplyLoc (stripGenPathSpec () CSTROKE spec) pt
+  where
+    post (_,_,c) = c
 
-background :: RGBi -> DCtxPicture
-background rgb = drawTracing $ 
-    localize (strokeColour rgb) $ 
-        unchain 112 iheartHaskell $ tableDown 18 (86,16) (P2 0 288)
+background :: RGBi -> LocGraphic Double
+background rgb = promoteLoc $ \_ -> 
+    ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288
+  where
+    ihh = distribColumnwiseTable 18 (86,16) $ replicate 112 iheartHaskell
+                   
 
-cpic1 :: DCtxPicture 
-cpic1 = clipCtxPicture (toPrimPath path01) (background black)
+-- | This is one for Wumpus-Basic - the set of combinators to 
+-- shift between Images and Queries needs sorting out
+--
+
+zapLocQ :: InterpretUnit u => LocQuery u a-> LocImage u a
+zapLocQ ma = promoteLoc $ \pt -> 
+   askDC >>= \ctx ->
+   let a = runLocQuery ctx pt ma in return a
+
+clip1 :: LocGraphic Double
+clip1 = zapLocQ (extrPathSpec path01) >>= \a -> 
+        locClip a (background black)
   
-cpic2 :: DCtxPicture
-cpic2 = clipCtxPicture (toPrimPath path02) (background medium_violet_red)
+clip2 :: LocGraphic Double
+clip2 = zapLocQ (extrPathSpec path02) >>= \a -> 
+        locClip a (background medium_violet_red)
 
-cpic3 :: DCtxPicture 
-cpic3 = clipCtxPicture (toPrimPath path03) (background black)
+clip3 :: LocGraphic Double
+clip3 = zapLocQ (extrPathSpec path03) >>= \a -> locClip a (background black)
 
-cpic4 :: DCtxPicture 
-cpic4 = clipCtxPicture (toPrimPath path04) (background black)
+clip4 :: LocGraphic Double
+clip4 = zapLocQ (extrPathSpec path04) >>= \a -> locClip a (background black)
 
 
-iheartHaskell :: Num u => FromPtSize u => LocGraphic u
-iheartHaskell = promoteR1 $ \pt -> 
-    let body  = textline "I Haskell" `at` pt
-        heart = localize (fontFace symbol) $ 
-                  textline "&heart;" `at` (pt .+^ hvec 7)
-    in body `oplus` heart
+iheartHaskell :: LocGraphic Double
+iheartHaskell = promoteLoc $ \pt -> 
+    let body  = dcTextlabel "I Haskell" `at` pt
+        heart = localize (set_font symbol) $ 
+                  dcTextlabel "&heart;" `at` (pt .+^ hvec 7)
+    in body `mappend` heart
 
+-- Note - this needs a more uniform name. In Wumpus an object 
+-- that produces a @UNil@ is called a __Graphic but that 
+-- convention seems misleading here.
+--
+type UPathSpec u = PathSpec u (UNil u)
 
-path01 :: Floating u => Path u
-path01 = execPath zeroPt $ hline 80 >> rlineto (vec 112 160) 
-                                    >> rlineto (vec (-112) 160)
-                                    >> hline (-80)
-                                    >> rlineto (vec 112 (-160))
-                                    >> rlineto (vec (-112) (-160))
- 
+-- zeroPt
+path01 :: UPathSpec Double
+path01 = do 
+    hpenline 80 
+    penline (vec 112 160) 
+    penline (vec (-112) 160)
+    hpenline (-80)
+    penline (vec 112 (-160))
+    penline (vec (-112) (-160))
+    ureturn
 
-path02 :: Floating u => Path u
-path02 = execPath (P2 112 0) $ hline 80 >> rlineto (vec 72 112)
-                                        >> rlineto (vec 72 (-112))
-                                        >> hline 80
-                                        >> rlineto (vec (-224) 320)
-                                        >> hline (-80)
-                                        >> rlineto (vec 112 (-160))
-                                        >> rlineto (vec (-112) (-160))
 
-path03 :: Floating u => Path u
-path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) 
+-- (P2 112 0)
+path02 :: UPathSpec Double
+path02 = do 
+    hpenline 80 
+    penline (vec 72 112)
+    penline (vec 72 (-112))
+    hpenline 80
+    penline (vec (-224) 320)
+    hpenline (-80)
+    penline (vec 112 (-160))
+    penline (vec (-112) (-160))
+    ureturn
 
-path04 :: Floating u => Path u
-path04 = execPath (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) 
+-- (P2 384 96) 
+path03 :: UPathSpec Double
+path03 = hpenline 96 >> vpenline 56 >> hpenline (-136) >> ureturn
+
+-- (P2 328 192)
+path04 :: UPathSpec Double
+path04 = hpenline 152 >> vpenline 56 >> hpenline (-192) >> ureturn
 
diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs
--- a/demo/ColourCharts.hs
+++ b/demo/ColourCharts.hs
@@ -4,11 +4,13 @@
 
 import ColourChartUtils
 
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Chains
+import Wumpus.Drawing.Basis.DrawingPrimitives
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
 
+import Data.Monoid
 import System.Directory
 
 
@@ -21,37 +23,37 @@
     writeSVG "./out/SVGcolours.svg" svg_pic
     --
     let x11_p = runCtxPictureU draw_ctx x11_portrait
-    writeEPS "./out/X11colours.eps" $ uniformScale 0.75 x11_p
+    writeEPS "./out/X11colours.eps" $ scale 0.75 0.75 x11_p
     let x11_l = runCtxPictureU draw_ctx x11_landscape
     writeSVG "./out/X11colours.svg" x11_l
 
 draw_ctx :: DrawingContext
 draw_ctx = (standardContext 9)
 
-svg :: CtxPicture Double
+svg :: CtxPicture
 svg = makeDrawing 52 all_svg_colours
 
-x11_landscape :: CtxPicture Double
+x11_landscape :: CtxPicture
 x11_landscape = makeDrawing 52 all_x11_colours
 
-x11_portrait :: CtxPicture Double
+x11_portrait :: CtxPicture
 x11_portrait = makeDrawing 72 all_x11_colours     
 
-makeDrawing :: Int -> [(String,RGBi)] -> DCtxPicture
+makeDrawing :: Int -> [(String,RGBi)] -> CtxPicture
 makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs
 
 tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double ()
 tableGraphic row_count xs = 
-    zipchainWith (\(name,rgb) -> colourSample name rgb) xs ps
+    drawl pt $ distribColumnwiseTable row_count (152,11) gs
   where
-    ps = tableDown row_count (152,11) pt
-    pt = displaceV (fromIntegral $ 11 * row_count) zeroPt 
-
+    pt   = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt 
+    gs   = map (uncurry colourSample) xs
+   
 
 colourSample :: String -> RGBi -> LocGraphic Double
-colourSample name rgb = localize (fillColour rgb) $ 
-    promoteR1 $ \pt ->  
-      oplus (borderedRectangle 15 10 `at` pt)
-            (textline name `at` displace 20 2 pt)
+colourSample name rgb = localize (fill_colour rgb) $ 
+    promoteLoc $ \pt ->  
+      mappend (blRectangle DRAW_FILL_STROKE 15 10 `at` pt)
+              (dcTextlabel name `at` displace (vec 20 2) pt)
         
 
diff --git a/demo/Connectors.hs b/demo/Connectors.hs
--- a/demo/Connectors.hs
+++ b/demo/Connectors.hs
@@ -2,71 +2,110 @@
 
 module Connectors where
 
-
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Arrows
-import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
-import Wumpus.Drawing.Paths hiding ( length )
+import Wumpus.Drawing.Connectors
+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
+
 import Wumpus.Core                              -- package: wumpus-core
 
+
+import Data.Monoid
 import System.Directory
 
+
 main :: IO ()
-main = do 
-    createDirectoryIfMissing True "./out/"
-    let pic1 = runCtxPictureU std_ctx conn_pic
-    writeEPS "./out/connectors01.eps" pic1
-    writeSVG "./out/connectors01.svg" pic1
+main = simpleFontLoader main1 >> return ()
 
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/"    
+    base_metrics <- loader [ Left helvetica ]
+    printLoadErrors base_metrics
+    let pic1 = runCtxPictureU (makeCtx base_metrics) conn_pic
+    writeEPS "./out/connectors.eps" pic1
+    writeSVG "./out/connectors.svg" pic1 
+          
 
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font helvetica . metricsContext 11
 
-conn_pic :: CtxPicture Double
-conn_pic = drawTracing $ tableGraphic $ conntable
+conn_pic :: CtxPicture 
+conn_pic = drawTracing $ tableGraphic conntable
 
-conntable :: [ConnectorPath Double]
+
+conntable :: [(String, ConnectorPathSpec Double)]
 conntable = 
-    [ connLine
-    , connRightVH
-    , connRightHV
-    , connRightVHV 15
-    , connRightHVH 15
-    , connIsosceles 25
-    , connIsosceles (-25)
-    , connIsosceles2 15
-    , connIsosceles2 (-15)
-    , connLightningBolt 15
-    , connLightningBolt (-15)
-    , connIsoscelesCurve 25
-    , connIsoscelesCurve (-25)
-    , connSquareCurve
-    , connUSquareCurve
-    , connTrapezoidCurve 40 0.5
-    , connTrapezoidCurve (-40) 0.5
-    , connZSquareCurve   
-    , connUZSquareCurve   
+    [ ("conn_line",             C.conn_line)
+    , ("conna_arc",             C.conna_arc)
+    , ("connb_arc",             C.connb_arc)
+    , ("conn_hdiagh",           C.conn_hdiagh)
+    , ("conn_vdiagv",           C.conn_vdiagv)
+    , ("conn_diagh",            C.conn_diagh)
+    , ("conn_diagv",            C.conn_diagv)
+    , ("conn_hdiag",            C.conn_hdiag)
+    , ("conn_vdiag",            C.conn_vdiag)
+    , ("conna_bar",             C.conna_bar)
+    , ("connb_bar",             C.connb_bar)
+    , ("conna_flam",            C.conna_flam)
+    , ("connb_flam",            C.connb_flam)
+    , ("conna_orthohbar",       C.conna_orthohbar)
+    , ("connb_orthohbar",       C.connb_orthohbar)
+    , ("conna_orthovbar",       C.conna_orthovbar)
+    , ("connb_orthovbar",       C.connb_orthovbar)
+    , ("conna_right",           C.conna_right)
+    , ("connb_right",           C.connb_right)
+    , ("conn_hrr",              C.conn_hrr )
+    , ("conn_rrh",              C.conn_rrh)
+    , ("conn_vrr",              C.conn_vrr)
+    , ("conn_rrv",              C.conn_rrv)
+    , ("conna_loop",            C.conna_loop)
+    , ("connb_loop",            C.connb_loop)
+    , ("conn_hbezier",          C.conn_hbezier)
+    , ("conn_vbezier",          C.conn_vbezier)
     ]
 
-tableGraphic :: (Real u, Floating u, FromPtSize u) 
-             => [ConnectorPath u] -> TraceDrawing u ()
-tableGraphic conns = zipchainWith makeConnDrawing conns ps
-  where
-    ps = tableDown 10 (120,52) (displaceV 520 zeroPt)
+props :: ConnectorProps
+props = default_connector_props { conn_src_arm   = 1
+                                , conn_dst_arm   = 1.5
+                                , conn_src_space = 0.5
+                                , conn_dst_space = 0.5 } 
 
 
+tableGraphic :: [(String, ConnectorPathSpec Double)] -> TraceDrawing Double ()
+tableGraphic conns = 
+    drawl start $ distribColumnwiseTable 6 (200,80) $ map makeConnDrawing conns
+  where
+    start = P2 0 520 
+
  
 std_ctx :: DrawingContext
-std_ctx = fillColour peru $ standardContext 18
+std_ctx = fill_colour peru $ standardContext 18
 
 
 
-makeConnDrawing :: (Real u, Floating u, FromPtSize u) 
-                 => ConnectorPath u -> LocGraphic u
-makeConnDrawing conn = 
-    promoteR1 $ \p0 -> fmap (replaceL uNil) $ 
-        connect (uniformArrow curveTip conn) p0 (mkP1 p0)
+makeConnDrawing :: (String, ConnectorPathSpec Double) -> DLocGraphic 
+makeConnDrawing (ss,conn) = 
+    promoteLoc $ \p0 -> fn p0 (displace (vec 72 42) p0) 
   where
-    mkP1 = displace 100 40
-  
+    fn p0 p1   = mconcat [disk p0, disk p1, dcon p0 p1, lbl p1]
+
+    disk pt    = localize (fill_colour red) $ dcDisk DRAW_FILL 2 `at` pt
+    dcon p0 p1 = ignoreAns $ connect biarrow p0 p1
+
+    lbl  pt    = ignoreAns $ textline WW ss `at` (displace (V2 10 (-10)) pt)
+
+    biarrow    = renderConnectorConfig props conf
+                    
+
+    conf       = ConnectorConfig { conn_arrowl    = Just curveTip
+                                 , conn_arrowr    = Just curveTip
+                                 , conn_path_spec = conn
+                                 }
+
+                    
 
diff --git a/demo/DotPic.hs b/demo/DotPic.hs
--- a/demo/DotPic.hs
+++ b/demo/DotPic.hs
@@ -2,122 +2,103 @@
 
 module DotPic where
 
-
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
-import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
 import Wumpus.Drawing.Dots.AnchorDots
-import Wumpus.Drawing.Text.SafeFonts
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
 
-import FontLoaderUtils
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space
-
+import Data.Monoid
 import System.Directory
 
-
-
 main :: IO ()
-main = do 
-    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help
-    createDirectoryIfMissing True "./out/"
-    maybe gs_failk  makeGSPicture  $ mb_gs
-    maybe afm_failk makeAfmPicture $ mb_afm
-  where
-    gs_failk  = putStrLn "No GhostScript font path supplied..."
-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."
-
+main = simpleFontLoader main1 >> return ()
 
-makeGSPicture :: FilePath -> IO ()
-makeGSPicture font_dir = do 
-    putStrLn "Using GhostScript metrics..."
-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"]
-    mapM_ putStrLn msgs
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/" 
+    base_metrics <- loader [ Left helvetica ]
+    printLoadErrors base_metrics
     let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic
-    writeEPS "./out/dot_pic01_gs.eps" pic1
-    writeSVG "./out/dot_pic01_gs.svg" pic1
+    writeEPS "./out/dot_pic.eps" pic1
+    writeSVG "./out/dot_pic.svg" pic1
 
  
-
-makeAfmPicture :: FilePath -> IO ()
-makeAfmPicture font_dir = do 
-    putStrLn "Using AFM 4.1 metrics..."
-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"]
-    mapM_ putStrLn msgs
-    let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic
-    writeEPS "./out/dot_pic01_afm.eps" pic1
-    writeSVG "./out/dot_pic01_afm.svg" pic1
-
  
-makeCtx :: GlyphMetrics -> DrawingContext
-makeCtx = fillColour peru . fontFace helvetica . metricsContext 24
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = fill_colour peru . set_font helvetica . metricsContext 14
 
 
-dot_pic :: CtxPicture Double
-dot_pic = drawTracing $ tableGraphic $ 
-    [ dotHLine
-    , dotVLine
-    , dotX
-    , dotPlus
-    , dotCross
-    , dotDiamond
-    , dotDisk
-    , dotSquare
-    , dotCircle
-    , dotPentagon
-    , dotStar
-    , dotAsterisk
-    , dotOPlus
-    , dotOCross
-    , dotFOCross
-    , dotFDiamond
-    , dotText "%" 
-    , dotTriangle
-    ]
+dot_pic :: CtxPicture
+dot_pic = drawTracing $ tableGraphic dottable
 
 
-tableGraphic :: (Real u, Floating u, FromPtSize u) 
-             => [DotLocImage u] -> TraceDrawing u ()
-tableGraphic imgs = zipchainWith makeDotDrawing imgs ps
-  where
-    row_count   = length imgs
-    ps          = tableDown row_count (1,36) pt
-    pt          = displaceV (fromIntegral $ 36 * row_count) zeroPt 
+-- Note - dots should probably have lower_case_with_underscore 
+-- names.
 
+dottable :: [(String, DotLocImage Double)]
+dottable =   
+    [ ("smallDisk",     smallDisk)
+    , ("largeDisk",     largeDisk)
+    , ("smallCirc",     smallCirc)
+    , ("largeCirc",     largeCirc)
+    , ("dotNone",       dotNone)
+    , ("dotHBar",       dotHBar)
+    , ("dotVBar",       dotVBar)
+    , ("dotX",          dotX)
+    , ("dotPlus",       dotPlus)
+    , ("dotCross",      dotCross)
+    , ("dotDiamond",    dotDiamond)
+    , ("dotDisk",       dotDisk)
+    , ("dotSquare",     dotSquare)
+    , ("dotCircle",     dotCircle)
+    , ("dotPentagon",   dotPentagon)
+    , ("dotStar",       dotStar)
+    , ("dotAsterisk",   dotAsterisk)
+    , ("dotOPlus",      dotOPlus)
+    , ("dotOCross",     dotOCross)
+    , ("dotFOCross",    dotFOCross)
+    , ("dotFDiamond",   dotFDiamond)
+    , ("dotText" ,      dotText "%")
+    , ("dotTriangle",   dotTriangle) 
+    ]
 
 
--- This is a bit convoluted - maybe there should be chain-run 
--- functions for TraceDrawings as well as LocGraphics?
 
-makeDotDrawing :: (Real u, Floating u, FromPtSize u) 
-               => DotLocImage u -> LocGraphic u
-makeDotDrawing dotF = 
-    promoteR1 $ \pt -> 
-        let all_points = map (pt .+^) displacements
-        in oconcat (dashline all_points)
-                   (map (\p1 -> ignoreL $ dotF `at` p1) all_points)
+tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double ()
+tableGraphic imgs = 
+    drawl pt $ distribColumnwiseTable row_count (180,36) 
+             $ map makeDotDrawing imgs
   where
-    dashline = \ps -> localize attrUpd (openStroke $ vertexPath ps)
+    row_count   = 18
+    pt          = displace (vvec $ fromIntegral $ 36 * row_count) zeroPt 
 
-    attrUpd  :: DrawingContext -> DrawingContext
-    attrUpd  =  dashPattern (evenDashes 1) . strokeColour cadet_blue
 
-    ignoreL  = fmap (replaceL uNil) 
 
-displacements :: Num u => [Vec2 u]
-displacements = [V2 0 0, V2 64 20, V2 128 0, V2 192 20]
 
+makeDotDrawing :: (String, DotLocImage Double) -> DLocGraphic 
+makeDotDrawing (name,df) = 
+    drawing `mappend` moveStart (vec 86 14) lbl
+  where
+    drawing     = runPathSpec_ OSTROKE path_spec
 
--- Should these produce a DashPattern or a StrokeAttr?
+    path_spec   = updatePen path_style >>
+                  insertl dot >> 
+                  mapM (\v -> penline v >> insertl dot) steps >>
+                  ureturn
+                                
+                           
 
-evenDashes :: Int -> DashPattern 
-evenDashes n = Dash 0 [(n,n)]
+    lbl         = ignoreAns $ promoteLoc $ \pt -> 
+                    textline WW name `at` pt
 
-dashOffset :: Int -> DashPattern -> DashPattern
-dashOffset _ Solid       = Solid
-dashOffset n (Dash _ xs) = Dash n xs
+    steps       = [V2 25 15, V2 25 (-15), V2 25 15]
+    dot         = ignoreAns df
+    path_style  = packed_dotted . stroke_colour cadet_blue
+
 
diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs
--- a/demo/FeatureModel.hs
+++ b/demo/FeatureModel.hs
@@ -1,66 +1,46 @@
-{-# LANGUAGE TypeFamilies               #-}
 {-# OPTIONS -Wall #-}
 
 
 
 module FeatureModel where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
-import Wumpus.Drawing.Arrows
-import Wumpus.Drawing.Paths 
+import Wumpus.Drawing.Connectors
+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C
+import Wumpus.Drawing.Paths
 import Wumpus.Drawing.Shapes
-import Wumpus.Drawing.Text.LRText
-import Wumpus.Drawing.Text.SafeFonts
-
-import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
 
-import FontLoaderUtils
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
 
+import Wumpus.Core                              -- package: wumpus-core
 
 import System.Directory
 
 
 main :: IO ()
-main = do 
-    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help
-    createDirectoryIfMissing True "./out/"
-    putStrLn "Note - text centering does not seem to be working well at present..."
-    maybe gs_failk  makeGSPicture  $ mb_gs
-    maybe afm_failk makeAfmPicture $ mb_afm
-  where
-    gs_failk  = putStrLn "No GhostScript font path supplied..."
-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."
+main = simpleFontLoader main1 >> return ()
 
-makeGSPicture :: FilePath -> IO ()
-makeGSPicture font_dir = do 
-    putStrLn "Using GhostScript metrics..."
-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Courier-Bold"]
-    mapM_ putStrLn msgs
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/" 
+    base_metrics <- loader [ Left courier_bold ]
+    printLoadErrors base_metrics
     let pic1 = runCtxPictureU (makeCtx base_metrics) feature_model 
     writeEPS "./out/feature_model01.eps" pic1
     writeSVG "./out/feature_model01.svg" pic1 
 
-makeAfmPicture :: FilePath -> IO ()
-makeAfmPicture font_dir = do 
-    putStrLn "Using AFM 4.1 metrics..."
-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Courier-Bold"]
-    mapM_ putStrLn msgs
-    let pic1 = runCtxPictureU (makeCtx base_metrics) feature_model 
-    writeEPS "./out/feature_model02.eps" pic1
-    writeSVG "./out/feature_model02.svg" pic1 
-
-makeCtx :: GlyphMetrics -> DrawingContext
-makeCtx = fontFace courier_bold . metricsContext 18
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font courier_bold . metricsContext 18
 
 
 -- Note - I haven't worked out how to do @alternative@, @or@ and
 -- @repetitions@ yet.
 --
          
-feature_model :: CtxPicture Double 
-feature_model = drawTracing $ do
+feature_model :: CtxPicture
+feature_model = udrawTracing (0::Double) $ do
     lea <- widebox "e" $ P2 150 160    
     lra <- widebox "r" $ P2  60  80
     lsa <- widebox "s" $ P2 240  80
@@ -91,46 +71,51 @@
 
 -- Note - ctrCenterLine does not seem to be working well...
 
-makeBox :: (Real u, Floating u, FromPtSize u) 
+makeBox :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
         => u -> String -> Point2 u -> TraceDrawing u (Box u)
 makeBox w ss pt = do 
     a <- drawi $ (strokedShape $ rectangle w 20) `at` pt
-    drawi_ $ ctrCenterLine ss `at` center a
-    -- draw  $ filledDisk 2 `at` center a
+    drawl (center a) $ textline CENTER ss
     return a
 
-box :: (Real u, Floating u, FromPtSize u) 
+box :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
     => String -> Point2 u -> TraceDrawing u (Box u)
 box = makeBox 40
 
-widebox :: (Real u, Floating u, FromPtSize u) 
+widebox :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
         => String -> Point2 u -> TraceDrawing u (Box u)
 widebox = makeBox 60
 
 
-connWith :: ( Real u, Floating u, FromPtSize u ) 
-         => Arrowhead u -> Box u -> Box u -> TraceDrawing u (Path u)
+connWith :: ( Real u, Floating u, InterpretUnit u, Tolerance u) 
+         => ArrowTip -> Box u -> Box u -> TraceDrawing u (AbsPath u)
 connWith arrh b0 b1 = do
    lw <- getLineWidth
    let p0 = south b0
-   let p1 = northwards (realToFrac lw) b1
-   drawi $ apply2R2 (rightArrow arrh connLine) p0 p1
+   let p1 = projectAnchor north (realToFrac lw) b1
+   drawi $ connect (mkConn_line arrh) p0 p1
 
 infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_`
 
-cmandatory :: ( Real u, Floating u, FromPtSize u ) 
-           => Box u -> Box u -> TraceDrawing u (Path u)
+cmandatory :: ( Real u, Floating u, InterpretUnit u, Tolerance u) 
+           => Box u -> Box u -> TraceDrawing u (AbsPath u)
 cmandatory = connWith diskTip
 
-coptional :: ( Real u, Floating u, FromPtSize u ) 
-          => Box u -> Box u -> TraceDrawing u (Path u)
+coptional :: ( Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => Box u -> Box u -> TraceDrawing u (AbsPath u)
 coptional = connWith odiskTip
 
 
-cmandatory_ :: ( Real u, Floating u, FromPtSize u ) 
+cmandatory_ :: ( Real u, Floating u, InterpretUnit u, Tolerance u) 
             => Box u -> Box u -> TraceDrawing u ()
 cmandatory_ p0 p1 = connWith diskTip p0 p1 >> return ()
 
-coptional_ :: ( Real u, Floating u, FromPtSize u ) 
+coptional_ :: ( Real u, Floating u, InterpretUnit u, Tolerance u) 
            => Box u -> Box u -> TraceDrawing u ()
 coptional_ p0 p1 = connWith odiskTip p0 p1 >> return ()
+
+
+
+mkConn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+            => ArrowTip -> ArrowConnector u
+mkConn_line = rightArrowConnector default_connector_props C.conn_line 
diff --git a/demo/FontLoaderUtils.hs b/demo/FontLoaderUtils.hs
deleted file mode 100644
--- a/demo/FontLoaderUtils.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-# OPTIONS -Wall #-}
-
-
-module FontLoaderUtils
-  (
-    processCmdLine
-  , default_font_loader_help
-  ) where
-
-
-import Control.Applicative
-import Control.Monad
-import System.Directory
-import System.Console.GetOpt
-import System.Environment
-import System.IO.Error
-
-
-wumpus_gs_font_dir :: String
-wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR"
-
-wumpus_afm_font_dir :: String
-wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR"
-
-
-default_font_loader_help :: String
-default_font_loader_help = unlines $ 
-    [ "This example uses glyph metrics loaded at runtime."
-    , "It can use either the metrics files supplied with GhostScript,"
-    , "or the AFM v4.1 metrics for the Core 14 fonts available from"
-    , "Adobe's website."
-    , "" 
-    , "To use GhostScripts font metrics set the environemt variable"
-    , wumpus_gs_font_dir ++ " to point to the GhostScript fonts"
-    , "directory (e.g. /usr/share/ghostscript/fonts) or use the command"
-    , "line flag --gs=PATH_TO_GHOSTSCRIPT_FONTS"
-    , ""
-    , "To use the Adode Core 14 font metrics download the archive from"
-    , "the Adobe website and set the environment variable "
-    , wumpus_afm_font_dir ++ " to point to it, or use the command line"
-    , "flag -- afm=PATH_TO_AFM_CORE14_FONTS"
-    ]
-
-
-data CmdLineFlag = Help
-                 | GS_FontDir  String
-                 | AFM_FontDir String
-  deriving (Eq,Ord,Show)
-
-processCmdLine :: String -> IO (Maybe FilePath, Maybe FilePath)
-processCmdLine help_message = 
-    let options = makeCmdLineOptions help_message in do
-        args <- getArgs
-        let (opts, _, _) = getOpt Permute options args
-        if Help `elem` opts then failk help_message
-                            else succk opts
-  where
-    failk msg   = putStr msg >> return (Nothing,Nothing) 
-    succk flags = (,) <$> gsFontDirectory flags <*> afmFontDirectory flags 
-       
-
-makeCmdLineOptions :: String -> [OptDescr CmdLineFlag]
-makeCmdLineOptions help_message =
-    [ Option ['h'] ["help"]   (NoArg Help)                help_message
-    , Option []    ["afm"]    (ReqArg AFM_FontDir "DIR")  "AFM v4.1 metrics dir"
-    , Option []    ["gs"]     (ReqArg GS_FontDir  "DIR")  "GhoshScript font dir"
-    ]
-
-
-gsFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath)
-gsFontDirectory = step 
-  where
-    step (GS_FontDir p:xs)  = doesDirectoryExist p >>= \check -> 
-                              if check then return (Just p) else step xs
-
-    step (_:xs)             = step xs
-    step []                 = envLookup wumpus_gs_font_dir
- 
-
-afmFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath)
-afmFontDirectory = step 
-  where
-    step (AFM_FontDir p:xs) = doesDirectoryExist p >>= \check -> 
-                              if check then return (Just p) else step xs
-
-    step (_:xs)             = step xs
-    step []                 = envLookup wumpus_afm_font_dir
-
-
-envLookup :: String -> IO (Maybe String)
-envLookup name = liftM fn $ try $ getEnv name
-  where
-    fn (Left _)  = Nothing
-    fn (Right a) = Just a
-
diff --git a/demo/FontPic.hs b/demo/FontPic.hs
--- a/demo/FontPic.hs
+++ b/demo/FontPic.hs
@@ -2,12 +2,12 @@
 
 module FontPic where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours ( steel_blue )
 import Wumpus.Drawing.Colour.X11Colours ( indian_red1 )
-import Wumpus.Drawing.Text.SafeFonts
+import Wumpus.Drawing.Text.StandardFontDefs
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
 
 
@@ -34,16 +34,17 @@
     writeSVG "./out/font_symbol.svg"    symbol_pic
 
 
-fontMsg :: FontFace -> Int -> String
-fontMsg ff sz = msgF []
+fontMsg :: FontDef -> Int -> String
+fontMsg ft sz = msgF []
   where
-    msgF = showString (ps_font_name ff) . showChar ' ' . shows sz . showString "pt"
+    msgF = showString name . showChar ' ' . shows sz . showString "pt"
+    name = ps_font_name $ font_def_face ft 
 
 
-makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic
-makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz)
+makeLabel :: RGBi -> FontDef -> Int -> DLocGraphic
+makeLabel rgb ft sz = localize upd (dcTextlabel $ fontMsg ft sz)
   where
-    upd = fillColour rgb . fontAttr ff sz 
+    upd = text_colour rgb . font_attr ft sz 
 
 -- indian_red1
 -- steel_blue
@@ -54,32 +55,42 @@
 positions :: [Int]
 positions = [0, 12, 27, 49, 78, 122] 
 
+-- Note - this chain has grown a bit crufty as the implementation 
+-- of chains has changed...
+--
+pointChain :: (Int -> DLocGraphic) -> DLocGraphic
+pointChain fn = runChain_ chn_alg $ mapM (chain1 . fn) point_sizes
+  where
+    chn_alg = ChainScheme start step
+    start   = \pt -> (pt,point_sizes)
 
-pointChain :: LocChain Double
-pointChain = verticals $ map (fromIntegral . (+2)) point_sizes
+    step _ (pt,[])     = let pnext = displace (vvec 50) pt in (pnext, (pnext, []))
+    step _ (pt,(y:ys)) = let pnext = displace (vvec $ fromIntegral $ 2 + y) pt
+                         in (pnext, (pnext, ys))
 
-fontGraphic :: RGBi -> FontFace -> DPoint2 -> TraceDrawing Double ()
-fontGraphic rgb ff pt = 
-    let ps = pointChain pt in 
-      zipchainWith (\sz -> makeLabel rgb ff sz) point_sizes ps
+fontGraphic :: RGBi -> FontDef -> DLocGraphic 
+fontGraphic rgb ft = ignoreAns $ pointChain mkGF
+  where
+    mkGF sz = makeLabel rgb ft sz
 
 
 std_ctx :: DrawingContext
 std_ctx = standardContext 10
 
 
-fontDrawing :: [(RGBi,FontFace)] -> DCtxPicture
+fontDrawing :: [(RGBi,FontDef)] -> CtxPicture
 fontDrawing xs = drawTracing $  
-    zipchainWithTD (\(rgb,ff) -> fontGraphic rgb ff) xs ps
+    drawl start $ runChain_ chn_alg $ mapM (chain1 . uncurry fontGraphic) xs
   where
-    ps = tableDown 4 (1,180) (P2 0 (4*180))
+    chn_alg   = columnwiseTableScheme 4 (2,180)
+    start     = P2 0 (4*180)
 
 
 
 --------------------------------------------------------------------------------
 -- Times
 
-times_cxpic :: CtxPicture Double
+times_cxpic :: CtxPicture
 times_cxpic = 
     fontDrawing [ (steel_blue,  times_roman)
                 , (indian_red1, times_italic)
@@ -87,7 +98,7 @@
                 , (indian_red1, times_bold_italic)
                 ] 
 
-helvetica_cxpic :: CtxPicture Double
+helvetica_cxpic :: CtxPicture
 helvetica_cxpic = 
     fontDrawing [ (steel_blue,  helvetica)
                 , (indian_red1, helvetica_oblique)
@@ -99,7 +110,7 @@
 
 --------------------------------------------------------------------------------
 
-courier_cxpic :: CtxPicture Double
+courier_cxpic :: CtxPicture
 courier_cxpic = 
     fontDrawing [ (steel_blue,  courier)
                 , (indian_red1, courier_oblique)
@@ -111,6 +122,6 @@
 --------------------------------------------------------------------------------
 
     
-symbol_cxpic :: CtxPicture Double
+symbol_cxpic :: CtxPicture
 symbol_cxpic = 
     fontDrawing [ (steel_blue, symbol) ]
diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs
--- a/demo/LeftRightText.hs
+++ b/demo/LeftRightText.hs
@@ -1,192 +1,138 @@
 {-# OPTIONS -Wall #-}
 
--- Note - @main@ is more convoluted than would normally be 
--- expected as it supports both sources of glyph metrics - the 
--- GhostScript distribution or the Core 14 metrics from Adobe.
--- 
--- \"Real\" applications would be expected to choose one source. 
---
--- I-am-not-a-lawyer, but it does look as though the Adobe font
--- metrics are redistributable, the GhostScript metrics are 
--- seemingly redistributable under the same terms as the larger
--- GhostScript distribution.
--- 
 
 
 module LeftRightText where
 
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
 import Wumpus.Drawing.Colour.SVGColours
-import Wumpus.Drawing.Dots.Marks
-import Wumpus.Drawing.Text.LRText
-import Wumpus.Drawing.Text.SafeFonts
-
-import FontLoaderUtils
+import Wumpus.Drawing.Dots.SimpleDots
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
 
-import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Core                              -- package: wumpus-core
 
 import System.Directory
 
 
-
 main :: IO ()
-main = do 
-    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help
-    createDirectoryIfMissing True "./out/"
-    maybe gs_failk  makeGSPicture  $ mb_gs
-    maybe afm_failk makeAfmPicture $ mb_afm
-  where
-    gs_failk  = putStrLn "No GhostScript font path supplied..."
-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."
+main = simpleFontLoader main1 >> return ()
 
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/" 
+    base_metrics <- loader [ Left helvetica ]
+    printLoadErrors base_metrics
+    let pic1 = runCtxPictureU (makeCtx base_metrics) text_pic
+    writeEPS "./out/left_right_text.eps" pic1
+    writeSVG "./out/left_right_text.svg" pic1
 
-makeGSPicture :: FilePath -> IO ()
-makeGSPicture font_dir = do
-    putStrLn "Using GhostScript metrics..."
-    (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"]
-    mapM_ putStrLn msgs
-    let pic1 = runCtxPictureU (makeCtx gs_metrics) text_pic
-    writeEPS "./out/lr_text01.eps" pic1
-    writeSVG "./out/lr_text01.svg" pic1
 
-makeAfmPicture :: FilePath -> IO ()
-makeAfmPicture font_dir = do
-    putStrLn "Using AFM 4.1 metrics..."
-    (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"]
-    mapM_ putStrLn msgs
-    let pic2 = runCtxPictureU (makeCtx afm_metrics) text_pic
-    writeEPS "./out/lr_text02.eps" pic2
-    writeSVG "./out/lr_text02.svg" pic2
 
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font helvetica . metricsContext 15
 
 
+text_pic :: CtxPicture
+text_pic = udrawTracing (0::Double) $ localize text_margin_loose $ do 
+    draw $ (fn left_text)       `at` P2   0 400
+    draw $ (fn center_text)     `at` P2 150 400
+    draw $ (fn right_text)      `at` P2 300 400
+    draw $ (fn blank_text)      `at` P2   0 300
+    draw $ (fn ne_oneline)      `at` P2 150 300 
+    draw $ (fn cc_oneline)      `at` P2 300 300
 
-makeCtx :: GlyphMetrics -> DrawingContext
-makeCtx = fontFace helvetica . metricsContext 18
 
+    draw $ (fn sw_oneline)      `at` P2   0 200
+    draw $ (fn ss_oneline)      `at` P2 150 200
+    draw $ (fn se_oneline)      `at` P2 300 200
+    draw $ (fn swr_single)      `at` P2   0 100
+    draw $ (fn ssr_single)      `at` P2 150 100
+    draw $ (fn ner_single)      `at` P2 300 100
 
-text_pic :: CtxPicture Double
-text_pic = drawTracing $ do 
-    drawi_ $ (fn left_text)       `at` P2   0 400
-    drawi_ $ (fn center_text)     `at` P2 200 400
-    drawi_ $ (fn right_text)      `at` P2 400 400
-    drawi_ $ (fn blank_text)      `at` P2   0 300
-    drawi_ $ (fn bl_oneline)      `at` P2 200 300
-    drawi_ $ (fn cc_oneline)      `at` P2 400 300
-    drawi_ $ (fn newblr)          `at` P2   0 200
-    drawi_ $ (fn newblc)          `at` P2 200 200
-    drawi_ $ (fn newbll)          `at` P2 400 200
-    drawi_ $ (fn rnewblr)         `at` P2   0 100
-    drawi_ $ (fn rnewblc)         `at` P2 200 100
-    drawi_ $ (fn rnewbll)         `at` P2 400 100
-    drawi_ $ (fn rleft_text)      `at` P2   0 (-75)
-    drawi_ $ (fn rcenter_text)    `at` P2 200 (-75)
-    drawi_ $ (fn rright_text)     `at` P2 400 (-75)
-      
- 
     draw $ redPlus            `at` P2   0 400
-    draw $ redPlus            `at` P2 200 400
-    draw $ redPlus            `at` P2 400 400
+    draw $ redPlus            `at` P2 150 400
+    draw $ redPlus            `at` P2 300 400
     draw $ redPlus            `at` P2   0 300  
-    draw $ redPlus            `at` P2 200 300 
-    draw $ redPlus            `at` P2 400 300 
+    draw $ redPlus            `at` P2 150 300 
+    draw $ redPlus            `at` P2 300 300 
     draw $ redPlus            `at` P2   0 200  
-    draw $ redPlus            `at` P2 200 200 
-    draw $ redPlus            `at` P2 400 200  
+    draw $ redPlus            `at` P2 150 200 
+    draw $ redPlus            `at` P2 300 200  
     draw $ redPlus            `at` P2   0 100  
-    draw $ redPlus            `at` P2 200 100 
-    draw $ redPlus            `at` P2 400 100 
+    draw $ redPlus            `at` P2 150 100 
+    draw $ redPlus            `at` P2 300 100 
     draw $ redPlus            `at` P2   0 (-75)
-    draw $ redPlus            `at` P2 200 (-75)
-    draw $ redPlus            `at` P2 400 (-75)
+    draw $ redPlus            `at` P2 150 (-75)
+    draw $ redPlus            `at` P2 300 (-75)
       
   where
     fn = illustrateBoundedLocGraphic
    
-redPlus :: (Fractional u, FromPtSize u) => LocGraphic u
-redPlus = localize (strokeColour red) markPlus
+redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u
+redPlus = localize (stroke_colour red) dotPlus
 
 
-newblc :: BoundedLocGraphic Double
-newblc = 
-    localize (strokeColour dark_slate_gray) $ 
-        baseCenterLine "new baseline center"
 
-newbll :: BoundedLocGraphic Double
-newbll = 
-    localize (strokeColour dark_slate_gray) $ 
-        baseLeftLine "new baseline left"
+-- single line
+--
+ne_oneline :: BoundedLocGraphic Double
+ne_oneline = textline NE "north east"
 
-newblr :: BoundedLocGraphic Double
-newblr = 
-    localize (strokeColour dark_slate_gray) $ 
-        baseRightLine "new baseline right"
 
+-- single line
+--
+se_oneline :: BoundedLocGraphic Double
+se_oneline = textline SE "south east"
 
-rnewblc :: BoundedLocGraphic Double
-rnewblc = 
-    localize (strokeColour dark_slate_gray) $ 
-        rbaseCenterLine "baseline center" `rot` (0.25*pi)
+-- single line
+--
+ss_oneline :: BoundedLocGraphic Double
+ss_oneline = textline SS "south"
 
-rnewbll :: BoundedLocGraphic Double
-rnewbll = 
-    localize (strokeColour dark_slate_gray) $ 
-        rbaseLeftLine "baseline left" `rot` (0.25*pi)
+-- single line
+--
+sw_oneline :: BoundedLocGraphic Double
+sw_oneline = textline SW "south west"
 
-rnewblr :: BoundedLocGraphic Double
-rnewblr = 
-    localize (strokeColour dark_slate_gray) $ 
-        rbaseRightLine "baseline right" `rot` (0.25 * pi)
 
 
-bl_oneline :: BoundedLocGraphic Double
-bl_oneline = 
-    localize (strokeColour dark_slate_gray) $ baseLeftLine "Baseline-left..."
+-- single line rot
+--
+ssr_single :: BoundedLocGraphic Double
+ssr_single = rtextline (0.25*pi) SS "south rot45"
 
+-- single line rot
+--
+swr_single :: BoundedLocGraphic Double
+swr_single = rtextline (0.25*pi) SW "south west rot45"
 
+-- single line rot
+--
+ner_single :: BoundedLocGraphic Double
+ner_single = rtextline (0.25*pi) NE "north east rot45"
+
+
 cc_oneline :: BoundedLocGraphic Double
-cc_oneline = 
-    localize (strokeColour dark_slate_gray) $ ctrCenterLine "Center-center..."
+cc_oneline = textline CENTER "Center-center..."
 
+
 blank_text :: BoundedLocGraphic Double
-blank_text = 
-    localize (strokeColour dark_slate_gray) $ multiAlignCenter ""
+blank_text = textline BLC ""
 
 
 left_text :: BoundedLocGraphic Double
-left_text = 
-    localize (strokeColour dark_slate_gray) $ multiAlignLeft dummy_text
+left_text = multilineText VALIGN_LEFT CENTER dummy_text
 
 
 right_text :: BoundedLocGraphic Double
-right_text = 
-    localize (strokeColour dark_slate_gray) $ multiAlignRight dummy_text
+right_text = multilineText VALIGN_RIGHT CENTER dummy_text
 
 center_text :: BoundedLocGraphic Double
-center_text = 
-    localize (strokeColour dark_slate_gray) $ multiAlignCenter dummy_text
-
-
-rleft_text :: BoundedLocGraphic Double
-rleft_text = 
-    localize (strokeColour dark_slate_gray) $ 
-        rmultiAlignLeft dummy_text `rot`   (0.25*pi)
-
-
-rright_text :: BoundedLocGraphic Double
-rright_text = 
-    localize (strokeColour dark_slate_gray) $ 
-        rmultiAlignRight dummy_text `rot`  (0.25*pi)
-
-rcenter_text :: BoundedLocGraphic Double
-rcenter_text = 
-    localize (strokeColour dark_slate_gray) $ 
-        rmultiAlignCenter dummy_text `rot` (0.25*pi)
-
+center_text = multilineText VALIGN_CENTER CENTER dummy_text
 
 dummy_text :: String 
 dummy_text = unlines $ [ "The quick brown"
diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs
--- a/demo/PetriNet.hs
+++ b/demo/PetriNet.hs
@@ -7,17 +7,15 @@
 
 module PetriNet where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
-import Wumpus.Drawing.Arrows
 import Wumpus.Drawing.Colour.SVGColours
-import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Connectors
+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C
 import Wumpus.Drawing.Shapes
-import Wumpus.Drawing.Text.SafeFonts
-import Wumpus.Drawing.Text.LRText
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
 
-import FontLoaderUtils
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -25,134 +23,149 @@
 import System.Directory
 
 
-
-
 main :: IO ()
-main = do 
-    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help
-    createDirectoryIfMissing True "./out/"
-    maybe gs_failk  makeGSPicture  $ mb_gs
-    maybe afm_failk makeAfmPicture $ mb_afm
-  where
-    gs_failk  = putStrLn "No GhostScript font path supplied..."
-    afm_failk = putStrLn "No AFM v4.1 font path supplied..."
+main = simpleFontLoader main1 >> return ()
 
-makeGSPicture :: FilePath -> IO ()
-makeGSPicture font_dir = do 
-    putStrLn "Using GhostScript metrics..."
-    (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica", "Helvetica-Bold"]
-    mapM_ putStrLn msgs
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/" 
+    base_metrics <- loader [ Right helvetica_family ]
+    printLoadErrors base_metrics
     let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net
-    writeEPS "./out/petri_net01.eps" pic1
-    writeSVG "./out/petri_net01.svg" pic1 
+    writeEPS "./out/petri_net.eps" pic1
+    writeSVG "./out/petri_net.svg" pic1 
 
-makeAfmPicture :: FilePath -> IO ()
-makeAfmPicture font_dir = do 
-    putStrLn "Using AFM 4.1 metrics..."
-    (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica", "Helvetica-Bold"]
-    mapM_ putStrLn msgs
-    let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net
-    writeEPS "./out/petri_net02.eps" pic1
-    writeSVG "./out/petri_net02.svg" pic1 
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font helvetica . metricsContext 14
 
 
-makeCtx :: GlyphMetrics -> DrawingContext
-makeCtx = fontFace helvetica . metricsContext 14
-
+petri_net :: CtxPicture
+petri_net = udrawTracing (0::Double) $ do
+    pw     <- drawi $ place         `at` (P2 0 140)
+    tu1    <- drawi $ transition    `at` (P2 70 140)  
+    rtw    <- drawi $ place         `at` (P2 140 140)
+    tu2    <- drawi $ transition    `at` (P2 210 140)
+    w      <- drawi $ place         `at` (P2 280 140)
+    tu3    <- drawi $ transition    `at` (P2 350 140)
+    res    <- drawi $ place         `at` (P2 280 70)
+    pr     <- drawi $ place         `at` (P2 0 0)
+    tl1    <- drawi $ transition    `at` (P2 70 0)
+    rtr    <- drawi $ place         `at` (P2 140 0)
+    tl2    <- drawi $ transition    `at` (P2 210 0)
+    r      <- drawi $ place         `at` (P2 280 0)
+    tl3    <- drawi $ transition    `at` (P2 350 0)
 
-petri_net :: DCtxPicture
-petri_net = drawTracing $ do
-    pw     <- place 0 140
-    tu1    <- transition 70 140
-    rtw    <- place 140 140
-    tu2    <- transition 210 140
-    w      <- place 280 140
-    tu3    <- transition 350 140
-    res    <- place 280 70
-    pr     <- place 0 0
-    tl1    <- transition 70 0
-    rtr    <- place 140 0
-    tl2    <- transition 210 0
-    r      <- place 280 0
-    tl3    <- transition 350 0
-    connector' (east pw)  (west tu1)              
-    connector' (east tu1) (west rtw)
-    connector' (east rtw) (west tu2)
-    connector' (east tu2) (west w)
-    connector' (east w)   (west tu3)
-    connectorC 32 (north tu3) (north pw)
-    connector' (east pr)  (west tl1)              
-    connector' (east tl1) (west rtr)
-    connector' (east rtr) (west tl2)
-    connector' (east tl2) (west r)
-    connector' (east r)   (west tl3)
-    connectorC (-32) (south tl3) (south pr)
-    connector' (southwest res) (northeast tl2)
-    connector' (northwest tl3) (southeast res)
-    connectorD 6    (southwest tu3) (northeast res)
-    connectorD (-6) (southwest tu3) (northeast res) 
-    connectorD 6    (northwest res) (southeast tu2)
-    connectorD (-6) (northwest res) (southeast tu2) 
+    drawc (east pw)  (west tu1)   $ straightconn
+    drawc (east tu1) (west rtw)   $ straightconn
+    drawc (east rtw) (west tu2)   $ straightconn
+    drawc (east tu2) (west w)     $ straightconn
+    drawc (east w)   (west tu3)   $ straightconn
+    drawc (north tu3) (north pw)  $ connectorC 
+    drawc (east pr)  (west tl1)   $ straightconn
+    drawc (east tl1) (west rtr)   $ straightconn
+    drawc (east rtr) (west tl2)   $ straightconn
+    drawc (east tl2) (west r)     $ straightconn
+    drawc (east r)   (west tl3)   $ straightconn
+    drawc (south tl3) (south pr)  $ connectorC'
+    drawc (southwest res) (northeast tl2) $ straightconn
+    drawc (northwest tl3) (southeast res) $ straightconn
+    drawc (southwest tu3) (northeast res) $ connectorD
+    drawc (southwest tu3) (northeast res) $ connectorD'
+    drawc (northwest res) (southeast tu2) $ connectorD
+    drawc (northwest res) (southeast tu2) $ connectorD'
     draw $ lblParensParens `at` (P2 (-36) 150)
     draw $ lblParensParens `at` (P2 300 60)
     draw $ lblParensParensParens `at` (P2 (-52) (-14))
-    draw $ lblBold "processing_w"   `at` (southwards 12 pw)
-    draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)
-    draw $ lblBold "writing"        `at` (southwards 12 w)
-    draw $ lblBold' "resource"      `at` (P2 300 72)
-    draw $ lblBold "processing_r"   `at` (northwards 12 pr)
-    draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)
-    draw $ lblBold "reading"        `at` (northwards 12 r)
+    drawl (projectAnchor south 12 pw)     $ lblBold "processing_w"
+    drawl (projectAnchor south 12 rtw)    $ lblBold "ready_to_write"
+    drawl (projectAnchor south 12 w)      $ lblBold "writing"
+    draw $ lblBold "resource"      `at` (P2 300 72)
+    drawl (projectAnchor north 12 pr)     $ lblBold "processing_r"
+    drawl (projectAnchor north 12 rtr)    $ lblBold "ready_to_read"
+    drawl (projectAnchor north 12 r)      $ lblBold "reading"
+
     return ()
 
-greenFill :: DrawingCtxM m => m a -> m a
-greenFill = localize (fillColour lime_green)
+greenFill :: LocImage u a -> LocImage u a
+greenFill = localize (fill_colour lime_green)
 
-place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) 
-      => u -> u -> m (Circle u)
-place x y = greenFill $ drawi $ (borderedShape $ circle 14) `at` P2 x y
 
-transition :: ( Real u, Floating u, FromPtSize u
-              , DrawingCtxM m, TraceM m, u ~ MonUnit m ) 
-           => u -> u -> m (Rectangle u)
-transition x y = 
-    greenFill $ drawi $ (borderedShape $ rectangle 32 22) `at` P2 x y
+place :: DLocImage (Circle Double)
+place = greenFill $ borderedShape $ circle 14
 
 
+transition :: DLocImage (Rectangle Double)
+transition = greenFill $ borderedShape $ rectangle 32 22
 
 
-connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m
-         , Real u, Floating u, FromPtSize u ) 
-      => Point2 u -> Point2 u -> m ()
-connector' p0 p1 = 
-    drawi_ $ apply2R2 (rightArrow tri45 connLine) p0 p1
 
+makeSglArrConn :: ConnectorPathSpec u -> ConnectorConfig u
+makeSglArrConn cspec = 
+    ConnectorConfig
+      { conn_arrowl     = Nothing
+      , conn_arrowr     = Just tri45
+      , conn_path_spec  = cspec
+      }
 
-connectorC :: ( Real u, Floating u, FromPtSize u
-             , DrawingCtxM m, TraceM m, u ~ MonUnit m )
-           => u -> Point2 u -> Point2 u -> m ()
-connectorC v p0 p1 = 
-    drawi_ $ apply2R2 (rightArrow tri45 (connRightVHV v)) p0 p1
+straightconn :: ConnectorGraphic Double
+straightconn = ignoreAns conn_line
 
-connectorD :: ( Real u, Floating u, FromPtSize u
-             , DrawingCtxM m, TraceM m, u ~ MonUnit m )
-           => u -> Point2 u -> Point2 u -> m ()
-connectorD u p0 p1 = 
-    drawi_ $ apply2R2 (rightArrow tri45 (connIsosceles u)) p0 p1
 
+connectorC :: ConnectorGraphic Double
+connectorC = ignoreAns conna_bar
 
-lblParensParens :: Num u => LocGraphic u
-lblParensParens = localize (fontFace helvetica) $ textline "(),()"
+connectorC' :: ConnectorGraphic Double
+connectorC' = ignoreAns connb_bar
 
-lblParensParensParens :: Num u => LocGraphic u
-lblParensParensParens = localize (fontFace helvetica) $ textline "(),(),()"
+connectorD :: ConnectorGraphic Double
+connectorD = ignoreAns conna_arc
 
+connectorD' :: ConnectorGraphic Double
+connectorD' = ignoreAns connb_arc
 
-lblBold' :: Num u => String -> LocGraphic u
-lblBold' ss = localize (fontFace helvetica_bold) $ textline ss
 
+lblParensParens :: DLocGraphic
+lblParensParens = 
+    ignoreAns $ localize (set_font helvetica) $ textline CENTER "(),()"
 
-lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u
-lblBold ss = localize (fontFace helvetica_bold) $ post $ ctrCenterLine ss
-  where
-    post = fmap (replaceL uNil)
+lblParensParensParens :: DLocGraphic
+lblParensParensParens = 
+    ignoreAns $ localize (set_font helvetica) $ textline CENTER "(),(),()"
+
+
+
+lblBold :: String -> DLocGraphic
+lblBold ss = 
+    ignoreAns $ localize (set_font helvetica_bold) $ textline CENTER ss
+
+
+
+-- Cf. Parsec\'s Token module...
+
+conn_props :: ConnectorProps
+conn_props = (default_connector_props { conn_src_arm = 2
+                                      , conn_dst_arm = 2 
+                                      , conn_arc_ang =  negate $ pi / 12 })
+
+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ArrowConnector u
+conn_line = renderConnectorConfig conn_props $ makeSglArrConn C.conn_line
+
+
+conna_bar :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ArrowConnector u
+conna_bar = renderConnectorConfig conn_props $ makeSglArrConn C.conna_bar
+
+
+connb_bar :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ArrowConnector u
+connb_bar = renderConnectorConfig conn_props $ makeSglArrConn C.connb_bar
+
+
+conna_arc :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ArrowConnector u
+conna_arc = renderConnectorConfig conn_props $ makeSglArrConn C.conna_arc
+
+connb_arc :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ArrowConnector u
+connb_arc = renderConnectorConfig conn_props $ makeSglArrConn C.connb_arc
diff --git a/demo/PictureCompo.hs b/demo/PictureCompo.hs
deleted file mode 100644
--- a/demo/PictureCompo.hs
+++ /dev/null
@@ -1,151 +0,0 @@
-{-# OPTIONS -Wall #-}
-
-module PictureCompo where
-
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Colour.SVGColours
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import System.Directory
-
-
-main :: IO ()
-main = do 
-    createDirectoryIfMissing True "./out/"
-    let out1 = runCtxPictureU pic_drawing_ctx pictures
-    writeEPS "./out/picture_composition.eps" out1
-    writeSVG "./out/picture_composition.svg" out1
-
-
-pic_drawing_ctx :: DrawingContext
-pic_drawing_ctx = standardContext 14
-
-
-pictures :: DCtxPicture
-pictures = vsep 12 [ pic1,  pic2,  pic3,  pic4
-                   , pic5,  pic6,  pic7,  pic8
-                   , pic9,  pic10, pic11, pic12 ]
-
-
-drawBlueBounds :: (Real u, Floating u, FromPtSize u) 
-               => CtxPicture u -> CtxPicture u
-drawBlueBounds = mapCtxPicture (illustrateBounds blue)
-
-pic1 :: DCtxPicture
-pic1 = picAnno pic "red `over` green `over` blue"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ rect_red `over` rect_green `over` rect_blue
-
-pic2 :: DCtxPicture
-pic2 = picAnno pic "red `under` green `under` blue"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ rect_red `under` rect_green `under` rect_blue
-
-
-pic3 :: DCtxPicture 
-pic3 = picAnno pic "red `centric` green `centric` blue"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            rect_red `centric` rect_green `centric` rect_blue
-
--- Note - nextToH only moves pictures in the horizontal.
---
-pic4 :: DCtxPicture 
-pic4 = picAnno pic "red `nextToH` green `nextToH` blue"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            rect_red `nextToH` rect_green `nextToH` rect_blue
-
--- Note - nextToV only moves pictures in the vertical.
---
-pic5 :: DCtxPicture 
-pic5 = picAnno pic "red `nextToV` green `nextToV` blue"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            rect_red `nextToV` rect_green `nextToV` rect_blue
-
-
-pic6 :: DCtxPicture
-pic6 = picAnno pic "zconcat [red, green, blue]"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            zconcat [rect_red, rect_green, rect_blue]
-
-
-pic7 :: DCtxPicture
-pic7 = picAnno pic "hcat [red, green, blue]"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            hcat [rect_red, rect_green, rect_blue]
-
-pic8 :: DCtxPicture
-pic8 = picAnno pic "vcat [red, green, blue]"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            vcat [rect_red, rect_green, rect_blue]
-
-pic9 :: DCtxPicture
-pic9 = picAnno pic "hsep 20 [red, green, blue]"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            hsep 20 [rect_red, rect_green, rect_blue]
-
-pic10 :: DCtxPicture
-pic10 = picAnno pic "vsep 20 [red, green, blue]"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            vsep 20 [rect_red, rect_green, rect_blue]
-
-
-pic11 :: DCtxPicture
-pic11 = picAnno pic "hcatA HTop [red, green, blue]"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            hcatA HTop [rect_red, rect_green, rect_blue]
-
-
-pic12 :: DCtxPicture
-pic12 = picAnno pic "vcatA VCenter [red, green, blue]"
-  where
-    pic :: DCtxPicture
-    pic = drawBlueBounds $ 
-            vcatA VCenter [rect_red, rect_green, rect_blue]
-
-
---------------------------------------------------------------------------------
-
-
-picAnno :: DCtxPicture -> String -> DCtxPicture
-picAnno pic msg = alignHSep HCenter 30 pic lbl
-  where
-    lbl = drawTracing $ draw $ textline msg `at` zeroPt
-
-
-rect_red :: DCtxPicture
-rect_red = drawTracing $ 
-    localize (fillColour indian_red)
-             (draw $ borderedRectangle 30 10 `at` (P2 0 10))
-                 
-rect_green :: DCtxPicture
-rect_green = drawTracing $ 
-    localize (fillColour olive_drab)
-             (draw $ borderedRectangle 15 15 `at` (P2 10 10))
-
-
-rect_blue :: DCtxPicture
-rect_blue = drawTracing $ 
-    localize (fillColour powder_blue)
-             (draw $ borderedRectangle 20 30 `at` (P2 10 0))
-
diff --git a/demo/SampleShapes.hs b/demo/SampleShapes.hs
new file mode 100644
--- /dev/null
+++ b/demo/SampleShapes.hs
@@ -0,0 +1,189 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+
+module SampleShapes where
+
+
+import Wumpus.Drawing.Colour.SVGColours
+import Wumpus.Drawing.Dots.SimpleDots
+import Wumpus.Drawing.Shapes
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Monad
+import Data.Monoid
+import System.Directory
+
+main :: IO ()
+main = simpleFontLoader main1 >> return ()
+
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/shapes/" 
+    base_metrics <- loader [ Left courier ]
+    printLoadErrors base_metrics
+    let ctx = makeCtx base_metrics
+    mapM_ (out1 ctx) shape_list
+  where
+    out1 ctx (name, shape_pic) = do 
+       let pic1 = runCtxPictureU ctx $ shape_pic name
+       writeEPS ("./out/shapes/" ++ name ++ "01.eps") pic1
+       writeSVG ("./out/shapes/" ++ name ++ "01.svg") pic1
+
+
+type ShapeList = [(String, (String -> CtxPicture))]
+
+
+shape_list :: ShapeList
+shape_list = 
+    [ ( "circle"
+      , shapePic voidExtra $ circle 150)
+    , ( "diamond"
+      ,  shapePic (apexAnchor >=> midPoints 4) $ diamond 150 100)
+    , ( "ellipse"
+      , shapePic voidExtra $ ellipse 150 100)
+    , ( "invsemicircle"
+      , shapePic (apexAnchor >=> topCorners) $ invsemicircle 150)
+    , ( "invsemiellipse"
+      , shapePic (apexAnchor >=> topCorners) $ invsemiellipse 100 150)
+    , ( "invtriangle"
+      , shapePic (apexAnchor >=> topCorners >=> midPoints 3) $ 
+          invtriangle 300 150)
+    , ( "parallelogram"
+      , shapePic (topCorners >=> bottomCorners >=> midPoints 4) $ 
+          zparallelogram 250 200)
+    , ( "rectangle"
+      , shapePic (topCorners >=> bottomCorners >=> midPoints 4) $ 
+          rectangle 300 175)
+    , ( "semicircle"
+      , shapePic (apexAnchor >=> bottomCorners) $ semicircle 150) 
+    , ( "semiellipse"
+      , shapePic (apexAnchor >=> bottomCorners) $ semiellipse 100 150) 
+    , ( "trapezium"
+      ,  shapePic (bottomCorners >=> topCorners >=> midPoints 4) $ 
+          trapezium 300 180 ang60)
+    , ( "triangle"
+      , shapePic (apexAnchor >=> bottomCorners >=> midPoints 3) $ 
+          triangle 300 150 )
+    ]
+
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font courier . metricsContext 16
+
+rotate05 :: Rotate a => Image u a -> Image u a
+rotate05 = rotate (d2r (5::Double))
+
+-- Extra elaboration...
+
+voidExtra :: a -> TraceDrawing u ()
+voidExtra _ = return ()
+
+
+
+apexAnchor :: ( Real u, Floating u, InterpretUnit u
+              , ApexAnchor a, u ~ DUnit a)
+            => a -> TraceDrawing u a
+apexAnchor a = do
+    draw $ label EAST   "(apex)"    `at` apex  a
+    return a
+
+bottomCorners :: ( Real u, Floating u, InterpretUnit u
+                 , BottomCornerAnchor a, u ~ DUnit a
+                 )
+            => a -> TraceDrawing u a
+bottomCorners a = do
+    draw $ label SOUTH_WEST   "(bottom left)"    `at` bottomLeftCorner  a
+    draw $ label SOUTH_EAST   "(bottom right)"   `at` bottomRightCorner a
+    return a
+
+topCorners :: ( Real u, Floating u, InterpretUnit u
+              , TopCornerAnchor a, u ~ DUnit a
+              )
+           => a -> TraceDrawing u a
+topCorners a = do
+    draw $ label NORTH_WEST   "(top left)"    `at` topLeftCorner  a
+    draw $ label NORTH_EAST   "(top right)"   `at` topRightCorner a
+    return a
+
+
+midPoints :: ( Real u, Floating u, InterpretUnit u
+             , SideMidpointAnchor a, u ~ DUnit a
+             )
+          => Int -> a -> TraceDrawing u a
+midPoints n a = mapM_ mf [1..n] >> return a
+  where
+    mf i = let msg = "(side midpt " ++ show i ++ ")"
+           in draw $ label EAST  msg    `at` sideMidpoint i  a
+
+
+
+
+shapePic :: ( Functor t
+            , CenterAnchor (t Double)
+            , CardinalAnchor (t Double)
+            , CardinalAnchor2 (t Double)
+            , RadialAnchor (t Double)
+            , Scale (t Double)
+            , Rotate (t Double)
+            , Double ~ DUnit (t Double)
+            ) 
+         => (t Double -> DTraceDrawing a) -> DShape t -> String -> CtxPicture
+shapePic mf sh name = udrawTracing (0::Double) $ do
+    a1  <- localize shapeSty $ drawi $ 
+              uniformScale 2 $ {- rotate05 $ -} shape `at` (P2 100 0)
+    draw $ label NORTH        "(center)"      `at` center a1
+    draw $ label NORTH        "(north)"       `at` north a1
+    draw $ label SOUTH        "(south)"       `at` south a1
+    draw $ label EAST         "(east)"        `at` east a1
+    draw $ label WEST         "(west)"        `at` west a1
+    draw $ label NORTH_EAST   "(northeast)"   `at` northeast a1
+    draw $ label NORTH_WEST   "(northwest)"   `at` northwest a1
+    draw $ label SOUTH_EAST   "(southeast)"   `at` southeast a1
+    draw $ label SOUTH_WEST   "(southwest)"   `at` southwest a1
+    draw $ label EAST         "(10 deg)"      `at` radialAnchor (d2r 10) a1
+    draw $ label NORTH_WEST   "(110 deg)"     `at` radialAnchor (d2r 110) a1
+    draw $ label WEST         "(190 deg)"     `at` radialAnchor (d2r 190) a1
+    draw $ label NORTH        "(250 deg)"     `at` radialAnchor (d2r 250) a1
+    draw $ label WEST         "(200 deg)"     `at` radialAnchor (d2r 200) a1
+
+--    draw $ label WEST         "(0 deg)"     `at` radialAnchor (d2r 0) a1
+    draw $ label NORTH         "(224.5 deg)"     `at` radialAnchor (d2r 225.5) a1
+    _ <- mf a1
+    return ()    
+  where
+    shape   = strokedShape $ setDecoration textF sh
+    textF   = promoteLocTheta $ \pt _ -> 
+                ignoreAns (multilineText VALIGN_CENTER CENTER name) `at` pt
+
+
+
+
+
+shapeSty :: DrawingContextF
+shapeSty = stroke_colour light_steel_blue . line_ultra_thick
+
+label :: (Real u, Floating u, InterpretUnit u) 
+      => Cardinal -> String -> LocGraphic u
+label cpos ss = dotX `mappend` msg
+  where
+    (rpos,fn)     = go cpos
+    msg           = ignoreAns $ moveStart (fn 10) $ 
+                       multilineText VALIGN_CENTER rpos ss 
+
+    go NORTH      = (SS, go_north)
+    go NORTH_EAST = (SW, go_north_east)
+    go EAST       = (WW, go_east) 
+    go SOUTH_EAST = (NW, go_south_east)
+    go SOUTH      = (NN, go_south)
+    go SOUTH_WEST = (NE, go_south_west)
+    go WEST       = (EE, go_west)
+    go NORTH_WEST = (SE, go_north_west)
+  
+
diff --git a/demo/SingleChar.hs b/demo/SingleChar.hs
new file mode 100644
--- /dev/null
+++ b/demo/SingleChar.hs
@@ -0,0 +1,69 @@
+{-# OPTIONS -Wall #-}
+
+
+module SingleChar where
+
+
+import Wumpus.Drawing.Colour.SVGColours
+import Wumpus.Drawing.Dots.SimpleDots
+import Wumpus.Drawing.Text.StandardFontDefs
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import System.Directory
+
+
+main :: IO ()
+main = simpleFontLoader main1 >> return ()
+
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/" 
+    base_metrics <- loader [ Left helvetica ]
+    printLoadErrors base_metrics
+    let pic1 = runCtxPictureU (makeCtx base_metrics) drawing01
+    writeEPS "./out/single_char.eps" pic1
+    writeSVG "./out/single_char.svg" pic1
+
+
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font helvetica . metricsContext 18
+
+
+
+drawing01 :: CtxPicture
+drawing01 = drawTracing $ localize (fill_colour red) $ mf 
+
+
+-- Note - Baseline positions not meaningful for multiline text
+
+mf :: TraceDrawing Double ()
+mf = localize (text_margin 6.0 6.0)  $ do
+    draw $ (fn SS $ posChar 'S') `at` zeroPt
+    draw $ redPlus `at` zeroPt
+
+    draw $ (fn NN $ posChar 'N') `at` P2 40 0
+    draw $ redPlus `at` P2 40 0
+
+    draw $ (fn EE $ posChar 'E') `at` P2 80 0
+    draw $ redPlus `at` P2 80 0
+
+    draw $ (fn WW $ posChar 'W') `at` P2 120 0
+    draw $ redPlus `at` P2 120 0
+
+    draw $ (fn CENTER $ posChar 'C') `at` P2 160 0
+    draw $ redPlus `at` P2 160 0
+
+    draw $ (fn NE $ posChar 'X') `at` P2 200 0
+    draw $ redPlus `at` P2 200 0
+
+  where
+    fn addr obj = illustrateBoundedLocGraphic $ runPosObjectBBox addr obj
+
+
+redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u
+redPlus = localize (stroke_colour red) dotPlus
+
diff --git a/demo/SingleLine.hs b/demo/SingleLine.hs
new file mode 100644
--- /dev/null
+++ b/demo/SingleLine.hs
@@ -0,0 +1,61 @@
+{-# OPTIONS -Wall #-}
+
+
+module SingleLine where
+
+import Wumpus.Drawing.Colour.SVGColours
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.Monoid
+import System.Directory
+
+
+main :: IO ()
+main = simpleFontLoader main1 >> return ()
+
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/" 
+    base_metrics <- loader [ Left helvetica ]
+    printLoadErrors base_metrics
+    let pic1 = runCtxPictureU (makeCtx base_metrics) drawing01
+    writeEPS "./out/single_line.eps" pic1
+    writeSVG "./out/single_line.svg" pic1
+
+
+
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = set_font helvetica . metricsContext 12
+
+
+
+drawing01 :: CtxPicture
+drawing01 = drawTracing $ localize (fill_colour red) $ mf 
+
+
+mf :: TraceDrawing Double ()
+mf = do
+    draw $ testDraw NN `at` (P2   0 200)
+    draw $ testDraw SS `at` (P2  75 200)
+    draw $ testDraw EE `at` (P2 150 200)
+    draw $ testDraw WW `at` (P2 225 200)
+    draw $ testDraw NE `at` (P2   0 100)
+    draw $ testDraw SE `at` (P2  75 100)
+    draw $ testDraw SW `at` (P2 150 100)
+    draw $ testDraw NW `at` (P2 225 100)
+    draw $ testDraw CENTER    `at` (P2   0 0)
+    
+
+testDraw :: RectAddress -> LocGraphic Double
+testDraw rpos = dcDisk DRAW_FILL 2 `mappend` (ignoreAns ans)
+  where
+    ans = textline rpos "Qwerty"
+
+
+
diff --git a/demo/Symbols.hs b/demo/Symbols.hs
--- a/demo/Symbols.hs
+++ b/demo/Symbols.hs
@@ -2,220 +2,89 @@
 
 module Symbols where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Chains
-import Wumpus.Drawing.Text.SafeFonts
+import Wumpus.Drawing.Basis.Symbols
+import Wumpus.Drawing.Colour.SVGColours
+import Wumpus.Drawing.Text.DirectionZero
+import Wumpus.Drawing.Text.StandardFontDefs
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Prelude hiding ( pi, product )
-
+import Data.Monoid
 import System.Directory
 
+
 main :: IO ()
-main = do 
-    createDirectoryIfMissing True "./out/"
-    let pic1 = runCtxPictureU std_ctx symbols
+main = simpleFontLoader main1 >> return ()
+
+main1 :: FontLoader -> IO ()
+main1 loader = do
+    createDirectoryIfMissing True "./out/"    
+    base_metrics <- loader [ Left times_roman ]
+    printLoadErrors base_metrics
+    let pic1 = runCtxPictureU (makeCtx base_metrics) symb_pic
     writeEPS "./out/symbols.eps" pic1
-    writeSVG "./out/symbols.svg" pic1
+    writeSVG "./out/symbols.svg" pic1 
+          
 
+makeCtx :: FontLoadResult -> DrawingContext
+makeCtx = fill_colour khaki . set_font times_roman . metricsContext 14
 
-std_ctx :: DrawingContext
-std_ctx = fontFace times_roman $ standardContext 12
+symb_pic :: CtxPicture 
+symb_pic = drawTracing $ tableGraphic symbtable
 
 
--- Because the font changes, we draw the all the symbols in one
--- run and all the labels in a second run. This helps Wumpus-Core 
--- generate better PostScript as there are less changes to the 
--- /graphics state/.
---
-symbols :: DCtxPicture
-symbols = drawTracing $ do
-    localize (fontFace symbol) $ zipchainWith sdraw all_letters ps
-    zipchainWith ldraw all_letters ps
-  where
-    ps              = tableDown 30 (100,20) (P2 0 (30*20))
-    sdraw (s,_)     = textline s
-    ldraw (_,name)  = moveStartPoint (displaceH 16) (textline name)
+symbtable :: [(String, LocGraphic Double)]
+symbtable = 
+    [ ("scircle",               scircle 8) 
+    , ("fcircle",               fcircle 8) 
+    , ("fscircle",              fscircle 8) 
+    , ("ssquare",               ssquare 8) 
+    , ("fsquare",               fsquare 8) 
+    , ("fssquare",              fssquare 8) 
+    , ("sleft_slice",           sleft_slice 14)
+    , ("fleft_slice",           fleft_slice 14)
+    , ("fsleft_slice",          fsleft_slice 14)
+    , ("sright_slice",          sright_slice 14)
+    , ("fright_slice",          fright_slice 14)
+    , ("fsright_slice",         fsright_slice 14)
+    , ("sleft_triangle",        sleft_triangle 14)
+    , ("fleft_triangle",        fleft_triangle 14)
+    , ("fsleft_triangle",       fsleft_triangle 14)
+    , ("sright_triangle",       sright_triangle 14)
+    , ("fright_triangle",       fright_triangle 14)
+    , ("fsright_triangle",      fsright_triangle 14)
+    , ("ochar",                 ochar $ CharLiteral 'a')
+    , ("ochar - bad",           ochar $ CharLiteral 'g')
+    , ("ocharDescender",        ocharDescender $ CharLiteral 'g')
+    , ("ocharUpright",          ocharUpright $ CharLiteral '8')
+    , ("ocharUpright - bad",    ocharUpright $ CharLiteral 'a')
+    , ("ocurrency",             ocurrency 8)
+    , ("hbar",                  hbar 14)
+    , ("vbar",                  vbar 14)
+    , ("dbl_hbar",              dbl_hbar 14)
+    , ("dbl_vbar",              dbl_vbar 14)
+    ]
 
 
-all_letters :: [(String, String)]
-all_letters = 
-    [ ("&Alpha;",               "Alpha") 
-    , ("&Beta;",                "Beta")
-    , ("&Chi;",                 "Chi")
-    , ("&Delta;",               "Delta")
-    , ("&Epsilon;",             "Epsilon")
-    , ("&Eta;",                 "Eta")
-    , ("&Euro;",                "Euro")
-    , ("&Gamma;",               "Gamma")
-    , ("&Ifraktur;",            "Ifraktur")
-    , ("&Iota;",                "Iota")
-    , ("&Kappa;",               "Kappa")
-    , ("&Lambda;",              "Lambda")
-    , ("&Mu;",                  "Mu")
-    , ("&Nu;",                  "Nu")
-    , ("&Omega;",               "Omega")
-    , ("&Omicron;",             "Omicron")
-    , ("&Phi;",                 "Phi")
-    , ("&Pi;",                  "Pi")
-    , ("&Psi;",                 "Psi")
-    , ("&Rfraktur;",            "Rfraktur")
-    , ("&Rho;",                 "Rho")
-    , ("&Sigma;",               "Sigma")
-    , ("&Tau;",                 "Tau")
-    , ("&Theta;",               "Theta")
-    , ("&Upsilon;",             "Upsilon")
-    , ("&Upsilon1;",            "Upsilon1")
-    , ("&Xi;",                  "Xi")
-    , ("&Zeta;",                "Zeta")
-    , ("&aleph;",               "aleph")
-    , ("&alpha;",               "alpha")
-    , ("&ampersand;",           "ampersand")
-    , ("&angle;",               "angle")
-    , ("&angleleft;",           "angleleft")
-    , ("&angleright;",          "angleright")
-    , ("&approxequal;",         "approxequal")
+tableGraphic :: [(String, LocGraphic Double)] -> TraceDrawing Double ()
+tableGraphic symbs = 
+    drawl start $ ignoreAns $ distribColumnwiseTable 14 (180,24)
+                $ map makeSymbDrawing symbs
+  where
+    start = P2 0 520 
 
-    -- 
-    , ("&arrowboth;",           "arrowboth") 
-    , ("&arrowdblboth;",        "arrowdblboth")
-    , ("&arrowdbldown;",        "arrowdbldown")
-    , ("&arrowdblleft;",        "arrowdblleft")
-    , ("&arrowdblright;",       "arrowdblright")
-    , ("&arrowdblup;",          "arrowdblup")
-    , ("&arrowdown;",           "arrowdown")
-    , ("&arrowleft;",           "arrowleft")
-    , ("&arrowright;",          "arrowright")
-    , ("&arrowup;",             "arrowup")
-    , ("&asteriskmath;",        "asteriskmath")
-    , ("&bar;",                 "bar")
-    , ("&beta;",                "beta")
-    , ("&braceleft;",           "braceleft")
-    , ("&braceright;",          "braceright")
-    , ("&bracketleft;",         "bracketleft")
-    , ("&bracketright;",        "bracketright")
-    , ("&bullet;",              "bullet")
-    , ("&carriagereturn;",      "carriagereturn")
-    , ("&chi;",                 "chi")
+ 
+std_ctx :: DrawingContext
+std_ctx = fill_colour peru $ standardContext 18
 
-    --
-    , ("&circlemultiply;",      "circlemultiply") 
-    , ("&circleplus;",          "circleplus")
-    , ("&club;",                "club")
-    , ("&colon;",               "colon")
-    , ("&comma;",               "comma")
-    , ("&congruent;",           "congruent")
-    , ("&copyrightsans;",       "copyrightsans")
-    , ("&copyrightserif;",      "copyrightserif")
-    , ("&degree;",              "degree")
-    , ("&delta;",               "delta")
-    , ("&diamond;",             "diamond")
-    , ("&divide;",              "divide")
-    , ("&dotmath;",             "dotmath")
-    , ("&eight;",               "eight")
-    , ("&element;",             "element")
-    , ("&ellipsis;",            "ellipsis")
-    , ("&emptyset;",            "emptyset")
-    , ("&epsilon;",             "epsilon")
-    , ("&equal;",               "equal")
-    , ("&equivalence;",         "equivalence")
-    , ("&eta;",                 "eta")
-    , ("&exclam;",              "exclam")
-    , ("&existential;",         "existential")
-    , ("&five;",                "five")
-    , ("&florin;",              "florin")
-    , ("&four;",                "four")
-    , ("&fraction;",            "fraction")
-    , ("&gamma;",               "gamma")
-    , ("&gradient;",            "gradient")
-    , ("&greater;",             "greater")
-    , ("&greaterequal;",        "greaterequal")
-    , ("&heart;",               "heart")
-    , ("&infinity;",            "infinity")
-    , ("&integral;",            "integral")
 
-    -- 
-    , ("&intersection;",        "intersection")
-    , ("&iota;",                "iota")
-    , ("&kappa;",               "kappa")
-    , ("&lambda;",              "lambda")
-    , ("&less;",                "less")
-    , ("&lessequal;",           "lessequal")
-    , ("&logicaland;",          "logicaland")
-    , ("&logicalnot;",          "logicalnot")
-    , ("&logicalor;",           "logicalor")
-    , ("&lozenge;",             "lozenge")
-    , ("&minus;",               "minus")
-    , ("&minute;",              "minute")
-    , ("&mu;",                  "mu")
-    , ("&multiply;",            "multiply")
-    , ("&nine;",                "nine")
-    , ("&notelement;",          "notelement")
-    , ("&notequal;",            "notequal")
-    , ("&notsubset;",           "notsubset")
-    , ("&nu;",                  "nu")
-    , ("&numbersign;",          "numbersign")
-    , ("&omega;",               "omega")
-    , ("&omega1;",              "omega1")
-    , ("&omicron;",             "omicron")
-    , ("&one;",                 "one")
-    , ("&parenleft;",           "parenleft")
-    , ("&parenright;",          "parenright")
 
-    --
-    , ("&partialdiff;",         "partialdiff")
-    , ("&percent;",             "percent")
-    , ("&period;",              "period")
-    , ("&perpendicular;",       "perpendicular")
-    , ("&phi;",                 "phi")
-    , ("&phi1;",                "phi1")
-    , ("&pi;",                  "pi")
-    , ("&plus;",                "plus")
-    , ("&plusminus;",           "plusminus")
-    , ("&product;",             "product")
-    , ("&propersubset;",        "propersubset")
-    , ("&propersuperset;",      "propersuperset")
-    , ("&proportional;",        "proportional")
-    , ("&psi;",                 "psi")
-    , ("&question;",            "question")
-    , ("&radical;",             "radical")
-    , ("&radicalex;",           "radicalex")
-    , ("&reflexsubset;",        "reflexsubset")
-    , ("&reflexsuperset;",      "reflexsuperset")
-    , ("&registersans;",        "registersans")
-    , ("&registerserif;",       "registerserif")
-    , ("&rho;",                 "rho")
-    
-    -- 
-    , ("&second;",              "second")
-    , ("&semicolon;",           "semicolon")
-    , ("&seven;",               "seven")
-    , ("&sigma;",               "sigma")
-    , ("&sigma1;",              "sigma1")
-    , ("&similar;",             "similar")
-    , ("&six;",                 "six")
-    , ("&slash;",               "slash")
-    , ("&space;",               "space")
-    , ("&spade;",               "spade")
-    , ("&suchthat;",            "suchthat")
-    , ("&summation;",           "summation")
-    , ("&tau;",                 "tau")
-    , ("&therefore;",           "therefore")
-    , ("&theta;",               "theta")
-    , ("&theta1;",              "theta1")
-    , ("&three;",               "three")
-    , ("&trademarksans;",       "trademarksans")
-    , ("&trademarkserif;",      "trademarkserif")
-    , ("&two;",                 "two")
-    , ("&underscore;",          "underscore")
-    , ("&union;",               "union")
-    , ("&universal;",           "universal")
-    , ("&upsilon;",             "upsilon")
-    , ("&weierstrass;",         "weierstrass")
-    , ("&xi;",                  "xi")
-    , ("&zero;",                "zero")
-    , ("&zeta;",                "zeta")
-    ]
+makeSymbDrawing :: (String, LocGraphic Double) -> DLocGraphic 
+makeSymbDrawing (ss,symb) = symb <> moveStart (hvec 20) lbl
+  where
+    lbl = ignoreAns $ textline WW ss
+
 
diff --git a/demo/TableChains.hs b/demo/TableChains.hs
deleted file mode 100644
--- a/demo/TableChains.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# OPTIONS -Wall #-}
-
-module TableChains where
-
-
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Chains
-import Wumpus.Drawing.Colour.SVGColours
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import System.Directory
-
-
-main :: IO ()
-main = do 
-    createDirectoryIfMissing True "./out/"
-    let pic1 = runCtxPictureU std_ctx table_drawing
-    writeEPS "./out/table_chains01.eps" pic1
-    writeSVG "./out/table_chains01.svg" pic1
-
-table_drawing :: CtxPicture Double
-table_drawing = drawTracing $ tableGraphic
-
-
-tableGraphic :: (Real u, Floating u, FromPtSize u) 
-             => TraceDrawing u ()
-tableGraphic = do 
-    draw $ filledDisk 3  `at` dstart
-    draw $ filledDisk 3  `at` rstart
-    zipchainWith (textline . show) [1..20::Int] downs
-    zipchainWith (textline . show) [1..20::Int] rights
-  where
-    downs   = tableDown  4 (36,24) dstart
-    rights  = tableRight 5 (36,24) rstart
-
-    dstart  = P2 0   480
-    rstart  = P2 240 480
-
- 
-std_ctx :: DrawingContext
-std_ctx = fillColour peru $ standardContext 18
-
-
diff --git a/src/Wumpus/Drawing/Arrows.hs b/src/Wumpus/Drawing/Arrows.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Arrows.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Arrows
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Shim module for arrow connectors and arrowheads.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Arrows
-  ( 
-
-    module Wumpus.Drawing.Arrows.Tips
-  , module Wumpus.Drawing.Arrows.Connectors
-
-  ) where
-
-import Wumpus.Drawing.Arrows.Tips
-import Wumpus.Drawing.Arrows.Connectors
-
-
diff --git a/src/Wumpus/Drawing/Arrows/Connectors.hs b/src/Wumpus/Drawing/Arrows/Connectors.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Arrows/Connectors.hs
+++ /dev/null
@@ -1,104 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Arrows.Connectors
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Draw arrows.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Arrows.Connectors
-  ( 
-
-    ArrowConnector
-  , leftArrow
-  , rightArrow
-  , leftRightArrow
-  , uniformArrow
-
-  ) where
-
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Arrows.Tips
-import Wumpus.Drawing.Paths
-
-
-
--- An arrowhead always know how to draw itself (filled triangle, 
--- stroked barb, etc.)
---
--- A Path is currently always drawn with openStroke,
--- eventually there might be scope for drawing 
--- e.g. parallel lines  ====
---
-
-
--- | A connector with arrow tips. The connector is an /Image/,
--- drawing it returns the path - positions can be taken on the 
--- path (e.g. @midpoint@) for further decoration.
---
-type ArrowConnector u = ConnectorImage u (Path u)
-
-
--- | Connector with an arrow tip at the start point \/ left.
---
-leftArrow :: (Real u, Floating u) 
-           => Arrowhead u -> ConnectorPath u -> ArrowConnector u
-leftArrow arrh conn = promoteR2 $ \p0 p1 -> 
-    connect conn p0 p1           >>= \cpath -> 
-    arrowhead_retract_dist arrh  >>= \dl -> 
-    let path1   = shortenL dl cpath
-        ang     = directionL path1
-        g1      = openStroke $ toPrimPath path1
-        g2      = atRot (arrowhead_draw arrh) p0 ang
-    in  fmap (replaceL cpath) $ g1 `oplus` g2       
-
--- Note - returns original path
-                 
-
--- | Connector with an arrow tip at the end point \/ right.
---
-rightArrow :: (Real u, Floating u) 
-           => Arrowhead u -> ConnectorPath u -> ArrowConnector u
-rightArrow arrh conn = promoteR2 $ \p0 p1 -> 
-    connect conn p0 p1           >>= \cpath -> 
-    arrowhead_retract_dist arrh  >>= \dr -> 
-    let path1   = shortenR dr cpath
-        ang     = directionR path1
-        g1      = openStroke $ toPrimPath path1
-        g2      = atRot (arrowhead_draw arrh) p1 ang
-    in  fmap (replaceL cpath) $ g1 `oplus` g2
-
-
-
--- | Connector with two arrow tips, possibly different.
---
-leftRightArrow :: (Real u, Floating u) 
-               => Arrowhead u -> Arrowhead u -> ConnectorPath u 
-               -> ArrowConnector u
-leftRightArrow arrL arrR conn = promoteR2 $ \p0 p1 -> 
-    connect conn p0 p1           >>= \cpath -> 
-    arrowhead_retract_dist arrL  >>= \dL -> 
-    arrowhead_retract_dist arrR  >>= \dR -> 
-    let path1   = shortenPath dL dR cpath
-        angL    = directionL path1
-        angR    = directionR path1
-        g1      = openStroke $ toPrimPath path1
-        gL      = atRot (arrowhead_draw arrL) p0 angL
-        gR      = atRot (arrowhead_draw arrR) p1 angR
-    in  fmap (replaceL cpath) $ g1 `oplus` gL `oplus` gR
-
-
--- | Connector with the same arrow tip at both ends.
---
-uniformArrow :: (Real u, Floating u) 
-             => Arrowhead u -> ConnectorPath u -> ArrowConnector u
-uniformArrow arrh cp = leftRightArrow arrh arrh cp
-
diff --git a/src/Wumpus/Drawing/Arrows/Tips.hs b/src/Wumpus/Drawing/Arrows/Tips.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Arrows/Tips.hs
+++ /dev/null
@@ -1,515 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Arrows.Tips
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Anchor points on shapes.
---
--- \*\* WARNING \*\* this module is an experiment, and may 
--- change significantly in future revisions.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Arrows.Tips
-  ( 
-
-
-    Arrowhead(..)
-
- 
-  , tri90
-  , tri60
-  , tri45
-  , otri90
-  , otri60
-  , otri45
-
-  , revtri90
-  , revtri60
-  , revtri45
-  , orevtri90
-  , orevtri60
-  , orevtri45
-
-  , barb90
-  , barb60
-  , barb45
-  , revbarb90
-  , revbarb60
-  , revbarb45
-
-  , perp
-
-  , bracket
-
-  , diskTip
-  , odiskTip
-  , squareTip
-  , osquareTip
-  , diamondTip
-  , odiamondTip
-
-  , curveTip
-  , revcurveTip
-
-  ) where
-
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Paths
-
-import Wumpus.Core                      -- package: wumpus-core
-
-import Data.AffineSpace                 -- package: vector-space
-
-import Control.Applicative
-
-
--- | Encode an arrowhead as a Graphic and a retract distance - 
--- lines should be shortened for certain drawings (e.g. open
--- triangles).
---
--- The retract distance is context sensitive - usually just on
--- the markHeight (or halfMarkHeight) so it has to be calculated
--- w.r.t. the DrawingCtx.
---
-data Arrowhead u = Arrowhead 
-      { arrowhead_retract_dist  :: DrawingInfo u
-      , arrowhead_draw          :: LocThetaGraphic u 
-      }
-
-
--- Design note - this used to be a newtype wrapper over a 
--- LocThetaImage that returned retract distance. But, considering 
--- the dataflow / evaluation, in some respects Arrowhead is not an 
--- ideal LocThetaImage as we want the retract distance to work out 
--- how to draw the image.
---
--- Images do not inherently encode objects that should be drawn 
--- and evaluated at the same time (and lazy eval permits this) but 
--- it seems to helpful to think that Images should be evaluated as 
--- they are drawn.
---
-
-
--- | Tiplen is length of the tip \*along the line it follows\*. 
---
--- > |\
--- > | \
--- > | /
--- > |/
--- > 
--- > |  |  -- tip len
---
-
--- | Tip width is the distance between upper and lower 
--- arrow points.
---
--- >       __
--- > |\    
--- > | \   tip
--- > | /   width
--- > |/    __
--- >       
-
-
-
--- | This one is for triangular tips defined by their tip angle
--- e.g. 90deg, 60deg, 45deg.
---
--- The tip width will be variable (tip length should be the 
--- markHeight).
--- 
-triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u)
-triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower)
-  where
-    hypo_len     = tiplen / (fromRadian $ cos halfang)
-    rtheta       = pi + theta        -- theta in the opposite direction
-    vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len
-    vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len 
-
-
-
--- | This one is for triangles when the tip height and tip width
--- are known.
---
-triVecsByDist  :: (Real u, Floating u) 
-               => u -> u -> Radian -> (Vec2 u, Vec2 u)
-triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower)
-  where
-    hypo_len     = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth)
-    halfang      = toRadian $ atan (half_tipwidth / tiplen) 
-    rtheta       = pi + theta        -- theta in the opposite direction
-    vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len
-    vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len 
-
-
-
-
-{-
-markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u
-markHeightPlusLineWidth = 
-    (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth
--}
-
-
-markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u
-markHeightLessLineWidth = 
-    (\h lw -> h - realToFrac lw) <$> markHeight <*> getLineWidth
-
-
--- noRetract ignores both the angle and the point.
---
--- Its common for the rectraction not to care about the angle or 
--- the point and only care about the DrawingCtx.
---
-noRetract :: Num u => DrawingInfo u
-noRetract = pure 0 
-
-
--- | Arrow tips are drawn with a sloid line even if the connector
--- line is dashed (tips also override round corners)
-
-solidArrTip :: DrawingCtxM m => m a -> m a
-solidArrTip mf = localize (dashPattern Solid . roundCornerFactor 0) mf
-
-
-solidOpenStroke :: Num  u => PrimPath u -> Graphic  u
-solidOpenStroke = solidArrTip . openStroke
-
-solidClosedStroke :: Num  u => PrimPath u -> Graphic  u
-solidClosedStroke = solidArrTip . closedStroke
-
-solidStrokedDisk :: Num  u => u -> LocGraphic  u
-solidStrokedDisk = solidArrTip . strokedDisk
-
---------------------------------------------------------------------------------
-
-tipBody :: FromPtSize u => (Point2 u -> Radian -> u -> CF a) -> LocThetaCF u a
-tipBody mf = promoteR2 $ \pt theta -> markHeight >>= \h -> mf pt theta h 
-
--- | Tripoints takes the \*tip length\* is the mark height.
---
--- This means that the 90deg tip has a tip width greater-than the
--- mark height (but that is okay - seemingly this is how TikZ 
--- does it).
---
-tripointsByAngle :: (Floating u, FromPtSize u)
-                 => Radian -> LocThetaCF u (Point2 u, Point2 u)
-tripointsByAngle triang = 
-    tipBody $ \pt theta h -> 
-      let (vup,vlo) = triVecsByAngle h (0.5*triang) theta
-      in  pure (pt .+^ vup, pt .+^ vlo)
-    
-
-revtripointsByAngle :: (Floating u, FromPtSize u)
-                    => Radian 
-                    -> LocThetaCF u (Point2 u, Point2 u, Point2 u)
-revtripointsByAngle triang = 
-    tipBody $ \pt theta h -> 
-      let theta'    = circularModulo $ pi+theta 
-          (vup,vlo) = triVecsByAngle h (0.5*triang) theta'
-          back_tip  = pt .-^ avec theta h 
-      in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo)
-
-
-
-tripointsByDist :: (Real u, Floating u, FromPtSize u)
-                => LocThetaCF u (Point2 u, Point2 u)
-tripointsByDist = 
-    tipBody $ \pt theta h -> 
-      let (vup,vlo) = triVecsByDist h (0.5*h) theta
-      in pure (pt .+^ vup, pt .+^ vlo)
-  
-
-
-revtripointsByDist :: (Real u, Floating u, FromPtSize u)
-                   => LocThetaCF u (Point2 u, Point2 u, Point2 u)
-revtripointsByDist = 
-    tipBody $ \pt theta h -> 
-      let theta'    = circularModulo $ pi+theta 
-          (vup,vlo) = triVecsByDist h (0.5*h) theta'
-          back_tip  = pt .-^ avec theta h 
-      in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo)
-
-
-
-
-
--- width = xchar_height
--- filled with stroke colour!
-
-triTLG :: (Floating u, Real u, FromPtSize u)
-       => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u
-triTLG triang drawF = 
-    promoteR2 $ \pt theta ->
-      localize bothStrokeColour $ 
-         apply2R2 (tripointsByAngle triang) pt theta >>= \(u,v) -> 
-           drawF $ vertexPath [pt,u,v]
-
-
-
-tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-tri90 = Arrowhead markHeight (triTLG (pi/2) filledPath)
-
-
-tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-tri60 = Arrowhead markHeight (triTLG (pi/3) filledPath)
-
-
-tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-tri45 = Arrowhead markHeight (triTLG (pi/4) filledPath)
-
-otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-otri90 = Arrowhead markHeight (triTLG (pi/2) solidClosedStroke)
-
-otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-otri60 = Arrowhead markHeight (triTLG (pi/3) solidClosedStroke)
-
-otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-otri45 = Arrowhead markHeight (triTLG (pi/4) solidClosedStroke)
-
-
--- width = xchar_height
--- filled with stroke colour!
-
-revtriTLG :: (Floating u, Real u, FromPtSize u)
-          => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u
-revtriTLG triang drawF = 
-    promoteR2 $ \pt theta -> 
-      localize bothStrokeColour $ 
-        apply2R2 (revtripointsByAngle triang) pt theta >>= \(u,pt',v) -> 
-           drawF $ vertexPath [u,pt',v]
-
-
-
-revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-revtri90 = Arrowhead markHeightLessLineWidth
-                     (revtriTLG (pi/2) filledPath)
-
-revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-revtri60 = Arrowhead markHeightLessLineWidth
-                     (revtriTLG (pi/3) filledPath)
-
-revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-revtri45 = Arrowhead markHeightLessLineWidth
-                     (revtriTLG (pi/4) filledPath)
-
-
-orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-orevtri90 = Arrowhead markHeightLessLineWidth
-                      (revtriTLG (pi/2) solidClosedStroke)
-
-orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-orevtri60 = Arrowhead markHeightLessLineWidth
-                      (revtriTLG (pi/3) solidClosedStroke)
-
-orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-orevtri45 = Arrowhead markHeightLessLineWidth
-                      (revtriTLG (pi/4) solidClosedStroke)
-
-
-
-barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u
-barbTLG ang =  
-    promoteR2 $ \pt theta -> 
-      apply2R2 (tripointsByAngle ang) pt theta >>= \(u,v) -> 
-        solidOpenStroke $ vertexPath [u,pt,v]
-
-
-
-barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-barb90 = Arrowhead noRetract (barbTLG (pi/2))
-
-barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-barb60 = Arrowhead noRetract (barbTLG (pi/3))
-
-
-barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-barb45 = Arrowhead noRetract (barbTLG (pi/4))
-
-
-
-revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u
-revbarbTLG ang = 
-    promoteR2 $ \pt theta -> 
-      apply2R2 (revtripointsByAngle ang) pt theta >>= \(u,pt',v) -> 
-        solidOpenStroke $ vertexPath [u,pt',v]
-
-revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-revbarb90 = Arrowhead markHeight (revbarbTLG (pi/2))
-
-
-revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-revbarb60 = Arrowhead markHeight (revbarbTLG (pi/3))
-
-revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
-revbarb45 = Arrowhead markHeight (revbarbTLG (pi/4))
-
-
-perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u
-perpTLG = 
-    tipBody $ \pt theta h -> 
-      let hh = 0.5*h in solidOpenStroke $ rperpPath hh pt theta
-
-
-rperpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u
-rperpPath hh ctr theta = primPath p0 [lineTo p1]
-  where
-    p0 = displacePerpendicular   hh  theta ctr
-    p1 = displacePerpendicular (-hh) theta ctr 
-             
-
-
-perp :: (Floating u, FromPtSize u) => Arrowhead u
-perp = Arrowhead noRetract perpTLG
-
-
-
-bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u
-bracketTLG = 
-    tipBody $ \pt theta h -> 
-      let hh = 0.5*h in solidOpenStroke $ rbracketPath hh pt theta
-
-
-rbracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u
-rbracketPath hh pt theta = vertexPath [p0,p1,p2,p3]
-  where
-    p1 = displacePerpendicular   hh  theta pt
-    p0 = displaceParallel      (-hh) theta p1
-    p2 = displacePerpendicular (-hh) theta pt
-    p3 = displaceParallel      (-hh) theta p2
-        
-
-
-
-bracket :: (Floating u, FromPtSize u) => Arrowhead u
-bracket = Arrowhead noRetract bracketTLG
-
-
-diskTLG :: (Floating u, FromPtSize u) 
-        => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u
-diskTLG drawF = 
-    tipBody $ \pt theta h -> let hh  = 0.5*h 
-                                 ctr = pt .-^ avec theta hh 
-                             in drawF hh ctr
-
-
-diskTip :: (Floating u, FromPtSize u) => Arrowhead u
-diskTip = Arrowhead markHeight (diskTLG drawF)
-  where
-    drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt
-
-
-odiskTip :: (Floating u, FromPtSize u) => Arrowhead u
-odiskTip = Arrowhead markHeight (diskTLG drawF)
-  where
-    drawF r pt = solidStrokedDisk r `at` pt
-
-
-squareTLG :: (Floating u, FromPtSize u) 
-        => (PrimPath u -> Graphic u) -> LocThetaGraphic u
-squareTLG drawF = 
-    tipBody $ \pt theta h -> drawF $ rsquarePath pt theta (0.5*h)
-
-
-rsquarePath :: Floating u => Point2 u -> Radian -> u -> PrimPath u
-rsquarePath pt theta hh = vertexPath [p0,p1,p2,p3]
-  where
-    p0 = displacePerpendicular     hh  theta pt
-    p3 = displacePerpendicular   (-hh) theta pt
-    p1 = displaceParallel      (-2*hh) theta p0
-    p2 = displaceParallel      (-2*hh) theta p3
-    
-
-squareTip :: (Floating u, FromPtSize u) => Arrowhead u
-squareTip = Arrowhead markHeight (squareTLG drawF)
-  where
-    drawF = localize bothStrokeColour . filledPath
-
-
-osquareTip :: (Floating u, FromPtSize u) => Arrowhead u
-osquareTip = Arrowhead markHeight (squareTLG solidClosedStroke)
-
-
-diamondTLG :: (Floating u, FromPtSize u) 
-           => (PrimPath u -> Graphic u) -> LocThetaGraphic u
-diamondTLG drawF = 
-    tipBody $ \pt theta h -> drawF $ rdiamondPath pt theta (0.5*h)
- 
-
-rdiamondPath :: Floating u => Point2 u -> Radian -> u -> PrimPath u
-rdiamondPath pt theta hh = vertexPath [pt,p1,p2,p3]
-  where
-    ctr = displaceParallel       (-2*hh) theta pt
-    p1  = displacePerpendicular     hh   theta ctr
-    p3  = displacePerpendicular   (-hh)  theta ctr
-    p2  = displaceParallel       (-4*hh) theta pt
-         
-
-
-diamondTip :: (Floating u, FromPtSize u) => Arrowhead u
-diamondTip = Arrowhead (fmap (2*) markHeightLessLineWidth) 
-                       (diamondTLG drawF)
-  where
-    drawF = localize bothStrokeColour . filledPath
-
-
-odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u
-odiamondTip = Arrowhead (fmap (2*) markHeight) (diamondTLG solidClosedStroke)
-
-
-
-
--- Note - points flipped to get the second trapezium to 
--- draw /underneath/.
---
-curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u
-curveTLG = 
-    tipBody $ \pt theta h -> 
-      cxCurvePath pt theta (0.5*h) >>= \path ->
-        localize (joinRound . capRound) (solidOpenStroke path)
-
-
-cxCurvePath :: (Real u, Floating u, FromPtSize u) 
-            => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u)
-cxCurvePath pt theta hh =
-     apply2R2 tripointsByDist pt theta >>= \(tup,tlo) -> 
-          let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup
-              (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt 
-          in pure $ toPrimPath $ curve tup u2 u1 pt `append` curve pt l1 l2 tlo
-
-
-
-
-curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u
-curveTip = Arrowhead (fmap realToFrac getLineWidth) curveTLG
-
-
--- Note - points flipped to get the second trapezium to 
--- draw /underneath/.
---
-revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u
-revcurveTLG = 
-    tipBody $ \pt theta h ->
-      cxRevcurvePath pt theta (0.5*h) >>= \path ->
-        localize (joinRound . capRound) (solidOpenStroke path)
-
-cxRevcurvePath :: (Real u, Floating u, FromPtSize u) 
-               => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u)
-cxRevcurvePath pt theta hh = 
-    apply2R2 revtripointsByDist pt theta >>= \(tup,p1,tlo) -> 
-      let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup
-          (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1
-      in pure $ toPrimPath $ curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo
-
-
-revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u
-revcurveTip = Arrowhead markHeight revcurveTLG
-
diff --git a/src/Wumpus/Drawing/Basis/BezierCurve.hs b/src/Wumpus/Drawing/Basis/BezierCurve.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Basis/BezierCurve.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Basis.BezierCurve
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Datatype for cubic Bezier curve.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Basis.BezierCurve
+  ( 
+
+    BezierCurve(..)
+  , vbezierCurve
+  , subdivide
+  , subdividet
+
+  , bezierLength
+
+  ) where
+
+
+import Wumpus.Drawing.Basis.Geometry
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+--------------------------------------------------------------------------------
+
+
+
+-- | A Strict cubic Bezier curve.
+--
+data BezierCurve u = BezierCurve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)
+  deriving (Eq,Ord,Show)
+
+type instance DUnit (BezierCurve u) = u
+
+
+
+vbezierCurve :: Num u 
+             => Vec2 u -> Vec2 u -> Vec2 u -> Point2 u -> BezierCurve u
+vbezierCurve v1 v2 v3 p0 = BezierCurve p0 p1 p2 p3
+  where
+    p1 = p0 .+^ v1
+    p2 = p1 .+^ v2
+    p3 = p2 .+^ v3
+
+
+
+-- | Curve subdivision via de Casteljau\'s algorithm.
+--
+subdivide :: Fractional u 
+          => BezierCurve u -> (BezierCurve u, BezierCurve u)
+subdivide (BezierCurve p0 p1 p2 p3) =
+    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)
+  where
+    p01   = midpoint p0    p1
+    p12   = midpoint p1    p2
+    p23   = midpoint p2    p3
+    p012  = midpoint p01   p12
+    p123  = midpoint p12   p23
+    p0123 = midpoint p012  p123
+
+
+-- | subdivide with an affine weight along the line...
+--
+subdividet :: Real u
+           => u -> BezierCurve u -> (BezierCurve u, BezierCurve u)
+subdividet t (BezierCurve p0 p1 p2 p3) = 
+    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)
+  where
+    p01   = affineComb t p0    p1
+    p12   = affineComb t p1    p2
+    p23   = affineComb t p2    p3
+    p012  = affineComb t p01   p12
+    p123  = affineComb t p12   p23
+    p0123 = affineComb t p012  p123
+
+
+--------------------------------------------------------------------------------
+
+-- | 'bezierLength' : @ start_point * control_1 * control_2 * 
+--        end_point -> Length @ 
+--
+-- Find the length of a Bezier curve. The result is an 
+-- approximation, with the /tolerance/ is 0.1 of a point. This
+-- seems good enough for drawing (potentially the tolerance could 
+-- be larger still). 
+--
+-- The result is found through repeated subdivision so the 
+-- calculation is potentially costly.
+--
+bezierLength :: (Floating u, Ord u, Tolerance u)
+             => BezierCurve u -> u
+bezierLength = gravesenLength length_tolerance 
+
+
+
+-- | Jens Gravesen\'s bezier arc-length approximation. 
+--
+-- Note this implementation is parametrized on error tolerance.
+--
+gravesenLength :: (Floating u, Ord u) => u -> BezierCurve u -> u
+gravesenLength err_tol crv = step crv 
+  where
+    step c = let l1 = ctrlPolyLength c
+                 l0 = cordLength c
+             in if   l1-l0 > err_tol
+                then let (a,b) = subdivide c in step a + step b
+                else 0.5*l0 + 0.5*l1
+
+-- | Length of the tree lines spanning the control points.
+--
+ctrlPolyLength :: Floating u => BezierCurve u -> u
+ctrlPolyLength (BezierCurve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3
+  where
+    len pa pb = vlength $ pvec pa pb
+
+
+-- | Length of the cord - start point to end point.
+--
+cordLength :: Floating u => BezierCurve u -> u
+cordLength (BezierCurve p0 _ _ p3) = vlength $ pvec p0 p3
+
+
diff --git a/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs b/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs
@@ -0,0 +1,132 @@
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Basis.DrawingPrimitives
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Alternative to the @DrawingPrimitives@ module in Wumpus-Basic.
+-- 
+-- The drawing primitives here are either slightly higher level or
+-- less general (more quirky).
+--
+-- This module is expected to be imported qualified - other modules
+-- (e.g. shapes and paths) are likely to export conflicting names.
+-- 
+-- \*\* WARNING \*\* - much of this module is probably obsolete 
+-- (except wedge).
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Basis.DrawingPrimitives
+  (
+
+
+  -- * Lines
+
+    horizontalLine
+  , verticalLine
+  , pivotLine
+
+
+  -- * Rectangles
+  , blRectangle
+  , ctrRectangle
+
+
+  -- * Wedge
+  , wedge
+
+  )
+
+  where
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+import Data.Monoid
+
+
+--------------------------------------------------------------------------------
+-- Lines
+
+
+-- | Draw a vertical line.
+-- 
+verticalLine :: InterpretUnit u => u -> LocGraphic u 
+verticalLine len = locStraightLine $ vvec len
+
+-- | Draw a horizontal line.
+-- 
+horizontalLine :: InterpretUnit u => u -> LocGraphic u 
+horizontalLine len = locStraightLine $ hvec len
+
+
+
+-- | @pivotLine@ : @ left_length * right_length * incline -> LocGraphic @
+--
+-- Draw a /pivot/ line. The start point is a pivot along the line, 
+-- not the end. The left and right distances are the extension of
+-- the line from the pivot. 
+--
+pivotLine :: (Floating u, InterpretUnit u) => u -> u -> Radian -> LocGraphic u
+pivotLine lu ru ang = promoteLoc $ \pt -> 
+    straightLine (pt .+^ avec (ang+pi) lu) (pt .+^ avec ang ru)
+
+
+
+
+--------------------------------------------------------------------------------
+-- Rectangles
+
+
+
+-- | Draw a rectangle, start point is bottom left.
+--
+blRectangle :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u
+blRectangle = dcRectangle
+
+
+-- | Draw a rectangle, start point is bottom left.
+--
+ctrRectangle :: (Fractional u, InterpretUnit u) 
+             => DrawMode -> u -> u -> LocGraphic u
+ctrRectangle mode w h = 
+    moveStart (vec (-hw) (-hh)) $ dcRectangle mode w h
+  where
+    hw = 0.5 * w
+    hh = 0.5 * h
+
+
+
+
+--------------------------------------------------------------------------------
+-- Wedge
+
+
+
+-- | wedge : mode * radius * apex_angle
+-- 
+-- Wedge is drawn at the apex.
+--
+wedge :: (Real u, Floating u, InterpretUnit u) 
+       => DrawMode -> u -> Radian -> LocThetaGraphic u
+wedge mode radius ang = promoteLocTheta $ \pt inclin -> 
+    let half_ang = 0.5 * ang 
+        line_in  = catline $ avec (inclin + half_ang)   radius
+        line_out = catline $ avec (inclin - half_ang) (-radius)
+        w_arc    = circularArc CW ang radius (inclin - half_pi)
+        ct       = line_in `mappend` w_arc `mappend` line_out
+    in supplyLoc pt $ renderCatTrail (closedMode mode) ct
+        
+
diff --git a/src/Wumpus/Drawing/Basis/Geometry.hs b/src/Wumpus/Drawing/Basis/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Basis/Geometry.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Basis.Geometry
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Misc geometric operations.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Basis.Geometry
+  ( 
+
+    midpoint
+  , affineComb
+
+  ) where
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+--------------------------------------------------------------------------------
+
+
+
+--------------------------------------------------------------------------------
+--
+
+
+-- | Affine combination...
+--
+affineComb :: Real u => u -> Point2 u -> Point2 u -> Point2 u
+affineComb t p1 p2 = p1 .+^ t *^ (p2 .-. p1)
+
+
+-- | 'midpoint' : @ start_point * end_point -> Midpoint @
+-- 
+-- Mid-point on the line formed between the two supplied points.
+--
+midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
+midpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0
diff --git a/src/Wumpus/Drawing/Basis/InclineTrails.hs b/src/Wumpus/Drawing/Basis/InclineTrails.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Basis/InclineTrails.hs
@@ -0,0 +1,499 @@
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Basis.InclineTrails
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Basis.InclineTrails
+  (
+
+    incline_circle
+  , incline_ellipse
+  , incline_square
+  , incline_rect
+  , incline_diamond
+  , incline_triangle
+  , incline_barb
+  , incline_tube
+  , incline_chamf_rect
+
+  , trail_diagh
+  , trail_diagv
+  , trail_hdiag
+  , trail_vdiag
+
+  , trail_hdiagh
+  , trail_vdiagv
+
+  , trail_perp_bar
+  , trail_perp_bar2
+
+  , trail_vflam
+  , trail_ortho_hbar
+  , trail_ortho_vbar
+
+  , trail_hright
+  , trail_vright
+
+  , trail_hrr
+  , trail_vrr
+  , trail_rrh
+  , trail_rrv
+
+  , trail_rect_loop
+
+  , vtriCurve
+  , vrectCurve
+  , vtrapCurve
+  , vbowCurve
+  , vwedgeCurve
+
+  )
+  where
+
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Data.Monoid
+
+
+-- Shapes...
+
+incline_circle :: (Real u, Floating u) => Vec2 u -> AnaTrail u
+incline_circle v1 = 
+    anaCatTrail zeroVec (semicircleTrail CW v1 <> semicircleTrail CW rv1)
+  where
+    rv1 = vreverse v1
+
+incline_ellipse :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u
+incline_ellipse ry v1 = 
+    anaCatTrail zeroVec (semiellipseTrail CW ry v1 <> semiellipseTrail CW ry rv1)
+  where
+    rv1 = vreverse v1
+
+
+
+incline_square :: (Real u, Floating u) => Vec2 u -> AnaTrail u
+incline_square v1 = incline_rect (vlength v1) v1
+
+
+incline_rect :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u
+incline_rect h v1 = 
+    anaCatTrail (theta_down (0.5 * h) ang) catt
+  where
+    len  = vlength v1
+    ang  = vdirection v1
+    catt = mconcat [ trail_theta_right len ang
+                   , trail_theta_up h ang 
+                   , trail_theta_left len ang 
+                   , trail_theta_down h ang 
+                   ]
+           
+incline_diamond :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u
+incline_diamond h v1 = anaCatTrail zeroVec catt
+  where
+    hw   = 0.5 * vlength v1
+    hh   = 0.5 * h
+    ang  = vdirection v1
+    catt = mconcat [ orthoCatTrail   hw  (-hh) ang
+                   , orthoCatTrail   hw    hh  ang 
+                   , orthoCatTrail (-hw)   hh  ang 
+                   , orthoCatTrail (-hw) (-hh) ang 
+                   ]
+
+-- | Note - vector represents midpoint of the baseline to the 
+-- tip. Angle is the ang of the tip.
+--
+-- This trail is primarily for drawing arrowheads.
+-- 
+incline_triangle :: (Real u, Floating u) => Radian -> Vec2 u -> AnaTrail u
+incline_triangle tip_ang v1 = 
+    anaCatTrail (theta_up opposite theta) catt
+  where
+    half_ang = 0.5 * tip_ang
+    theta    = vdirection v1
+    h        = vlength v1
+    opposite = h * (fromRadian $ tan half_ang)
+
+    catt     = mconcat [ trail_theta_adj_grazing h half_ang theta
+                       , trail_theta_bkwd_adj_grazing h half_ang theta
+                       , trail_theta_up (2 * opposite) theta
+                       ]
+
+
+-- | Note - vector represents midpoint of the baseline to the 
+-- tip. Angle is the ang of the tip.
+--
+-- This trail is primarily for drawing arrowheads. The resulting 
+-- path is /open/. 
+-- 
+incline_barb :: (Real u, Floating u) => Radian -> Vec2 u -> AnaTrail u
+incline_barb tip_ang v1 = 
+    anaCatTrail (theta_up opposite theta) catt
+  where
+    half_ang = 0.5 * tip_ang
+    theta    = vdirection v1
+    h        = vlength v1
+    opposite = h * (fromRadian $ tan half_ang)
+
+    catt     = mconcat [ trail_theta_adj_grazing h half_ang theta
+                       , trail_theta_bkwd_adj_grazing h half_ang theta
+                       ]
+
+
+-- | @v1@ is the /interior/ vector.
+--
+incline_tube :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u
+incline_tube h v1 = 
+    anaCatTrail (theta_down_right hh ang) $ mconcat $
+      [ trail_theta_right base_len ang
+      , semicircleTrail CCW vup
+      , trail_theta_left base_len ang
+      , semicircleTrail CCW vdown
+      ]
+  where
+    hh        = 0.5 * h
+    ang       = vdirection v1 
+    base_len  = vlength v1 - h
+    vup       = avec (ang + half_pi) h
+    vdown     = avec (ang - half_pi) h
+
+
+incline_chamf_rect :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u
+incline_chamf_rect h v1 = 
+    anaCatTrail zeroVec $ mconcat $
+      [ trail_theta_down_right hh ang
+      , trail_theta_right base_len ang
+      , trail_theta_up_right hh ang
+      , trail_theta_up_left hh ang
+      , trail_theta_left base_len ang
+      , trail_theta_down_left hh ang
+      ]
+  where
+    hh        = 0.5 * h
+    ang       = vdirection v1 
+    base_len  = vlength v1 - h
+
+-- | Diagonal-horizontal trail.
+--
+-- >    --@
+-- >   /
+-- >  o
+-- 
+trail_diagh :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u
+trail_diagh leg v1 = 
+    let h   = vector_y v1
+        mid = (abs $ vector_x v1) - leg
+    in case horizontalDirection $ vdirection v1 of
+         RIGHTWARDS -> orthoCatTrail mid h 0    <> trail_right leg
+         _          -> orthoCatTrail (-mid) h 0 <> trail_left leg
+
+trail_diagv :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u
+trail_diagv leg v1 = 
+    let w   = vector_x v1
+        mid = (abs $ vector_y v1) - leg
+    in case verticalDirection $ vdirection v1 of
+         UPWARDS -> orthoCatTrail w mid 0 <> trail_up leg
+         _       -> orthoCatTrail w (-mid) 0 <> trail_down leg
+
+
+trail_hdiag :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u
+trail_hdiag leg v1 = 
+    let h   = vector_y v1
+        mid = (abs $ vector_x v1) - leg
+    in case horizontalDirection $ vdirection v1 of
+         RIGHTWARDS -> trail_right leg <> orthoCatTrail mid h 0
+         _          -> trail_left  leg <> orthoCatTrail (-mid) h 0
+
+
+trail_vdiag :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u
+trail_vdiag leg v1 = 
+    let w   = vector_x v1
+        mid = (abs $ vector_y v1) - leg
+    in case verticalDirection $ vdirection v1 of
+         UPWARDS -> trail_up   leg <> orthoCatTrail w mid 0
+         _       -> trail_down leg <> orthoCatTrail w (-mid) 0
+
+
+
+-- | Horizontal-diagonal-horizontal trail.
+--
+-- >      --@
+-- >     /
+-- >  o--
+-- 
+--
+trail_hdiagh :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u
+trail_hdiagh legl legr v1 = 
+    let h   = vector_y v1
+        mid = (abs $ vector_x v1) - (legl + legr)
+    in case horizontalDirection $ vdirection v1 of
+         RIGHTWARDS -> mconcat [ trail_right legl
+                               , orthoCatTrail mid h 0
+                               , trail_right legr
+                               ] 
+         _          -> mconcat [ trail_left  legl
+                               , orthoCatTrail (-mid) h 0
+                               , trail_left legr
+                               ] 
+
+
+
+trail_vdiagv :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u
+trail_vdiagv legl legr v1 = 
+    let w   = vector_x v1
+        mid = (abs $ vector_y v1) - (legl + legr)
+    in case verticalDirection $ vdirection v1 of
+         UPWARDS -> mconcat [ trail_up legl
+                            , orthoCatTrail w mid 0
+                            , trail_up legr
+                            ] 
+         _       -> mconcat [ trail_down  legl
+                            , orthoCatTrail w (-mid) 0
+                            , trail_down legr
+                            ] 
+
+-- | Uniform leg size.
+--
+trail_perp_bar :: (Real u, Floating u) 
+               => ClockDirection -> u -> Vec2 u -> CatTrail u
+trail_perp_bar CW h v1 = trail_perp_barCW h v1
+trail_perp_bar _  h v1 = trail_perp_barCW (-h) v1
+
+
+trail_perp_barCW :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u
+trail_perp_barCW h v1 = 
+    trail_theta_up h ang <> catline v1 <> trail_theta_down h ang
+  where
+    ang = vdirection v1
+
+
+-- | Bar connector - independent leg size, legs perpendicular.
+--
+-- 
+-- >  o    @ 
+-- >  |    |
+-- >  '----'  
+--
+-- The bar is drawn /below/ the points.
+--
+trail_perp_bar2 :: (Real u, Floating u) 
+                => ClockDirection -> u -> u -> Vec2 u -> CatTrail u
+trail_perp_bar2 CW h1 h2 v1 = trail_perp_barCW2 h1 h2 v1
+trail_perp_bar2 _  h1 h2 v1 = trail_perp_barCW2 (-h1) (-h2) v1
+
+
+trail_perp_barCW2 :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u
+trail_perp_barCW2 h1 h2 v1 = 
+       trail_theta_up h1 ang 
+    <> orthoCatTrail (vlength v1) (negate $ h1 - h2) ang
+    <> trail_theta_down h2 ang
+  where
+    ang = vdirection v1
+
+
+-- | Independent leg size.
+--
+trail_vflam :: (Real u, Floating u) 
+            => ClockDirection -> u -> u -> Vec2 u -> CatTrail u
+trail_vflam CW h1 h2 v1 = trail_vflamCW h1 h2 v1
+trail_vflam _  h1 h2 v1 = trail_vflamCW (-h1) (-h2) v1
+
+
+trail_vflamCW :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u
+trail_vflamCW h1 h2 v1 = 
+    diffLines [ p0, p0 .+^ vvec h1, p1 .+^ vvec h2, p1 ]
+  where
+    p0 = zeroPt
+    p1 = p0 .+^ v1
+
+
+-- | Height is minimum leg height. Ortho bar is horizontal.
+--
+trail_ortho_hbar :: (Real u, Floating u) 
+                 => ClockDirection -> u -> Vec2 u -> CatTrail u
+trail_ortho_hbar CW h v1 = trail_ortho_hbarCW  h v1
+trail_ortho_hbar _  h v1 = trail_ortho_hbarCCW h v1
+
+
+trail_ortho_hbarCW :: (Real u, Floating u) 
+                   => u -> Vec2 u -> CatTrail u
+trail_ortho_hbarCW ymin v1@(V2 x y) = case quadrant $ vdirection v1 of
+    QUAD_NE -> trail_up ymaj <> trail_right x <> trail_down ymin
+    QUAD_SE -> trail_up ymin <> trail_right x <> trail_down ymaj
+    QUAD_NW -> trail_down ymin <> trail_left (abs x) <> trail_up ymaj
+    QUAD_SW -> trail_down ymaj <> trail_left (abs x) <> trail_up ymin
+  where
+    ymaj = ymin + abs y
+
+
+
+
+trail_ortho_hbarCCW :: (Real u, Floating u) 
+                   => u -> Vec2 u -> CatTrail u
+trail_ortho_hbarCCW ymin v1@(V2 x y) = case quadrant $ vdirection v1 of
+    QUAD_NE -> trail_down ymin <> trail_right x <> trail_up ymaj
+    QUAD_SE -> trail_down ymaj <> trail_right x <> trail_up ymin
+    QUAD_NW -> trail_up ymaj <> trail_left (abs x) <> trail_down ymin
+    QUAD_SW -> trail_up ymin <> trail_left (abs x) <> trail_down ymaj
+  where
+    ymaj = ymin + abs y
+
+
+
+
+-- | Width is minimum leg width. Ortho bar is vertical.
+--
+trail_ortho_vbar :: (Real u, Floating u) 
+                 => ClockDirection -> u -> Vec2 u -> CatTrail u
+trail_ortho_vbar CW w v1 = trail_ortho_vbarCW  w v1
+trail_ortho_vbar _  w v1 = trail_ortho_vbarCCW w v1
+
+
+trail_ortho_vbarCW :: (Real u, Floating u) 
+                   => u -> Vec2 u -> CatTrail u
+trail_ortho_vbarCW xmin v1@(V2 x y) = case quadrant $ vdirection v1 of
+    QUAD_NE -> trail_left xmin <> trail_up y <> trail_right xmaj
+    QUAD_NW -> trail_left xmaj <> trail_up y <> trail_right xmin
+    QUAD_SE -> trail_right xmaj <> trail_down (abs y) <> trail_left xmin
+    QUAD_SW -> trail_right xmin <> trail_down (abs y) <> trail_left xmaj
+  where
+    xmaj = xmin + abs x
+
+
+
+trail_ortho_vbarCCW :: (Real u, Floating u) 
+                   => u -> Vec2 u -> CatTrail u
+trail_ortho_vbarCCW xmin v1@(V2 x y) = case quadrant $ vdirection v1 of
+    QUAD_NE -> trail_right xmaj <> trail_up y <> trail_left xmin
+    QUAD_NW -> trail_right xmin <> trail_up y <> trail_left xmaj
+    QUAD_SE -> trail_left  xmin <> trail_down (abs y) <> trail_right xmaj
+    QUAD_SW -> trail_left  xmaj <> trail_down (abs y) <> trail_right xmin
+  where
+    xmaj = xmin + abs x
+
+
+trail_hright :: Num u => Vec2 u -> CatTrail u
+trail_hright (V2 x y) = trail_right x <> trail_up y
+
+
+trail_vright :: Num u => Vec2 u -> CatTrail u
+trail_vright (V2 x y) = trail_up y <> trail_right x
+
+trail_hrr :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u
+trail_hrr x1 (V2 x y) = 
+       trail_theta_right x1 ang 
+    <> trail_theta_up y ang 
+    <> trail_theta_right (abs x  - x1) ang
+  where
+    ang = if x < 0 then pi else 0
+
+trail_vrr :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u
+trail_vrr y1 (V2 x y) = 
+       trail_theta_up y1 ang 
+    <> trail_theta_right x ang 
+    <> trail_theta_up (abs y  - y1) ang
+  where
+    ang = if y < 0 then pi else 0
+
+
+trail_rrh :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u
+trail_rrh x1 (V2 x y) = 
+       trail_theta_right (abs x  - x1) ang 
+    <> trail_theta_up y ang 
+    <> trail_theta_right x1 ang
+  where
+    ang = if x < 0 then pi else 0
+
+trail_rrv :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u
+trail_rrv y1 (V2 x y) = 
+       trail_theta_up (abs y - y1) ang 
+    <> trail_theta_right x ang 
+    <> trail_theta_up y1 ang
+  where
+    ang = if y < 0 then pi else 0
+
+
+trail_rect_loop :: (Real u, Floating u) 
+                => ClockDirection -> u -> u -> u -> Vec2 u -> CatTrail u
+trail_rect_loop CW = trail_rect_loopCW
+trail_rect_loop _  = trail_rect_loopCCW
+
+trail_rect_loopCW :: (Real u, Floating u) 
+                  => u -> u -> u -> Vec2 u -> CatTrail u
+trail_rect_loopCW extl extr h v1 = 
+       trail_theta_left  extl ang
+    <> trail_theta_up    h    ang
+    <> trail_theta_right (len + extl + extr) ang
+    <> trail_theta_down  h    ang
+    <> trail_theta_left  extr ang
+  where
+    ang = vdirection v1
+    len = vlength v1
+
+trail_rect_loopCCW :: (Real u, Floating u)
+                   => u -> u -> u -> Vec2 u -> CatTrail u
+trail_rect_loopCCW extl extr h v1 = 
+       trail_theta_left  extl ang
+    <> trail_theta_down  h    ang
+    <> trail_theta_right (len + extl + extr) ang
+    <> trail_theta_up    h    ang
+    <> trail_theta_left  extr ang
+  where
+    ang = vdirection v1
+    len = vlength v1
+
+
+-- | 'triCurve' formulated with a /base vector/ rather than 
+-- base-width and angle of inclination.
+--
+vtriCurve :: (Real u, Floating u) 
+          => ClockDirection -> u -> Vec2 u -> CatTrail u 
+vtriCurve clk h v1 = triCurve clk (vlength v1) h (vdirection v1)
+  
+
+-- | 'rectCurve' formulated with a /base vector/ rather than 
+-- base-width and angle of inclination.
+--
+vrectCurve :: (Real u, Floating u) 
+           => ClockDirection -> u -> Vec2 u -> CatTrail u
+vrectCurve clk h v1 = rectCurve clk (vlength v1) h (vdirection v1)
+
+
+-- | 'trapCurve' formulated with a /base vector/ rather than 
+-- base-width and angle of inclination.
+--
+vtrapCurve :: (Real u, Floating u)
+           => ClockDirection -> u -> Radian -> Vec2 u -> CatTrail u
+vtrapCurve clk h interior_ang v1 = 
+    trapCurve clk (vlength v1) h interior_ang (vdirection v1)
+
+
+-- | 'bowCurve' formulated with a /base vector/ rather than 
+-- base-width and angle of inclination.
+--
+vbowCurve :: (Real u, Floating u)
+          => ClockDirection -> u -> Vec2 u -> CatTrail u
+vbowCurve clk h v1 = bowCurve clk (vlength v1) h (vdirection v1) 
+
+-- | 'wedgeCurve' formulated with a /base vector/ rather than 
+-- base-width and angle of inclination.
+--
+vwedgeCurve :: (Real u, Floating u)
+            => ClockDirection -> u -> Vec2 u -> CatTrail u
+vwedgeCurve clk h v1 = wedgeCurve clk (vlength v1) h (vdirection v1) 
+
diff --git a/src/Wumpus/Drawing/Basis/ShapeTrails.hs b/src/Wumpus/Drawing/Basis/ShapeTrails.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Basis/ShapeTrails.hs
@@ -0,0 +1,213 @@
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Basis.ShapeTrails
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Basis.ShapeTrails
+  (
+
+    circle_trail
+  , rcircle_trail
+
+  , ellipse_trail
+  , rellipse_trail
+
+  , rectangle_trail
+  , rrectangle_trail
+
+  , diamond_trail
+  , rdiamond_trail
+
+  , isosceles_triangle_trail
+  , risosceles_triangle_trail
+
+  , semicircle_trail
+  , rsemicircle_trail
+
+  , semiellipse_trail
+  , rsemiellipse_trail
+
+  , parallelogram_trail
+  , rparallelogram_trail
+
+  , trapezium_trail
+  , rtrapezium_trail
+
+  )
+
+  where
+
+import Wumpus.Drawing.Basis.InclineTrails
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+-- import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+import Data.Monoid
+
+
+-- Shapes...
+
+circle_trail :: (Real u, Floating u) => u -> AnaTrail u
+circle_trail r = rcircle_trail r 0
+
+rcircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u
+rcircle_trail r ang = 
+    modifyAna (\v -> v ^-^ avec ang r) $ incline_circle $ avec ang (2 * r)
+
+
+
+ellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
+ellipse_trail rx ry = rellipse_trail rx ry 0
+
+rellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
+rellipse_trail rx ry ang = 
+    modifyAna (\v -> v ^-^ avec ang rx) $ incline_ellipse ry $ avec ang (2 * rx)
+
+
+rectangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
+rectangle_trail w h = rrectangle_trail w h 0
+
+
+rrectangle_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
+rrectangle_trail w h ang = 
+    anaCatTrail (orthoVec (negate $ 0.5 * w) (negate $ 0.5 * h) ang) catt
+  where
+    catt = mconcat [ trail_theta_right w ang
+                   , trail_theta_up    h ang 
+                   , trail_theta_left  w ang 
+                   , trail_theta_down  h ang 
+                   ]
+
+
+diamond_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
+diamond_trail w h = rdiamond_trail w h 0 
+
+rdiamond_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
+rdiamond_trail w h ang = 
+    anaCatTrail (theta_right hw ang) catt
+  where
+    hw   = 0.5 * w
+    hh   = 0.5 * h
+    catt = mconcat [ orthoCatTrail (-hw)   hh  ang
+                   , orthoCatTrail (-hw) (-hh) ang 
+                   , orthoCatTrail   hw  (-hh) ang 
+                   , orthoCatTrail   hw    hh  ang 
+                   ]
+
+
+isosceles_triangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
+isosceles_triangle_trail bw h = risosceles_triangle_trail bw h 0 
+
+-- | Drawn at the centroid (1/3 * h).
+--
+risosceles_triangle_trail :: (Real u, Floating u) 
+                          => u -> u -> Radian -> AnaTrail u
+risosceles_triangle_trail bw h ang = 
+    anaCatTrail (orthoVec (negate hbw) (negate $ h / 3) ang) catt
+  where
+    hbw  = 0.5 * bw
+    catt = mconcat [ trail_theta_right bw ang
+                   , orthoCatTrail (-hbw)   h  ang
+                   , orthoCatTrail (-hbw) (-h) ang
+                   ]
+
+
+semicircle_trail :: (Real u, Floating u) => u -> AnaTrail u
+semicircle_trail r = rsemicircle_trail r 0
+
+rsemicircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u
+rsemicircle_trail r ang = 
+    anaCatTrail (orthoVec (negate r) (negate hminor) ang) catt
+  where
+    -- hminor is the centroid formula for semicircle
+    hminor = (4 * r) / (3 * pi)
+    catt   =  trail_theta_right (2 * r) ang
+           <> semicircleTrail CCW (avec ang (negate $ 2 * r) )
+
+
+
+semiellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u
+semiellipse_trail rx ry = rsemiellipse_trail rx ry 0
+
+rsemiellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u
+rsemiellipse_trail rx ry ang = 
+    anaCatTrail (orthoVec (negate rx) (negate hminor) ang) catt
+  where
+    -- hminor is the centroid formula for semiellipse
+    hminor = (4 * ry) / (3 * pi)
+    catt   =  trail_theta_right (2 * rx) ang
+           <> semiellipseTrail CCW ry (avec ang (negate $ 2 * rx) )
+
+-- | Note - bottom left angle must be smaller than 180deg, 
+-- otherwise a runtime error is thrown.
+--
+parallelogram_trail :: Floating u => u -> u -> Radian -> AnaTrail u
+parallelogram_trail w h bottom_left_ang = 
+    rparallelogram_trail w h bottom_left_ang 0
+
+-- | Note - bottom left angle must be smaller than 180deg, 
+-- otherwise a runtime error is thrown.
+--
+rparallelogram_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u
+rparallelogram_trail w h bl_ang ang
+    | bl_ang >= ang180 = 
+        error "rparallelogram_trail - bottom left angle >= 180."
+    | otherwise     = anaCatTrail ctr_to_bl catt
+  where
+    -- Note - base_minor is negative for angles > 90
+    base_minor = h / (fromRadian $ tan bl_ang)
+                 
+    vbase      = theta_right w ang
+    vrhs       = orthoVec base_minor h ang
+    vtop       = vreverse vbase
+    vlhs       = vreverse vrhs
+    ctr_to_bl  = vreverse $ 0.5 *^ (vbase ^+^ vrhs)
+    catt       = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ]
+
+
+-- | Note - bottom left angle must be smaller than 180deg, 
+-- otherwise a runtime error is thrown.
+--
+-- Also, no checking is perfomed on the relation between height
+-- and bottom_left ang. Out of range values will draw \"twisted\"
+-- trapezoids.
+-- 
+trapezium_trail :: Floating u => u -> u -> Radian -> AnaTrail u
+trapezium_trail w h bottom_left_ang = 
+    rtrapezium_trail w h bottom_left_ang 0
+
+
+-- | Note - bottom left angle must be smaller than 180deg, 
+-- otherwise a runtime error is thrown.
+--
+rtrapezium_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u
+rtrapezium_trail bw h bl_ang ang  
+    | bl_ang >= ang180 = error "rtrapezium_trail - bottom left angle >= 180."
+    | otherwise        = anaCatTrail ctr_to_bl catt
+  where
+    -- Note - base_minor is negative for angles > 90
+    base_minor = h / (fromRadian $ tan bl_ang)
+    top_width  = bw - (2 * base_minor)
+    vbase      = theta_right bw ang
+    vrhs       = orthoVec (-base_minor) h ang
+    vtop       = theta_left top_width ang
+    vlhs       = orthoVec (-base_minor) (-h) ang
+    ctr_to_bl  = orthoVec (negate $ 0.5 * bw) (negate $ 0.5 * h) ang
+    catt       = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ]
+
+    
diff --git a/src/Wumpus/Drawing/Basis/Symbols.hs b/src/Wumpus/Drawing/Basis/Symbols.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Basis/Symbols.hs
@@ -0,0 +1,369 @@
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Basis.Symbols
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Symbols - many symbols expected to be re-defined as Dots or
+-- character size PosObjects for DocText.
+--
+-- \*\* WARNING \*\* - naming conventention is to be determined...
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Basis.Symbols
+  (
+
+    scircle
+  , fcircle
+  , fscircle
+    
+  , ssquare
+  , fsquare
+  , fssquare
+
+  , sleft_slice
+  , fleft_slice
+  , fsleft_slice
+
+  , sright_slice
+  , fright_slice
+  , fsright_slice
+
+  , sleft_triangle
+  , fleft_triangle
+  , fsleft_triangle
+
+  , sright_triangle
+  , fright_triangle
+  , fsright_triangle
+
+  , ochar
+  , ocharUpright
+  , ocharDescender
+  , ocurrency
+
+  , empty_box
+
+  , hbar
+  , vbar
+  , dbl_hbar
+  , dbl_vbar
+
+  )
+  where
+
+import Wumpus.Drawing.Basis.DrawingPrimitives
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+-- import Data.AffineSpace                         -- package: vector-space
+
+import Data.Monoid
+
+--
+-- DESIGN NOTE 
+--
+-- Should names follow the /function scheme/ (camelCase), or the
+-- /data scheme/ (underscore_separators).
+--
+-- Objects here are functions as they take size param, but they
+-- expected to be redefined elsewhere (possibly at fixed size) 
+-- with the re-definitions used in /user code/ rather than these 
+-- primitives. 
+-- 
+-- Using camelCase here, then under_score in the DocText versions
+-- adds double the function signatures to the Haddock docs.
+--
+-- Also - should the names encode start pos, or can all start 
+-- positions be center?
+--
+
+--
+-- TikZ uses o to indicated /circled/.
+--
+-- Using o as a prefix for /open/ i.e. stroked has the problem 
+-- that there aren\'t any other characters ideographic for filled
+-- or filled stroked.
+--
+
+-- scircle
+-- fcircle
+-- fscircle
+
+
+
+-- | Stroked circle.
+-- 
+-- Start pos - center.
+--
+scircle :: InterpretUnit u => u -> LocGraphic u
+scircle radius = dcDisk DRAW_STROKE radius
+
+-- | Filled circle.
+-- 
+-- Start pos - center.
+--
+fcircle :: InterpretUnit u => u -> LocGraphic u
+fcircle radius = dcDisk DRAW_FILL radius
+
+-- | Filled-stroked circle.
+-- 
+-- Start pos - center.
+--
+fscircle :: InterpretUnit u => u -> LocGraphic u
+fscircle radius = dcDisk DRAW_FILL_STROKE radius
+
+
+
+
+-- | Stroked square.
+-- 
+-- Start pos - center.
+--
+ssquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u
+ssquare w = renderAnaTrail CSTROKE $ rectangleTrail w w 
+
+
+-- | Filled square.
+-- 
+-- Start pos - center.
+--
+fsquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u
+fsquare w = renderAnaTrail CFILL $ rectangleTrail w w 
+
+
+-- | Filled-stroked square.
+-- 
+-- Start pos - center.
+--
+fssquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u
+fssquare w = renderAnaTrail CFILL_STROKE $ rectangleTrail w w 
+
+
+
+-- | Implementation.
+--
+lslice :: (Real u, Floating u, InterpretUnit u) 
+       => DrawMode -> u -> LocGraphic u
+lslice mode radius = moveStart (go_left $ 0.5 * radius) lwedge
+  where
+    lwedge = supplyIncline 0 $ wedge mode radius quarter_pi
+
+-- | Stroked left slice (wedge).
+-- 
+-- Start pos - ....
+--
+sleft_slice :: (Real u, Floating u, InterpretUnit u) 
+            => u -> LocGraphic u
+sleft_slice = lslice DRAW_STROKE
+
+
+-- | Filled left slice (wedge).
+-- 
+-- Start pos - ....
+--
+fleft_slice :: (Real u, Floating u, InterpretUnit u) 
+            => u -> LocGraphic u
+fleft_slice = lslice DRAW_FILL
+
+
+-- | Filled-stroked left slice (wedge).
+-- 
+-- Start pos - ....
+--
+fsleft_slice :: (Real u, Floating u, InterpretUnit u) 
+             => u -> LocGraphic u
+fsleft_slice = lslice DRAW_FILL_STROKE
+
+
+
+-- | Implementation.
+--
+rslice :: (Real u, Floating u, InterpretUnit u) 
+       => DrawMode -> u -> LocGraphic u
+rslice mode radius = moveStart (go_right $ 0.5 * radius) rwedge
+  where
+    rwedge = supplyIncline pi $ wedge mode radius quarter_pi
+
+
+-- | Stroked right slice (wedge).
+-- 
+-- Start pos - ....
+--
+sright_slice :: (Real u, Floating u, InterpretUnit u) 
+             => u -> LocGraphic u
+sright_slice = rslice DRAW_STROKE
+
+
+-- | Filled right slice (wedge).
+-- 
+-- Start pos - ....
+--
+fright_slice :: (Real u, Floating u, InterpretUnit u) 
+             => u -> LocGraphic u
+fright_slice = rslice DRAW_FILL
+
+
+-- | Filled-stroked right slice (wedge).
+-- 
+-- Start pos - ....
+--
+fsright_slice :: (Real u, Floating u, InterpretUnit u) 
+              => u -> LocGraphic u
+fsright_slice = rslice DRAW_FILL_STROKE
+
+
+
+-- | Implementation.
+--
+left_tri :: (Fractional u, InterpretUnit u) 
+         => PathMode -> u -> LocGraphic u
+left_tri mode w = 
+    renderAnaTrail mode $ anaCatTrail (go_left $ 0.5 * w)
+                            $ line_r <> vbase <> line_l
+  where
+    hh     = 0.40 * w
+    line_r = catline $ vec w hh
+    vbase  = catline $ go_down $ 2*hh
+    line_l = catline $ vec (-w) hh
+
+
+-- | Stroked left triangle.
+-- 
+-- Start pos - ....
+--
+sleft_triangle :: (Real u, Floating u, InterpretUnit u) 
+                => u -> LocGraphic u
+sleft_triangle = left_tri CSTROKE
+
+
+-- | Filled left triangle.
+-- 
+-- Start pos - ....
+--
+fleft_triangle :: (Real u, Floating u, InterpretUnit u) 
+                => u -> LocGraphic u
+fleft_triangle = left_tri CFILL
+
+
+-- | Filled-stroked left triangle.
+-- 
+-- Start pos - ....
+--
+fsleft_triangle :: (Real u, Floating u, InterpretUnit u) 
+                 => u -> LocGraphic u
+fsleft_triangle = left_tri CFILL_STROKE
+
+
+-- | Implementation
+--
+right_tri :: (Fractional u, InterpretUnit u) 
+          => PathMode -> u -> LocGraphic u
+right_tri mode w = 
+    renderAnaTrail mode $ anaCatTrail (go_right $ 0.5 * w)
+                            $ line_l <> vbase <> line_r
+  where
+    hh     = 0.40 * w
+    line_l = catline $ vec (-w) hh
+    vbase  = catline $ go_down $ 2*hh
+    line_r = catline $ vec w hh
+
+
+-- | Stroked right triangle.
+-- 
+-- Start pos - ....
+--
+sright_triangle :: (Real u, Floating u, InterpretUnit u) 
+                => u -> LocGraphic u
+sright_triangle = right_tri CSTROKE
+
+
+-- | Filled right triangle.
+-- 
+-- Start pos - ....
+--
+fright_triangle :: (Real u, Floating u, InterpretUnit u) 
+                => u -> LocGraphic u
+fright_triangle = right_tri CFILL
+
+
+-- | Filled-stroked right triangle.
+-- 
+-- Start pos - ....
+--
+fsright_triangle :: (Real u, Floating u, InterpretUnit u) 
+                 => u -> LocGraphic u
+fsright_triangle = right_tri CFILL_STROKE
+
+
+
+-- | Note this looks horrible for chars with descenders.
+--
+ochar :: (Fractional u, InterpretUnit u) 
+      => EscapedChar -> LocGraphic u
+ochar esc = char1 <> circ1
+  where
+    char1 = runPosObject CENTER $ posEscChar esc
+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (0.85 * h)
+
+ocharUpright :: (Fractional u, InterpretUnit u) 
+             => EscapedChar -> LocGraphic u
+ocharUpright esc = char1 <> circ1
+  where
+    char1 = runPosObject CENTER $ posEscCharUpright esc
+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (0.85 * h)
+
+ocharDescender :: (Fractional u, InterpretUnit u) 
+             => EscapedChar -> LocGraphic u
+ocharDescender esc = char1 <> circ1
+  where
+    char1 = fmap abs descender >>= \dy -> 
+            moveStart (go_up dy) $ runPosObject CENTER $ posEscCharUpright esc
+    circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (0.85 * h)
+
+
+ocurrency :: (Floating u, InterpretUnit u) 
+          => u -> LocGraphic u 
+ocurrency ra = scircle ra <> lne <> lnw <> lsw <> lse
+  where
+    ra3 = 0.33 * ra
+    lne = moveStart (go_north_east ra) $ locStraightLine $ go_north_east ra3
+    lnw = moveStart (go_north_west ra) $ locStraightLine $ go_north_west ra3
+    lsw = moveStart (go_south_west ra) $ locStraightLine $ go_south_west ra3
+    lse = moveStart (go_south_east ra) $ locStraightLine $ go_south_east ra3
+
+
+
+empty_box :: (Fractional u, InterpretUnit u) => u -> LocGraphic u
+empty_box w = renderAnaTrail CSTROKE $ rectangleTrail w w
+
+hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u
+hbar u = 
+    renderAnaTrail OSTROKE $ anaCatTrail (go_left $ 0.5 * u) $ trail_right u
+
+vbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u
+vbar u = 
+    renderAnaTrail OSTROKE $ anaCatTrail (go_down $ 0.5 * u) $ trail_up u
+
+dbl_hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u
+dbl_hbar u = line1 <> line2
+  where
+    line1 = moveStart (go_up $ 0.1 * u) $ hbar u
+    line2 = moveStart (go_down $ 0.1 * u) $ hbar u
+
+
+dbl_vbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u
+dbl_vbar u = line1 <> line2
+  where
+    line1 = moveStart (go_left $ 0.1 * u) $ vbar u
+    line2 = moveStart (go_right $ 0.1 * u) $ vbar u
diff --git a/src/Wumpus/Drawing/Chains.hs b/src/Wumpus/Drawing/Chains.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Chains.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Chains
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- Shim module.
---
--- WARNING - very unstable.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Chains
-  (
-    module Wumpus.Drawing.Chains.Base
-  , module Wumpus.Drawing.Chains.Derived
-  
-
-  ) where
-
-
-import Wumpus.Drawing.Chains.Base
-import Wumpus.Drawing.Chains.Derived
diff --git a/src/Wumpus/Drawing/Chains/Base.hs b/src/Wumpus/Drawing/Chains/Base.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Chains/Base.hs
+++ /dev/null
@@ -1,117 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Chains.Base
--- Copyright   :  (c) Stephen Tetley 2010-2011
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- Generate points in an iterated chain.
---
--- \*\* WARNING \*\* - unstable. Names are not so good, also 
--- Wumpus-Basic has a @chain1@ operator...
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Chains.Base
-  (
-
-    Chain
-  , LocChain
-  , unchain
-  , zipchain
-  , zipchainWith
-
-  , unchainTD
-  , zipchainTD
-  , zipchainWithTD
-
-
-
-  ) where
-
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
-
-import Wumpus.Core                              -- package: wumpus-core
-
-
-
--- | A 'Chain' is a list of points. The list is often expected to 
--- be inifinte, but if it was a Stream  it would loose the ability
--- to use list comprehensions.
--- 
-type Chain u = [Point2 u]
-
-
--- | A LocChain is a function from a starting point to a 'Chain'.
--- 
-type LocChain u = Point2 u -> Chain u
-
-
--- | Note - commonly a 'Chain' may be infinite, so it is only 
--- unrolled a finite number of times.
---
-unchain :: Int -> LocGraphic u -> Chain u -> TraceDrawing u ()
-unchain i op chn = go i chn
-  where
-    go n _      | n <= 0 = return ()
-    go _ []              = return () 
-    go n (x:xs)          = draw (op `at` x) >> go (n-1) xs
-
-
-
-
-
-
-zipchain :: [LocGraphic u] -> Chain u -> TraceDrawing u ()
-zipchain (g:gs) (p:ps)   = draw (g `at` p) >> zipchain gs ps
-zipchain _      _        = return ()
-
-
-zipchainWith :: (a -> LocGraphic u) -> [a] -> Chain u -> TraceDrawing u ()
-zipchainWith op xs chn = go xs chn 
-  where
-    go (a:as) (p:ps)   = draw (op a `at` p) >> go as ps
-    go _      _        = return ()
-
-
-
--- | Variant of 'unchain' where the drawing argument is a 
--- @TraceDrawing@ not a @LocGraphic@. 
---
-unchainTD :: Int -> (Point2 u -> TraceDrawing u ()) -> Chain u -> TraceDrawing u ()
-unchainTD i op chn = go i chn
-  where
-    go n _      | n <= 0 = return ()
-    go _ []              = return () 
-    go n (x:xs)          = (op x) >> go (n-1) xs
-
-
-zipchainTD :: [Point2 u -> TraceDrawing u ()] -> Chain u -> TraceDrawing u ()
-zipchainTD (g:gs) (p:ps)   = g p >> zipchainTD gs ps
-zipchainTD _      _        = return ()
-
-
-
-zipchainWithTD :: (a -> Point2 u -> TraceDrawing u ()) -> [a] -> Chain u -> TraceDrawing u ()
-zipchainWithTD op xs chn = go xs chn 
-  where
-    go (a:as) (p:ps)   = op a p >> go as ps
-    go _      _        = return ()
-
-
-
--- Notes - something like TikZ\'s chains could possibly be 
--- achieved with a Reader monad (@local@ initially seems better 
--- for \"state change\" than @set@ as local models a stack). 
---
--- It\'s almost tempting to put point-supply directly in the
--- Trace monad so that TikZ style chaining is transparent.
--- (The argument against is: how compatible this would be with
--- the Turtle monad for example?).
---
-
diff --git a/src/Wumpus/Drawing/Chains/Derived.hs b/src/Wumpus/Drawing/Chains/Derived.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Chains/Derived.hs
+++ /dev/null
@@ -1,126 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Chains.Derived
--- Copyright   :  (c) Stephen Tetley 2010-2011
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- Generate points in an iterated chain.
---
--- WARNING - very unstable.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Chains.Derived
-  (
-    
-    tableDown
-  , tableRight
-
-  , horizontal
-  , vertical
-
-  , horizontals
-  , verticals
-
-  ) where
-
-import Wumpus.Drawing.Chains.Base
-
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
-
---------------------------------------------------------------------------------
--- Tables
-
--- Note - for the minor runtime cost, pairing the row_width and 
--- row_height should make the API more /memorable/...
-
-
--- | 'tableDown' : @ num_rows * (row_width, row_height) -> LocChain @
---
--- The table grows down and right, the implicit initial point is 
--- @top-left@.
---
-tableDown :: Num u => Int -> (u,u) -> LocChain u
-tableDown n (rw,rh) pt = map fn ints
-  where
-    ints = iterate (+1) 0
-    fn i = let (x,y) = i `divMod` n 
-           in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt
-
-
--- | 'tableRight' : @ num_cols * row_width * row_height -> LocChain @
---
--- The table grows right and down, the implicit initial point is 
--- @top-left@.
---
--- This chain is infinite.
---
-tableRight :: Num u => Int -> (u,u) -> LocChain u
-tableRight n (rw,rh) pt = map fn ints
-  where
-    ints = iterate (+1) 0
-    fn i = let (y,x) = i `divMod` n 
-           in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt
-
-
-
-
-
--- | 'horizontal' : @ horizontal_dist -> LocChain @
---
--- The chain grows right by the supplied increment.
---
--- This chain is infinite.
---
--- \*\* WARNING \*\* - name due to be changed. Current name is 
--- too general for this function. 
---
-horizontal :: Num u => u -> LocChain u
-horizontal dx = iterate (displaceH dx)
-
-
--- | 'vertical' : @ vertical_dist -> LocChain @
---
--- The chain grows up by the supplied increment.
---
--- This chain is infinite.
---
--- \*\* WARNING \*\* - name due to be changed. Current name is 
--- too general for this function. 
---
-vertical :: Num u => u -> LocChain u
-vertical dy = iterate (displaceV dy) 
-
-
--- | 'horizontals' : @ [horizontal_dist] -> LocChain @
---
--- This is a @scanl@ successive displacing the start point.
---
--- This chain is finite (for finite input list).
---
--- \*\* WARNING \*\* - name due to be changed. Current name is 
--- too general for this function. 
---
-horizontals :: Num u => [u] -> LocChain u
-horizontals xs = \pt -> scanl (flip displaceH) pt xs 
-
-
--- | 'verticals' : @ [vertical_dist] -> LocChain @
---
--- This is a @scanl@ successive displacing the start point.
---
--- This chain is finite (for finite input list).
---
--- \*\* WARNING \*\* - name due to be changed. Current name is 
--- too general for this function. 
---
-verticals :: Num u => [u] -> LocChain u
-verticals ys = \pt -> scanl (flip displaceV) pt ys
-
-
diff --git a/src/Wumpus/Drawing/Connectors.hs b/src/Wumpus/Drawing/Connectors.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Connectors.hs
@@ -0,0 +1,29 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Connectors
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Shim module for Connectors.
+-- 
+-- \*\* WARNING \*\* - this is due to change...
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Connectors
+  ( 
+    module Wumpus.Drawing.Connectors.Arrowheads
+  , module Wumpus.Drawing.Connectors.Base
+  , module Wumpus.Drawing.Connectors.ConnectorProps
+
+  ) where
+
+import Wumpus.Drawing.Connectors.Arrowheads
+import Wumpus.Drawing.Connectors.Base
+import Wumpus.Drawing.Connectors.ConnectorProps
diff --git a/src/Wumpus/Drawing/Connectors/Arrowheads.hs b/src/Wumpus/Drawing/Connectors/Arrowheads.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Connectors/Arrowheads.hs
@@ -0,0 +1,453 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Connectors.Arrowheads
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Arrowheads.
+--
+-- \*\* WARNING \*\* - naming scheme due to change.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Connectors.Arrowheads
+  (
+
+    tri90
+  , tri60
+  , tri45
+  , otri90
+  , otri60
+  , otri45
+
+  , revtri90
+  , revtri60
+  , revtri45
+  , orevtri90
+  , orevtri60
+  , orevtri45
+
+  , barb90
+  , barb60
+  , barb45
+  , revbarb90
+  , revbarb60
+  , revbarb45
+
+  , perp
+  , bracket
+
+  , diskTip
+  , odiskTip
+
+  , squareTip
+  , osquareTip
+
+  , diamondTip
+  , odiamondTip
+
+  , diamondWideTip
+  , odiamondWideTip
+
+  , curveTip
+  , revcurveTip
+
+  ) where
+
+
+import Wumpus.Drawing.Basis.InclineTrails
+import Wumpus.Drawing.Connectors.Base
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+-- import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+import Data.Monoid
+
+
+
+
+
+
+-- | Arrow tips are drawn with a solid line even if the connector
+-- line is dashed (tips also override round corners)
+
+solid_stroke_tip :: DrawingContextF
+solid_stroke_tip = solid_line -- reset_drawing_metrics
+
+
+
+type TrailGen = Radian -> AnaTrail En
+
+
+fillTrailTip :: TrailGen -> LocThetaGraphic En
+fillTrailTip gen_pt = 
+    localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta ->
+      supplyLoc pt $ renderAnaTrail CFILL $ gen_pt theta
+
+closedTrailTip :: TrailGen -> LocThetaGraphic En
+closedTrailTip gen_pt = 
+    localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->
+      supplyLoc pt $ renderAnaTrail CSTROKE $ gen_pt theta
+
+
+openTrailTip :: TrailGen -> LocThetaGraphic En
+openTrailTip gen_pt = 
+    localize solid_stroke_tip $ promoteLocTheta $ \pt theta ->
+      supplyLoc pt $ renderAnaTrail OSTROKE $ gen_pt theta
+
+
+
+
+
+-- | All three lines are stated.
+--
+closedTriTrail :: Radian -> TrailGen
+closedTriTrail ang = \theta ->
+    modifyAna (\v1 -> v1 ^+^ theta_left 1 theta) $
+      incline_triangle ang (avec theta 1)
+
+
+
+filledTri :: Radian -> ArrowTip
+filledTri ang = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = fillTrailTip $ closedTriTrail ang
+      }
+
+--
+-- DESIGN NOTE 
+--
+-- Naming scheme should change.
+--
+-- The \"wumpus way\" of naming seems to be coalescing to favour 
+-- underscore separated names rather than camelCase for /data/ 
+-- objects. 
+--
+-- These data objects can still be functions but they are 
+-- distinguished by drawing differently - roughly speaking
+-- the difference between a barb tip and a triangle tip is 
+-- \"what they draw not what they mean\".
+--
+
+-- | Filled triangle - apex is 90 deg.
+--
+tri90 :: ArrowTip
+tri90 = filledTri ang90
+
+-- | Filled triangle - apex is 60 deg.
+--
+tri60 :: ArrowTip
+tri60 = filledTri ang60
+
+-- | Filled triangle - apex is 45 deg.
+--
+tri45 :: ArrowTip
+tri45 = filledTri ang45
+
+
+strokedClosedTri :: Radian -> ArrowTip
+strokedClosedTri ang = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = closedTrailTip $ closedTriTrail ang
+      }
+
+
+otri90 :: ArrowTip
+otri90 = strokedClosedTri ang90
+
+otri60 :: ArrowTip
+otri60 = strokedClosedTri ang60
+
+otri45 :: ArrowTip
+otri45 = strokedClosedTri ang45
+
+
+-- | All three lines are stated.
+--
+revClosedTriSpec :: Radian -> TrailGen
+revClosedTriSpec ang = \theta -> incline_triangle ang (avec theta (-1))
+
+
+filledRevTri :: Radian -> ArrowTip
+filledRevTri ang = 
+    ArrowTip
+      { retract_distance = 0.5
+      , tip_half_len     = 0.5
+      , tip_deco         = fillTrailTip $ revClosedTriSpec ang
+      }
+
+
+revtri90 :: ArrowTip
+revtri90 = filledRevTri ang90
+
+revtri60 :: ArrowTip
+revtri60 = filledRevTri ang60
+
+revtri45 :: ArrowTip
+revtri45 = filledRevTri ang45
+
+
+strokedClosedRevTri :: Radian -> ArrowTip
+strokedClosedRevTri ang = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = closedTrailTip $ revClosedTriSpec ang
+      }
+
+orevtri90 :: ArrowTip
+orevtri90 = strokedClosedRevTri ang90
+
+orevtri60 :: ArrowTip
+orevtri60 = strokedClosedRevTri ang60
+
+orevtri45 :: ArrowTip
+orevtri45 = strokedClosedRevTri ang45
+
+
+barbSpec :: Radian -> TrailGen
+barbSpec ang = \theta -> 
+    modifyAna (\v1 -> v1 ^+^ avec theta (-1)) $ incline_barb ang (avec theta 1)
+
+
+strokedBarb :: Radian -> ArrowTip
+strokedBarb ang = 
+    ArrowTip
+      { retract_distance = 0
+      , tip_half_len     = 0.5
+      , tip_deco         = openTrailTip $ barbSpec ang
+      }
+
+barb90 :: ArrowTip
+barb90 = strokedBarb ang90
+
+barb60 :: ArrowTip
+barb60 = strokedBarb ang60
+
+barb45 :: ArrowTip
+barb45 = strokedBarb ang45
+
+
+revBarbSpec :: Radian -> TrailGen
+revBarbSpec ang = \theta -> incline_barb ang (avec theta (-1))
+
+strokedRevBarb :: Radian -> ArrowTip
+strokedRevBarb ang = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = openTrailTip $ revBarbSpec ang 
+      }
+
+
+revbarb90 :: ArrowTip
+revbarb90 = strokedRevBarb ang90
+
+revbarb60 :: ArrowTip
+revbarb60 = strokedRevBarb ang60
+
+revbarb45 :: ArrowTip
+revbarb45 = strokedRevBarb ang45
+
+
+perpSpec :: TrailGen
+perpSpec ang = 
+    anaCatTrail (theta_up 0.5 ang) $ trail_theta_down 1 ang
+
+perp :: ArrowTip
+perp = 
+    ArrowTip
+      { retract_distance = 0
+      , tip_half_len     = 0
+      , tip_deco         = openTrailTip perpSpec
+      }
+
+
+bracketSpec :: TrailGen
+bracketSpec ang = anaCatTrail (orthoVec (-0.5) 0.5 ang) catt
+  where
+    catt = mconcat [ trail_theta_right 0.5 ang
+                   , trail_theta_down  1.0 ang
+                   , trail_theta_left  0.5 ang 
+                   ]
+
+
+bracket :: ArrowTip
+bracket = 
+    ArrowTip
+      { retract_distance = 0.0
+      , tip_half_len     = 0.5
+      , tip_deco         = openTrailTip bracketSpec
+      }
+
+diskBody :: DrawMode -> Radian -> LocGraphic En
+diskBody mode theta = 
+    localize fill_use_stroke_colour $ moveStart vback $ dcDisk mode 0.5
+  where
+    vback = theta_left 0.5 theta
+
+diskTip :: ArrowTip
+diskTip = 
+    ArrowTip
+      { retract_distance = 0.5
+      , tip_half_len     = 0.5
+      , tip_deco         = promoteLocTheta $ \pt theta -> 
+                             diskBody DRAW_FILL theta `at` pt
+      }
+
+
+odiskTip :: ArrowTip
+odiskTip = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = promoteLocTheta $ \pt theta -> 
+                             diskBody DRAW_STROKE theta `at` pt
+      }
+
+
+-- | Note - need to draw square East-West rather than West-East
+-- hence the base_width is negative.
+--
+squareSpec :: TrailGen
+squareSpec theta = incline_square $ avec theta (-1)
+
+
+squareTip :: ArrowTip
+squareTip = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = fillTrailTip squareSpec
+      }
+    
+
+osquareTip :: ArrowTip
+osquareTip = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = closedTrailTip squareSpec
+      }
+
+
+-- | squareSpec:
+--
+-- > 
+-- >       a
+-- >     /   \
+-- > ...w..v..o
+-- >     \   / 
+-- >       b
+--
+diamondSpec :: En -> TrailGen
+diamondSpec w theta = incline_diamond 1 $ avec theta (-w)
+
+diamondTip :: ArrowTip
+diamondTip = 
+    ArrowTip
+      { retract_distance = 0.5
+      , tip_half_len     = 0.5
+      , tip_deco         = fillTrailTip $ diamondSpec 1
+      }
+
+odiamondTip :: ArrowTip
+odiamondTip = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = closedTrailTip $ diamondSpec 1
+      }
+
+
+diamondWideTip :: ArrowTip
+diamondWideTip = 
+    ArrowTip
+      { retract_distance = 1.0
+      , tip_half_len     = 1.0
+      , tip_deco         = fillTrailTip $ diamondSpec 2
+      }
+
+odiamondWideTip :: ArrowTip
+odiamondWideTip = 
+    ArrowTip
+      { retract_distance = 2.0
+      , tip_half_len     = 1.0
+      , tip_deco         = closedTrailTip $ diamondSpec 2
+      }
+
+
+curveTipSpec :: TrailGen
+curveTipSpec theta = 
+    anaCatTrail dv $ vectrapCCW v1 <> vectrapCCW v2
+  where
+    dv  = orthoVec (-1.0)   0.75  theta     -- back and up
+    v1  = orthoVec   1.0  (-0.75) theta     -- fwd and down
+    v2  = orthoVec (-1.0) (-0.75) theta     -- back and down
+
+
+vectrapCW :: (Real u, Floating u) => Vec2 u -> CatTrail u
+vectrapCW v1 = trapCurve CW w h quarter_pi ang
+  where
+    w   = vlength v1
+    h   = w / 4
+    ang = vdirection v1
+
+
+vectrapCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u
+vectrapCCW v1 = trapCurve CCW w h quarter_pi ang
+  where
+    w   = vlength v1
+    h   = w / 4
+    ang = vdirection v1
+
+
+curveTip :: ArrowTip
+curveTip = 
+    ArrowTip
+      { retract_distance = 0
+      , tip_half_len     = 0.5
+      , tip_deco         = body
+      }
+  where
+    body = localize (cap_round . join_round . solid_stroke_tip) $ 
+             openTrailTip curveTipSpec
+
+
+
+curveTipRevSpec :: TrailGen
+curveTipRevSpec theta = 
+    anaCatTrail dv $ vectrapCW v1 <> vectrapCW v2
+  where
+    dv  = orthoVec   0.0    0.75  theta     -- just up
+    v1  = orthoVec (-1.0) (-0.75) theta     -- back and down
+    v2  = orthoVec   1.0  (-0.75) theta     -- fwd and down
+
+
+
+revcurveTip :: ArrowTip
+revcurveTip = 
+    ArrowTip
+      { retract_distance = 1
+      , tip_half_len     = 0.5
+      , tip_deco         = body
+      }
+  where
+    body = localize (cap_round . join_round . solid_stroke_tip) $ 
+             openTrailTip curveTipRevSpec
+
+
diff --git a/src/Wumpus/Drawing/Connectors/Base.hs b/src/Wumpus/Drawing/Connectors/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Connectors/Base.hs
@@ -0,0 +1,168 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Connectors.Base
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Connectors...
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Connectors.Base
+  ( 
+
+
+    ConnectorPathQuery
+  , SpacingProjection
+
+  , ArrowTip(..)
+  , ArrowConnector
+
+  , ConnectorConfig(..)
+  , ConnectorPathSpec(..)
+  , renderConnectorConfig
+
+  , arrowDecoratePath
+
+  , leftArrowConnector
+  , rightArrowConnector
+  , uniformArrowConnector
+
+  ) where
+
+import Wumpus.Drawing.Connectors.ConnectorProps
+import Wumpus.Drawing.Paths
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.Monoid
+
+
+
+
+type SpacingProjection u = 
+      ConnectorProps -> Point2 u -> Point2 u -> Query u (Point2 u)
+
+
+
+-- | The type of Connectors - a query from start and end point 
+-- returning an AbsPath.
+--
+type ConnectorPathQuery u = ConnectorQuery u (AbsPath u)
+
+
+
+-- | Arrowhead /algorithm/ - the components of an arrowhead.
+-- 
+-- Retract distance is rather vague - depending on the arrowhead
+-- it may represent a flush join between the path and the tip
+-- or a join that uses the z-order (tip over path) to create the 
+-- join.
+--
+-- \*\* WARNING \*\* - pending revision...
+--
+data ArrowTip = ArrowTip
+      { retract_distance :: En
+      , tip_half_len     :: En
+      , tip_deco         :: LocThetaGraphic En
+      }
+
+
+newtype ConnectorPathSpec u = ConnectorPathSpec { 
+      getConnectorPathSpec :: ConnectorProps -> ConnectorPathQuery u }
+
+-- | total_path is the path before accounting for arrow 
+-- retract distances.
+--
+data ConnectorConfig u = ConnectorConfig
+      { conn_arrowl     :: Maybe ArrowTip
+      , conn_arrowr     :: Maybe ArrowTip
+      , conn_path_spec  :: ConnectorPathSpec u 
+      }
+
+
+
+-- Ideally there should be a plus operation to combine tips 
+-- allowing double tips.
+-- 
+
+type ArrowConnector u = ConnectorImage u (AbsPath u)
+
+
+
+
+-- | NOTE - the prefix /render/ needs (re-) consideration...
+-- 
+-- If it is a good prefix other functions e.g. drawPath should 
+-- use render rather than draw.
+--
+renderConnectorConfig :: (Real u, Floating u, InterpretUnit u)
+                      => ConnectorProps
+                      -> ConnectorConfig u
+                      -> ConnectorImage u (AbsPath u)
+renderConnectorConfig props (ConnectorConfig mbl mbr pspec) = 
+    promoteConn $ \src dst -> 
+      liftQuery (qapplyConn path_spec src dst) >>= \tot_path -> 
+      connectorSrcSpace props >>= \sepl -> 
+      connectorDstSpace props >>= \sepr ->
+      arrowDecoratePath mbl mbr $ shortenL sepl $ shortenR sepr tot_path
+  where
+    path_spec = getConnectorPathSpec pspec props
+
+
+
+arrowDecoratePath :: (Real u, Floating u, InterpretUnit u) 
+                  => Maybe ArrowTip -> Maybe ArrowTip -> (AbsPath u) 
+                  -> Image u (AbsPath u)
+arrowDecoratePath mbl mbr initial_path = 
+      uconvertCtx1 (maybe 0 retract_distance mbl) >>= \retl -> 
+      uconvertCtx1 (maybe 0 retract_distance mbr) >>= \retr -> 
+      let (p1,theta1)  = atstart initial_path
+          (p2,theta2)  = atend   initial_path
+          new_path     = shortenL retl $ shortenR retr initial_path
+          arrl         = mbTip p1 (pi + theta1) mbl
+          arrr         = mbTip p2 theta2 mbr
+      in replaceAns initial_path $ 
+           decorate ZABOVE (renderPath OSTROKE new_path) (arrl `mappend` arrr)
+  where
+    mbTip pt ang = maybe emptyImage (supplyLocTheta pt ang . uconvF . tip_deco)
+
+
+-- | Shorthand...
+--
+leftArrowConnector :: (Real u, Floating u, InterpretUnit u)
+                    => ConnectorProps -> ConnectorPathSpec u -> ArrowTip
+                    -> ConnectorImage u (AbsPath u)
+leftArrowConnector props cpath tip = renderConnectorConfig props cfg 
+  where
+    cfg = ConnectorConfig { conn_arrowl    = Just tip 
+                          , conn_arrowr    = Nothing
+                          , conn_path_spec = cpath }
+
+rightArrowConnector :: (Real u, Floating u, InterpretUnit u)
+                    => ConnectorProps -> ConnectorPathSpec u -> ArrowTip
+                    -> ConnectorImage u (AbsPath u)
+rightArrowConnector props cpath tip = renderConnectorConfig props cfg 
+  where
+    cfg = ConnectorConfig { conn_arrowl    = Nothing
+                          , conn_arrowr    = Just tip
+                          , conn_path_spec = cpath }
+    
+uniformArrowConnector :: (Real u, Floating u, InterpretUnit u)
+                    => ConnectorProps -> ConnectorPathSpec u -> ArrowTip
+                    -> ConnectorImage u (AbsPath u)
+uniformArrowConnector props cpath tip = renderConnectorConfig props cfg 
+  where
+    cfg = ConnectorConfig { conn_arrowl    = Just tip
+                          , conn_arrowr    = Just tip
+                          , conn_path_spec = cpath }
+    
+
diff --git a/src/Wumpus/Drawing/Connectors/BoxConnectors.hs b/src/Wumpus/Drawing/Connectors/BoxConnectors.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Connectors/BoxConnectors.hs
@@ -0,0 +1,116 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Connectors.BoxConnectors
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Box connectors
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Connectors.BoxConnectors
+  ( 
+    ConnectorBox
+  , ConnectorBoxSpec(..)
+  , renderConnectorBoxSpec
+
+  , conn_box
+  , conn_tube
+  , conn_chamf_box 
+
+
+  ) where
+
+import Wumpus.Drawing.Basis.InclineTrails
+import Wumpus.Drawing.Connectors.ConnectorProps
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.VectorSpace                         -- package: vector-space
+
+
+-- NOTE - boxes seem to only support stroke otherwise
+-- they would obliterate what they connect.
+
+
+
+-- | The type of BoxConnectors - a query from start and end point 
+-- to a Path. 
+-- 
+-- Note - unlike a @Connector@, a BoxConnnector is expected to be 
+-- closed, then filled, stroked or bordered.
+--
+type ConnectorBox u = ConnectorGraphic u
+
+newtype ConnectorBoxSpec u = ConnectorBoxSpec { 
+      getConnectorBoxSpec :: ConnectorProps -> ConnectorBox u }
+
+
+renderConnectorBoxSpec :: (Real u, Floating u, InterpretUnit u)
+                       => ConnectorProps
+                       -> ConnectorBoxSpec u
+                       -> ConnectorBox u
+renderConnectorBoxSpec props spec = 
+    getConnectorBoxSpec spec props
+
+
+
+
+
+--
+-- DESIGN NOTE - boxes (probably) should not use source and dest
+-- separators.
+--
+
+boxConnector :: (Floating u, Ord u, InterpretUnit u) 
+             => (ConnectorProps -> Point2 u -> Point2 u -> Image u a) 
+             -> ConnectorBoxSpec u
+boxConnector mf = ConnectorBoxSpec $ \props -> 
+    promoteConn $ \p0 p1 -> ignoreAns $ mf props p0 p1 
+
+
+adaptAnaTrail :: (Real u, Floating u, Ord u, InterpretUnit u) 
+              => (u -> Vec2 u -> AnaTrail u) 
+              -> ConnectorBoxSpec u
+adaptAnaTrail fn = boxConnector $ \props p0 p1 ->
+    connectorBoxHalfSize props >>= \sz ->
+    let v0    = pvec p0 p1 
+        v1    = v0 ^+^ avec (vdirection v0) (2*sz)
+        vinit = avec (vdirection v0) (-sz)
+    in applyLoc (renderAnaTrail CSTROKE $ fn sz v1) (displace vinit p0)
+    
+
+
+-- | Draw a stroked, rectangular box around the connector points.
+--
+-- The rectangle will be inclined to the line.
+--
+conn_box :: (Real u, Floating u, InterpretUnit u) 
+        => ConnectorBoxSpec u
+conn_box = adaptAnaTrail (\sz -> incline_rect (2 * sz))
+
+
+-- | Draw a stroked, tube around the connector points.
+--
+-- The tube will be inclined to the line.
+--
+conn_tube :: (Real u, Floating u, InterpretUnit u) 
+         => ConnectorBoxSpec u
+conn_tube = adaptAnaTrail (\sz -> incline_tube (2 * sz))
+
+-- | Draw a stroked, chamfered box around the connector points.
+--
+-- The tube will be inclined to the line.
+--
+conn_chamf_box :: (Real u, Floating u, InterpretUnit u) 
+               => ConnectorBoxSpec u
+conn_chamf_box = adaptAnaTrail (\sz -> incline_chamf_rect (2 * sz))
+
diff --git a/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs b/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs
@@ -0,0 +1,563 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Connectors.ConnectorPaths
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Primitive connectors
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Connectors.ConnectorPaths
+  ( 
+
+    conn_line
+
+  , conna_arc
+  , connb_arc
+
+  , conn_hdiagh
+  , conn_vdiagv
+  
+  , conn_diagh
+  , conn_diagv
+
+  , conn_hdiag
+  , conn_vdiag
+
+  , conna_bar
+  , connb_bar
+  
+  , conna_flam
+  , connb_flam
+
+  , conna_orthohbar
+  , connb_orthohbar
+
+  , conna_orthovbar
+  , connb_orthovbar
+
+  , conna_right
+  , connb_right
+
+  , conn_hrr
+  , conn_rrh
+  , conn_vrr
+  , conn_rrv
+
+  , conna_loop
+  , connb_loop
+
+  , conn_hbezier
+  , conn_vbezier
+
+  ) where
+
+import Wumpus.Drawing.Basis.InclineTrails
+import Wumpus.Drawing.Connectors.Base
+import Wumpus.Drawing.Connectors.ConnectorProps
+import Wumpus.Drawing.Paths
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Control.Applicative
+
+
+
+
+-- | Build as Path as a CatTrail between two points.
+--
+catConnector :: (Floating u, Ord u, InterpretUnit u, Tolerance u) 
+             => (ConnectorProps -> Point2 u -> Point2 u -> Query u (CatTrail u)) 
+             -> ConnectorPathSpec u
+catConnector mf = ConnectorPathSpec $ \props -> 
+    qpromoteConn $ \p0 p1 -> catTrailPath p0 <$> mf props p0 p1 
+
+
+horizontally :: (Real u, Floating u) 
+             => (Vec2 u -> a) -> (Vec2 u -> a) -> Vec2 u -> a
+horizontally rightf leftf v1 = 
+    case horizontalDirection $ vdirection v1 of
+      RIGHTWARDS -> rightf v1
+      LEFTWARDS  -> leftf v1
+
+-- | Straight line connector.
+--
+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ConnectorPathSpec u
+conn_line = catConnector $ \_ p0 p1 -> pure $ catline $ pvec p0 p1
+
+
+
+
+-- | Form an arc connector.
+-- 
+-- If the conn_arc_angle in the Drawing context is positive the arc
+-- will be formed /above/ the straight line joining the points. 
+-- If the angle is negative it will be drawn below. 
+-- 
+-- The notion of /above/ is respective to the line direction, of 
+-- course.
+-- 
+-- TODO - above and below versions...
+--
+conna_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) 
+          => ConnectorPathSpec u
+conna_arc = connArcBody (vtriCurve CW) (vtriCurve CCW)
+
+-- | Below version of 'conna_arc'.
+--
+connb_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) 
+          => ConnectorPathSpec u
+connb_arc = connArcBody (vtriCurve CCW) (vtriCurve CW)
+
+
+connArcBody :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) 
+            => (u -> Vec2 u -> CatTrail u) 
+            -> (u -> Vec2 u -> CatTrail u) 
+            -> ConnectorPathSpec u
+connArcBody rightf leftf = catConnector $ \props p0 p1 -> 
+    let arc_ang = conn_arc_ang props 
+        v1      = pvec p0 p1
+        h       = (0.5 * vlength v1) * (fromRadian $ tan arc_ang)
+    in return $ horizontally (rightf h) (leftf h) v1 
+
+
+
+
+-- | Horizontal-diagonal-horizontal connector.
+--
+-- >      --@
+-- >     /
+-- >  o--
+-- 
+-- Horizontal /arms/ are drawn from the start and end points, a
+-- diagonal segment joins the arms. 
+-- 
+conn_hdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
+           => ConnectorPathSpec u
+conn_hdiagh = catConnector $ \props p0 p1 -> 
+    connectorLegs props >>= \(src_leg, dst_leg) ->
+    return $ trail_hdiagh src_leg dst_leg $ pvec p0 p1
+
+
+-- probably want trail_hdiagh as a library function
+
+-- | Vertical-diagonal-vertical connector.
+--
+-- >  @
+-- >  |
+-- >   \
+-- >    |
+-- >    o
+--
+-- Vertical /arms/ are drawn from the start and end points, a
+-- diagonal segment joins the arms. 
+-- 
+conn_vdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
+            => ConnectorPathSpec u
+conn_vdiagv = catConnector $ \props p0 p1 -> 
+    connectorLegs props >>= \(src_leg, dst_leg) ->
+    return $ trail_vdiagv src_leg dst_leg $ pvec p0 p1
+
+
+-- | Diagonal-horizontal connector.
+--
+-- >    --@
+-- >   /
+-- >  o
+-- 
+-- Restricted variant of 'hconndiag' - a diagonal segment is drawn 
+-- from the start point joining a horizontal arm drawn from the 
+-- end point
+-- 
+conn_diagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
+           => ConnectorPathSpec u
+conn_diagh = catConnector $ \props p0 p1 -> 
+    connectorLegs props >>= \(_, dst_leg) ->
+    return $ trail_diagh dst_leg $ pvec p0 p1
+
+
+-- | Diagonal-vertical connector.
+--
+-- >    @
+-- >    |
+-- >   /
+-- >  o
+--
+-- Restricted variant of 'vconndiag' - a diagonal segment is drawn 
+-- from the start point joining a vertical arm drawn from the end 
+-- point.
+-- 
+conn_diagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
+           => ConnectorPathSpec u
+conn_diagv = catConnector $ \props p0 p1 -> 
+    connectorLegs props >>= \(_, dst_leg) ->
+    return $ trail_diagv dst_leg $ pvec p0 p1
+
+
+
+-- | Horizontal-diagonal connector.
+--
+-- >      @
+-- >     /
+-- >  o--
+--
+-- Restricted variant of 'hconndiag' - a horizontal arm is drawn
+-- from the start point joining a diagonal segment drawn from the 
+-- end point.
+-- 
+conn_hdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
+           => ConnectorPathSpec u
+conn_hdiag = catConnector $ \props p0 p1 -> 
+    connectorLegs props >>= \(src_leg, _) ->
+    return $ trail_hdiag src_leg $ pvec p0 p1
+
+
+-- | Vertical-diagonal connector.
+--
+-- >    @
+-- >   /
+-- >  |
+-- >  o
+--
+-- Restricted variant of 'vconndiag' - a horizontal arm is drawn
+-- from the start point joining a vertical segment drawn from the 
+-- end point.
+-- 
+conn_vdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
+           => ConnectorPathSpec u
+conn_vdiag = catConnector $ \props p0 p1 -> 
+    connectorLegs props >>= \(src_leg, _) ->
+    return $ trail_vdiag src_leg $ pvec p0 p1
+
+
+
+-- DESIGN NOTE - should the concept of /above/ and /below/ use 
+-- ClockDirection instead?
+--
+
+
+-- | Bar connector.
+--
+-- >  ,----, 
+-- >  |    |
+-- >  o    @  
+--
+-- The bar is drawn /above/ the points.
+--
+conna_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+          => ConnectorPathSpec u
+conna_bar = connBarBody (trail_perp_bar2 CW) (trail_perp_bar2 CCW)
+
+
+-- | Bar connector.
+-- 
+-- >  o    @ 
+-- >  |    |
+-- >  '----'  
+--
+-- The bar is drawn /below/ the points.
+--
+connb_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+          => ConnectorPathSpec u
+connb_bar = connBarBody (trail_perp_bar2 CCW) (trail_perp_bar2 CW)
+
+
+connBarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+            => (u -> u -> Vec2 u -> CatTrail u) 
+            -> (u -> u -> Vec2 u -> CatTrail u) 
+            -> ConnectorPathSpec u
+connBarBody rightf leftf = catConnector $ \props p0 p1 ->
+    connectorLegs props >>= \(src, dst) ->
+    return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1
+
+
+
+-- | /Flam/ connector.
+--
+-- >    ,- '
+-- >  ,-   | 
+-- >  |    |
+-- >  o    @  
+--
+-- The bar is drawn /above/ the points.
+--
+conna_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+           => ConnectorPathSpec u
+conna_flam = connFlamBody (trail_vflam CW) (trail_vflam CCW)
+
+-- | /Flam/ connector - bleow.
+--
+connb_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+         => ConnectorPathSpec u
+connb_flam = connFlamBody (trail_vflam CCW) (trail_vflam CW)  
+
+
+connFlamBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+             => (u -> u -> Vec2 u -> CatTrail u) 
+             -> (u -> u -> Vec2 u -> CatTrail u) 
+             -> ConnectorPathSpec u
+connFlamBody rightf leftf = catConnector $ \props p0 p1 ->
+    connectorLegs props >>= \(src,dst) ->
+    return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1
+
+
+
+
+-- | Bar connector - always orthonormal .
+--
+-- >  
+-- >  ,----, 
+-- >  |    |
+-- >  o    @  
+--
+-- The bar is drawn /above/ the points.
+--
+conna_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+                => ConnectorPathSpec u
+conna_orthohbar = connOrthobarBody (trail_ortho_hbar CW) (trail_ortho_hbar CCW)
+
+-- | Bar connector orthonormal - below.
+--
+connb_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+                => ConnectorPathSpec u
+connb_orthohbar = connOrthobarBody (trail_ortho_hbar CCW) (trail_ortho_hbar CW)
+
+
+
+connOrthobarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+                 => (u -> Vec2 u -> CatTrail u)
+                 -> (u -> Vec2 u -> CatTrail u)
+                 -> ConnectorPathSpec u
+connOrthobarBody rightf leftf = catConnector $ \props p0 p1 ->
+    connectorLoopSize props >>= \looph ->
+    return $ horizontally (rightf looph) (leftf looph) $ pvec p0 p1
+
+
+-- | Bar connector - always orthonormal.
+--
+-- >  
+-- >  ,--- o 
+-- >  |   
+-- >  '--- @  
+-- > 
+--
+-- The bar is drawn /left/ of the points.
+--
+conna_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+                => ConnectorPathSpec u
+conna_orthovbar = connOrthobarBody (trail_ortho_vbar CW) (trail_ortho_vbar CCW)
+
+-- | Bar connector orthonormal - right of the points.
+--
+connb_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+                => ConnectorPathSpec u
+connb_orthovbar = connOrthobarBody (trail_ortho_vbar CCW) (trail_ortho_vbar CW)
+
+
+
+-- | Right angle connector.
+-- 
+-- >  ,----@ 
+-- >  | 
+-- >  o   
+--
+-- The bar is drawn /above/ the points.
+--
+conna_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+            => ConnectorPathSpec u
+conna_right = catConnector $ \_ p0 p1 ->
+    return $ trail_vright $ pvec p0 p1
+
+
+-- | Right angle connector.
+-- 
+-- >       @ 
+-- >       |
+-- >  o----'  
+--
+-- The bar is drawn /below/ the points.
+--
+connb_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+            => ConnectorPathSpec u
+connb_right = catConnector $ \_ p0 p1 -> 
+    return $ trail_hright $ pvec p0 p1
+
+
+
+
+-- | Connector with two horizontal segments and a joining 
+-- vertical segment.
+--
+-- >       ,--@
+-- >       |
+-- >  o----'  
+--
+-- The length of the first horizontal segment is the source arm 
+-- length. The length of the final segment is the remaining 
+-- horizontal distance. 
+--
+conn_hrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+         => ConnectorPathSpec u
+conn_hrr = catConnector $ \props p0 p1 ->
+    connectorLegs props >>= \(src_leg,_) ->
+    return $ trail_hrr src_leg $ pvec p0 p1
+
+
+-- | Connector with two horizontal segements and a joining 
+-- vertical segment.
+--
+-- >     ,----@
+-- >     |
+-- >  o--'  
+--
+-- The length of the final horizontal segment is the destination 
+-- arm length. The length of the initial segment is the remaining
+-- horizontal distance. 
+--
+conn_rrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+         => ConnectorPathSpec u
+conn_rrh = catConnector $ \props p0 p1 ->
+    connectorLegs props >>= \(_,dst_leg) ->
+    return $ trail_rrh dst_leg $ pvec p0 p1
+
+
+-- | Connector with two right angles...
+--
+-- >       @
+-- >       |
+-- >  ,----'
+-- >  |
+-- >  o  
+--
+-- The length of the first vertical segment is the source arm 
+-- length. The length of the final segment is the remaining 
+-- vertical distance. 
+--
+conn_vrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+         => ConnectorPathSpec u
+conn_vrr = catConnector $ \props p0 p1 ->
+    connectorLegs props >>= \(src_leg,_) ->
+    return $ trail_vrr src_leg $ pvec p0 p1
+
+
+-- | Connector with two right angles...
+--
+-- >       @
+-- >       |
+-- >  ,----'
+-- >  |
+-- >  o  
+--
+-- The length of the final vertical segment is the destination 
+-- arm length. The length of the initial segment is the remaining
+-- vertical distance. 
+--
+conn_rrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+         => ConnectorPathSpec u
+conn_rrv = catConnector $ \props p0 p1 ->
+    connectorLegs props >>= \(_,dst_leg) ->
+    return $ trail_rrv dst_leg $ pvec p0 p1
+
+
+
+-- | Loop connector.
+--
+-- >  ,---------, 
+-- >  |         |
+-- >  '-o    @--'
+--
+-- The loop is drawn /above/ the points.
+--
+conna_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+           => ConnectorPathSpec u
+conna_loop = connLoopBody (trail_rect_loop CW) (trail_rect_loop CCW)
+  
+
+-- | Loop connector.
+--
+-- >  ,-o    @--, 
+-- >  |         |
+-- >  '---------'
+--
+-- The loop is drawn /below/ the points.
+--
+connb_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+           => ConnectorPathSpec u
+connb_loop = connLoopBody (trail_rect_loop CCW) (trail_rect_loop CW)
+
+
+connLoopBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+             => (u -> u -> u -> Vec2 u -> CatTrail u) 
+             -> (u -> u -> u -> Vec2 u -> CatTrail u) 
+             -> ConnectorPathSpec u
+connLoopBody rightf leftf = catConnector $ \props p0 p1 -> 
+    connectorLegs props     >>= \(src,dst) ->
+    connectorLoopSize props >>= \looph ->
+    return $ horizontally (rightf src dst looph) (leftf src dst looph) 
+           $ pvec p0 p1
+
+
+
+-- | Bezier curve connector - the control points are positioned 
+-- horizontally respective to the source and dest.
+--
+-- >  *--@ 
+-- >    .  
+-- >   . 
+-- >  o--*  
+--
+-- Note - the source and dest arm lengths are doubled, generally 
+-- this produces nicer curves.
+-- 
+conn_hbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
+             => ConnectorPathSpec u
+conn_hbezier = ConnectorPathSpec $ \props -> 
+    qpromoteConn $ \p0 p1 -> 
+    fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,dst_arm) ->
+    case horizontalDirection $ vdirection $ pvec p0 p1 of
+      RIGHTWARDS -> right p0 p1 src_arm dst_arm
+      _          -> left  p0 p1 src_arm dst_arm
+  where
+    right p0 p1 h0 h1 = return $ curve1 p0 (p0 .+^ hvec h0) (p1 .-^ hvec h1) p1
+
+    left  p0 p1 h0 h1 = return $ curve1 p0 (p0 .-^ hvec h0) (p1 .+^ hvec h1) p1
+
+
+-- | Bezier curve connector - the control points are positioned 
+-- vertically respective to the source and dest.
+--
+-- >        @ 
+-- >       .|  
+-- >  *  .  *
+-- >  |.
+-- >  o
+--
+-- Note - the source and dest arm lengths are doubled, generally 
+-- this produces nicer curves.
+--
+conn_vbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
+             => ConnectorPathSpec u
+conn_vbezier = ConnectorPathSpec $ \props -> 
+    qpromoteConn $ \p0 p1 -> 
+    fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,dst_arm) ->
+      case verticalDirection $ vdirection $ pvec p0 p1 of
+        UPWARDS -> up   p0 p1 src_arm dst_arm
+        _       -> down p0 p1 src_arm dst_arm
+  where
+    up   p0 p1 v0 v1 = return $ curve1 p0 (p0 .+^ vvec v0) (p1 .-^ vvec v1) p1
+    down p0 p1 v0 v1 = return $ curve1 p0 (p0 .-^ vvec v0) (p1 .+^ vvec v1) p1
+
+
+
diff --git a/src/Wumpus/Drawing/Connectors/ConnectorProps.hs b/src/Wumpus/Drawing/Connectors/ConnectorProps.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Connectors/ConnectorProps.hs
@@ -0,0 +1,158 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Connectors.ConnectorProps
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Connectors...
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Connectors.ConnectorProps
+  ( 
+
+    -- * Data types
+    ConnectorProps(..)
+  , default_connector_props
+
+  -- * Queries
+  , connectorSrcSpace
+  , connectorDstSpace
+  , connectorArms
+  , connectorLegs
+  , connectorLoopSize
+  , connectorBoxHalfSize 
+
+  ) where
+
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Control.Applicative
+
+
+
+-- | ConnectorProps control the drawing of connectors in 
+-- Wumpus-Drawing.
+--
+-- > conn_src_space     :: Em
+-- > conn_dst_space     :: Em
+--
+-- Source and destination offsets - these offset the drawing of
+-- the connector perpendicular to the direction of line formed 
+-- between the connector points (a positive offset is drawn above, 
+-- a negative offset below). The main use of offsets is to draw
+-- parallel line connectors.
+--
+-- > conn_arc_ang       :: Radian 
+--
+-- Control the /bend/ of an arc connector.
+-- 
+-- > conn_src_arm       :: Em
+-- > conn_dst_arm       :: Em 
+--
+-- Control the /arm/ length of a jointed connector - arms are the 
+-- initial segments of the connector. 
+--
+-- > conn_loop_size     :: Em
+--
+-- Control the /height/ of a loop connector. 
+--
+-- > conn_box_halfsize  :: Em
+-- 
+-- Control the size of a connector box. Connector boxes are 
+-- drawn with the exterior lines projected out from the connector
+-- points a halfsize above and below.
+-- 
+data ConnectorProps = ConnectorProps
+      { conn_src_space       :: !Em
+      , conn_dst_space       :: !Em
+      , conn_arc_ang         :: !Radian
+      , conn_src_arm         :: !Em
+      , conn_dst_arm         :: !Em
+      , conn_loop_size       :: !Em
+      , conn_box_halfsize    :: !Em
+      }
+  deriving (Eq,Show)
+
+
+-- | Default connector properties.
+--
+-- > conn_src_sep:        0
+-- > conn_dst_sep:        0
+-- > conn_arc_ang:        pi / 12
+-- > conn_src_arm:        1
+-- > conn_dst_arm:        1
+-- > conn_loop_size:      2 
+-- > conn_box_half_size:  2
+--
+-- Arc angle is 15deg - quite shallow.
+--
+default_connector_props :: ConnectorProps
+default_connector_props = 
+    ConnectorProps { conn_src_space    = 0
+                   , conn_dst_space    = 0
+                   , conn_arc_ang      = pi / 12
+                   , conn_src_arm      = 1
+                   , conn_dst_arm      = 1
+                   , conn_loop_size    = 2 
+                   , conn_box_halfsize = 1
+                   }
+
+
+
+
+--------------------------------------------------------------------------------
+-- Queries
+
+
+connectorSrcSpace :: (DrawingCtxM m, InterpretUnit u) 
+                  => ConnectorProps -> m u
+connectorSrcSpace props = 
+    (\sz -> uconvert1 sz $ conn_src_space props) <$> pointSize
+
+
+connectorDstSpace :: (DrawingCtxM m, InterpretUnit u) 
+                  => ConnectorProps -> m u
+connectorDstSpace props = 
+    (\sz -> uconvert1 sz $ conn_dst_space props) <$> pointSize
+
+
+connectorArms :: (DrawingCtxM m, InterpretUnit u) 
+              => ConnectorProps -> m (u,u)
+connectorArms props = 
+    (\sz -> ( uconvert1 sz $ conn_src_arm props
+            , uconvert1 sz $ conn_dst_arm props) )
+        <$> pointSize
+
+-- | /legs/ are Arms + spacing.
+--
+connectorLegs :: (DrawingCtxM m, InterpretUnit u) 
+              => ConnectorProps -> m (u,u)
+connectorLegs props = 
+    (\sz -> ( uconvert1 sz $ conn_src_space props + conn_src_arm props
+            , uconvert1 sz $ conn_dst_space props + conn_dst_arm props ) )
+        <$> pointSize
+
+
+
+connectorLoopSize :: (DrawingCtxM m, InterpretUnit u) 
+                  => ConnectorProps -> m u
+connectorLoopSize props = 
+    (\sz -> uconvert1 sz $ conn_loop_size props) <$> pointSize
+
+
+connectorBoxHalfSize :: (DrawingCtxM m, InterpretUnit u) 
+                  => ConnectorProps -> m u
+connectorBoxHalfSize props = 
+    (\sz -> uconvert1 sz $ conn_box_halfsize props) <$> pointSize
+
diff --git a/src/Wumpus/Drawing/Dots/AnchorDots.hs b/src/Wumpus/Drawing/Dots/AnchorDots.hs
--- a/src/Wumpus/Drawing/Dots/AnchorDots.hs
+++ b/src/Wumpus/Drawing/Dots/AnchorDots.hs
@@ -1,6 +1,4 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE ExistentialQuantification  #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -31,10 +29,18 @@
   , DDotLocImage
 
   -- * Dots with anchor points
+  , smallDisk
+  , largeDisk
+
+  , smallCirc
+  , largeCirc
+
+
+  , dotNone
   , dotChar
   , dotText
-  , dotHLine
-  , dotVLine
+  , dotHBar
+  , dotVBar
   , dotX
   , dotPlus
   , dotCross
@@ -57,12 +63,11 @@
   ) where
 
 
-import Wumpus.Drawing.Geometry.Intersection
-import Wumpus.Drawing.Geometry.Paths
-import Wumpus.Drawing.Dots.Marks
-import Wumpus.Drawing.Text.LRText
+import Wumpus.Drawing.Dots.SimpleDots ( MarkSize )
+import qualified Wumpus.Drawing.Dots.SimpleDots as SD
+import Wumpus.Drawing.Paths.Intersection
 
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic          
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -71,23 +76,26 @@
 
 import Control.Applicative
 
--- An existential thing that supports anchors.
--- This means any dot can retun the same (opaque) structure
---
--- But it does mean that which anchor class are supported is 
--- fixed - the datatype needs a field for each one.
--- Supporting north, southeast etc. will also be tedious...
---
-data DotAnchor u = forall s.  
-                    DotAnchor { center_anchor   :: Point2 u
-                              , radial_anchor   :: Radian   -> Point2 u
-                              , cardinal_anchor :: Cardinal -> Point2 u }
 
-data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW
-  deriving (Eq,Show) 
+-- | All dots return the same thing a 'DotAnchor' which supports 
+-- the same (limited) see of anchors.
+--
+data DotAnchor u = DotAnchor 
+      { center_anchor   :: Point2 u
+      , radial_anchor   :: Radian   -> Point2 u
+      , cardinal_anchor :: Cardinal -> Point2 u 
+      }
 
 type instance DUnit (DotAnchor u) = u
 
+instance Num u => Translate (DotAnchor u) where
+  translate x y (DotAnchor ctr radialF cardinalF) = 
+      DotAnchor { center_anchor   = translate x y ctr
+                , radial_anchor   = translate x y . radialF 
+                , cardinal_anchor = translate x y . cardinalF 
+                }
+
+
 instance CenterAnchor (DotAnchor u) where
   center (DotAnchor ca _ _) = ca
 
@@ -95,117 +103,153 @@
    radialAnchor theta (DotAnchor _ ra _) = ra theta
 
 instance CardinalAnchor (DotAnchor u) where
-   north (DotAnchor _ _ c1) = c1 NN
-   south (DotAnchor _ _ c1) = c1 SS
-   east  (DotAnchor _ _ c1) = c1 EE
-   west  (DotAnchor _ _ c1) = c1 WW
+   north (DotAnchor _ _ c1) = c1 NORTH
+   south (DotAnchor _ _ c1) = c1 SOUTH
+   east  (DotAnchor _ _ c1) = c1 EAST
+   west  (DotAnchor _ _ c1) = c1 WEST
 
 
 
 instance CardinalAnchor2 (DotAnchor u) where
-   northeast (DotAnchor _ _ c1) = c1 NE
-   southeast (DotAnchor _ _ c1) = c1 SE
-   southwest (DotAnchor _ _ c1) = c1 SW
-   northwest (DotAnchor _ _ c1) = c1 NW
+   northeast (DotAnchor _ _ c1) = c1 NORTH_EAST
+   southeast (DotAnchor _ _ c1) = c1 SOUTH_EAST
+   southwest (DotAnchor _ _ c1) = c1 SOUTH_WEST
+   northwest (DotAnchor _ _ c1) = c1 NORTH_WEST
 
 
 radialCardinal :: Floating u => u -> Point2 u -> Cardinal -> Point2 u
-radialCardinal rad ctr NN = ctr .+^ (avec (pi/2)     rad) 
-radialCardinal rad ctr NE = ctr .+^ (avec (pi/4)     rad) 
-radialCardinal rad ctr EE = ctr .+^ (avec  0         rad) 
-radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) 
-radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) 
-radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) 
-radialCardinal rad ctr WW = ctr .+^ (avec  pi        rad) 
-radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad) 
+radialCardinal rad ctr NORTH        = ctr .+^ (avec (pi/2)     rad) 
+radialCardinal rad ctr NORTH_EAST   = ctr .+^ (avec (pi/4)     rad) 
+radialCardinal rad ctr EAST         = ctr .+^ (avec  0         rad) 
+radialCardinal rad ctr SOUTH_EAST   = ctr .+^ (avec (7/4 * pi) rad) 
+radialCardinal rad ctr SOUTH        = ctr .+^ (avec (6/4 * pi) rad) 
+radialCardinal rad ctr SOUTH_WEST   = ctr .+^ (avec (5/4 * pi) rad) 
+radialCardinal rad ctr WEST         = ctr .+^ (avec  pi        rad) 
+radialCardinal rad ctr NORTH_WEST   = ctr .+^ (avec (3/4 * pi) rad) 
 
 
 -- Rectangle cardinal points are at \"middles and corners\".
 --
 
 rectCardinal :: Floating u => u ->  u -> Point2 u -> Cardinal -> Point2 u
-rectCardinal _  hh ctr NN = ctr .+^ (vvec hh) 
-rectCardinal hw hh ctr NE = ctr .+^ (vec  hw     hh) 
-rectCardinal hw _  ctr EE = ctr .+^ (hvec hw) 
-rectCardinal hw hh ctr SE = ctr .+^ (vec  hw    (-hh)) 
-rectCardinal _  hh ctr SS = ctr .+^ (vvec (-hh)) 
-rectCardinal hw hh ctr SW = ctr .+^ (vec  (-hw) (-hh) )
-rectCardinal hw _  ctr WW = ctr .+^ (hvec (-hw)) 
-rectCardinal hw hh ctr NW = ctr .+^ (vec  (-hw)  hh) 
+rectCardinal _  hh ctr NORTH        = ctr .+^ (vvec hh) 
+rectCardinal hw hh ctr NORTH_EAST   = ctr .+^ (vec  hw     hh) 
+rectCardinal hw _  ctr EAST         = ctr .+^ (hvec hw) 
+rectCardinal hw hh ctr SOUTH_EAST   = ctr .+^ (vec  hw    (-hh)) 
+rectCardinal _  hh ctr SOUTH        = ctr .+^ (vvec (-hh)) 
+rectCardinal hw hh ctr SOUTH_WEST   = ctr .+^ (vec  (-hw) (-hh) )
+rectCardinal hw _  ctr WEST         = ctr .+^ (hvec (-hw)) 
+rectCardinal hw hh ctr NORTH_WEST   = ctr .+^ (vec  (-hw)  hh) 
 
-polyCardinal :: Floating u => (Radian -> Point2 u) -> Cardinal -> Point2 u
-polyCardinal f NN = f (0.5  * pi)
-polyCardinal f NE = f (0.25 * pi) 
-polyCardinal f EE = f 0 
-polyCardinal f SE = f (1.75 * pi) 
-polyCardinal f SS = f (1.5  * pi) 
-polyCardinal f SW = f (1.25 * pi)
-polyCardinal f WW = f pi 
-polyCardinal f NW = f (0.75 * pi) 
 
+-- | All anchors are the center!
+--
+zeroAnchor :: Point2 u -> DotAnchor u
+zeroAnchor ctr = 
+    DotAnchor { center_anchor   = ctr
+              , radial_anchor   = const ctr 
+              , cardinal_anchor = const ctr }
 
 
-rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u
+rectangleAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                => u -> u -> Point2 u -> DotAnchor u
 rectangleAnchor hw hh ctr = 
     DotAnchor { center_anchor   = ctr
               , radial_anchor   = fn  
               , cardinal_anchor = rectCardinal hw hh ctr }
   where
-    fn theta =  maybe ctr id $ findIntersect ctr theta 
-                             $ rectangleLines ctr hw hh
-
+    fn theta = let mb_v1 = rectangleRadialIntersect (2*hw) (2*hh) theta
+               in displace (maybe zeroVec id  mb_v1) ctr
 
-polygonAnchor :: (Real u, Floating u) => [Point2 u] -> Point2 u -> DotAnchor u
-polygonAnchor ps ctr = 
+triangleAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+               => u -> Point2 u -> DotAnchor u
+triangleAnchor hh ctr = 
     DotAnchor { center_anchor   = ctr
               , radial_anchor   = fn  
-              , cardinal_anchor = polyCardinal fn }
+              , cardinal_anchor = radialCardinal hh ctr }
   where
-    fn theta =  maybe ctr id $ findIntersect ctr theta $ polygonLines ps
+    fn theta = let mb_v1 = isoscelesTriangleRadialIntersect (2*hh) (2*hh) theta
+               in  displace (maybe zeroVec id mb_v1) ctr
 
 
+circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u
+circleAnchor rad ctr = 
+    DotAnchor { center_anchor   = ctr
+              , radial_anchor   = fn 
+              , cardinal_anchor = radialCardinal rad ctr }
+  where
+    fn theta = displace (avec theta rad) ctr
 
-bboxRectAnchor  :: (Real u, Floating u) => BoundingBox u -> DotAnchor u
+
+
+bboxRectAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+               => BoundingBox u -> DotAnchor u
 bboxRectAnchor (BBox bl@(P2 x1 y1) (P2 x2 y2)) =
    let hw = 0.5 * (x2 - x1)
        hh = 0.5 * (y2 - y1)
    in rectangleAnchor hw hh (bl .+^ vec hw hh)
 
-rectangleLDO :: (Real u, Floating u) 
-             => u -> u -> LocDrawingInfo u (DotAnchor u)
-rectangleLDO w h = 
-    promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt
 
+zeroLDO :: InterpretUnit u => LocQuery u (DotAnchor u)
+zeroLDO = qpromoteLoc $ \pt -> return $ zeroAnchor pt
 
-circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u
-circleAnchor rad ctr = DotAnchor ctr 
-                                 (\theta -> ctr .+^ (avec theta rad))
-                                 (radialCardinal rad ctr)
+rectangleLDO :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+             => MarkSize -> MarkSize -> LocQuery u (DotAnchor u)
+rectangleLDO w h = qpromoteLoc $ \pt -> 
+    (\uw uh -> rectangleAnchor (uw*0.5) (uh*0.5) pt) 
+      <$> uconvertCtx1 w <*> uconvertCtx1 h
 
-circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u)
-circleLDO = 
-    promoteR1 $ \pt -> 
-      markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt
 
 
--- This might be better taking a function: ctr -> poly_points
--- ...
---
-polygonLDO :: (Real u, Floating u, FromPtSize u) 
-           => (u -> Point2 u -> [Point2 u]) -> LocDrawingInfo u (DotAnchor u)
-polygonLDO mk = 
-    promoteR1 $ \ctr -> 
-      markHeight >>= \h -> let ps = mk h ctr in pure $ polygonAnchor ps ctr
+circleLDO :: (Floating u, InterpretUnit u) 
+          => MarkSize -> LocQuery u (DotAnchor u)
+circleLDO rad = qpromoteLoc $ \pt -> 
+    uconvertCtx1 rad >>= \urad ->  pure $ circleAnchor urad pt
 
 
+-- Probably better just using bounding circle for polygons 
+-- If you really care about anchors use shapes
+-- 
+
+-- Triangle probably benefits proper calculation...
+
+triangleLDO :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
+            => MarkSize -> LocQuery u (DotAnchor u)
+triangleLDO h = qpromoteLoc $ \pt -> 
+    (\uh -> triangleAnchor (uh*0.5) pt) 
+      <$> uconvertCtx1 h
+
+
 --------------------------------------------------------------------------------
 
 
-type DotLocImage u = LocImage u (DotAnchor u) 
+type DotLocImage u = LocImage u (DotAnchor u)
 
 type DDotLocImage = DotLocImage Double 
 
-dotChar :: (Floating u, Real u, FromPtSize u) => Char -> DotLocImage u
+
+dotNone :: InterpretUnit u => DotLocImage u
+dotNone = intoLocImage zeroLDO SD.dotNone
+
+
+
+smallDisk :: (Floating u, Real u, InterpretUnit u) => DotLocImage u
+smallDisk = intoLocImage (circleLDO 0.25) SD.smallDisk
+
+
+largeDisk :: (Floating u, Real u, InterpretUnit u) => DotLocImage u
+largeDisk = intoLocImage (circleLDO 1.00) SD.largeDisk
+
+smallCirc :: (Floating u, Real u, InterpretUnit u) => DotLocImage u
+smallCirc = intoLocImage (circleLDO 0.25) SD.smallCirc
+
+
+largeCirc :: (Floating u, Real u, InterpretUnit u) => DotLocImage u
+largeCirc = intoLocImage (circleLDO 1.00) SD.largeCirc
+
+
+dotChar :: (Floating u, Real u, InterpretUnit u, Tolerance u) 
+        => Char -> DotLocImage u
 dotChar ch = dotText [ch]
 
 
@@ -216,71 +260,83 @@
 --
 
 
-dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u 
-dotText ss = fmap (bimapL bboxRectAnchor) (ctrCenterLine ss)
+dotText :: (Floating u, Real u, InterpretUnit u, Tolerance u) 
+        => String -> DotLocImage u 
+dotText ss = 
+    fmap bboxRectAnchor $ runPosObjectBBox CENTER $ posText ss
 
+-- Note - maybe Wumpus-Basic should have a @swapAns@ function?
 
-dotHLine :: (Floating u, FromPtSize u) => DotLocImage u
-dotHLine = intoLocImage circleLDO markHLine
 
+dotHBar :: (Floating u, InterpretUnit u) => DotLocImage u
+dotHBar = intoLocImage (circleLDO 0.5) SD.dotHBar
 
-dotVLine :: (Floating u, FromPtSize u) => DotLocImage u
-dotVLine = intoLocImage circleLDO markVLine
 
+dotVBar :: (Floating u, InterpretUnit u) => DotLocImage u
+dotVBar = intoLocImage (circleLDO 0.5) SD.dotVBar
 
-dotX :: (Floating u, FromPtSize u) => DotLocImage u
-dotX = intoLocImage circleLDO markX
 
-dotPlus :: (Floating u, FromPtSize u) => DotLocImage u
-dotPlus = intoLocImage circleLDO markPlus
+dotX :: (Floating u, InterpretUnit u) => DotLocImage u
+dotX = intoLocImage (circleLDO 0.5) SD.dotX
 
-dotCross :: (Floating u, FromPtSize u) => DotLocImage u
-dotCross = intoLocImage circleLDO markCross
+dotPlus :: (Floating u, InterpretUnit u) => DotLocImage u
+dotPlus = intoLocImage (circleLDO 0.5) SD.dotPlus
 
-dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u
-dotDiamond = intoLocImage circleLDO markDiamond
+dotCross :: (Floating u, InterpretUnit u) => DotLocImage u
+dotCross = intoLocImage (circleLDO 0.5) SD.dotCross
 
-dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u
-dotFDiamond = intoLocImage circleLDO markFDiamond
+dotDiamond :: (Floating u, InterpretUnit u) => DotLocImage u
+dotDiamond = intoLocImage (circleLDO 0.5) SD.dotDiamond
 
+dotFDiamond :: (Floating u, InterpretUnit u) => DotLocImage u
+dotFDiamond = intoLocImage (circleLDO 0.5) SD.dotFDiamond
 
 
-dotDisk :: (Floating u, FromPtSize u) => DotLocImage u
-dotDisk = intoLocImage circleLDO markDisk
 
+dotDisk :: (Floating u, InterpretUnit u) => DotLocImage u
+dotDisk = intoLocImage (circleLDO 0.5) SD.dotDisk
 
-dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u
-dotSquare = 
-    lift0R1 markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare
 
+dotSquare :: (Floating u, Real u, InterpretUnit u, Tolerance u) 
+          => DotLocImage u
+dotSquare = intoLocImage (rectangleLDO 1 1) SD.dotSquare
 
 
 
-dotCircle :: (Floating u, FromPtSize u) => DotLocImage u
-dotCircle = intoLocImage circleLDO markCircle
 
+dotCircle :: (Floating u, InterpretUnit u) => DotLocImage u
+dotCircle = intoLocImage (circleLDO 0.5) SD.dotCircle
 
-dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u
-dotPentagon = intoLocImage circleLDO markPentagon
 
-dotStar :: (Floating u, FromPtSize u) => DotLocImage u
-dotStar = intoLocImage circleLDO markStar
+dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u
+dotPentagon = intoLocImage (circleLDO 0.5) SD.dotPentagon
 
+dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance u) 
+        => DotLocImage u
+dotStar = intoLocImage (circleLDO 0.5) SD.dotStar
 
-dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u
-dotAsterisk = intoLocImage circleLDO markAsterisk
 
-dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u
-dotOPlus = intoLocImage circleLDO markOPlus
+dotAsterisk :: (Floating u, InterpretUnit u) => DotLocImage u
+dotAsterisk = intoLocImage (circleLDO 0.5) SD.dotAsterisk
 
-dotOCross :: (Floating u, FromPtSize u) => DotLocImage u
-dotOCross = intoLocImage circleLDO markOCross
+dotOPlus :: (Floating u, InterpretUnit u) => DotLocImage u
+dotOPlus = intoLocImage (circleLDO 0.5) SD.dotOPlus
 
-dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u
-dotFOCross = intoLocImage circleLDO markFOCross
+dotOCross :: (Floating u, InterpretUnit u) => DotLocImage u
+dotOCross = intoLocImage (circleLDO 0.5) SD.dotOCross
 
+dotFOCross :: (Floating u, InterpretUnit u) => DotLocImage u
+dotFOCross = intoLocImage (circleLDO 0.5) SD.dotFOCross
 
-dotTriangle :: (Real u, Floating u, FromPtSize u) => DotLocImage u
-dotTriangle = intoLocImage (polygonLDO fn) markTriangle
-  where 
-    fn h ctr = let (bl,br,top) = equilateralTrianglePoints h ctr in [bl,br,top]
+
+dotTriangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+            => DotLocImage u
+dotTriangle = intoLocImage (triangleLDO 1) SD.dotTriangle
+
+
+intoLocImage :: InterpretUnit u 
+             => LocQuery u a -> LocImage u z -> LocImage u a
+intoLocImage ma gf = promoteLoc $ \pt -> 
+                     askDC >>= \ctx -> 
+                     let ans = runLocQuery ctx pt ma
+                     in replaceAns ans $ applyLoc gf pt
diff --git a/src/Wumpus/Drawing/Dots/Marks.hs b/src/Wumpus/Drawing/Dots/Marks.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Dots/Marks.hs
+++ /dev/null
@@ -1,243 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Dots.Marks
--- Copyright   :  (c) Stephen Tetley 2010-2011
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Marks - dots without anchor handles.
---
--- The text and char marks need loaded glyph metrics for proper 
--- centering. 
---
--- \*\* WARNING \*\* - names are expected to change - filled and
--- background-filled marks need a naming convention.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Dots.Marks
-  ( 
-
-
-  -- * Marks
-    markChar
-  , markText
-
-  , markHLine
-  , markVLine
-  , markX
-  , markPlus
-  , markCross
-  , markDiamond
-  , markFDiamond
-  , markBDiamond 
-  , markDisk
-  , markSquare
-  , markCircle  
-  , markPentagon
-  , markStar
-  , markAsterisk
-  , markOPlus
-  , markOCross
-  , markFOCross
-  , markTriangle
-
-  ) where
-
-
-import Wumpus.Drawing.Geometry.Paths
-import Wumpus.Drawing.Text.LRText
-
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AffineSpace                         -- package: vector-space
-import Data.VectorSpace
-
-import Control.Applicative
-
--- Marks should be the height of a lower-case letter...
-
--- NOTES
---
--- TikZ has both stroked and bordered (filled and outline-stroked)
--- marks e.g. square and square*
---
-
-
-
-
-infixr 9 `renderPathWith`
-
-renderPathWith :: LocDrawingInfo u (PrimPath u) 
-               -> (PrimPath u -> Graphic u) 
-               -> LocGraphic u
-renderPathWith m k = m >>= (lift0R1 . k)
-
-
-
-markChar :: (Real u, Floating u, FromPtSize u) => Char -> LocGraphic u
-markChar ch = markText [ch]
-
-
-
-
-markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u
-markText ss = fmap (replaceL uNil) $ ctrCenterLine ss
-
-
-
-
--- | Supplied point is the center.
---
-axialLine :: Fractional u => Vec2 u -> LocGraphic u
-axialLine v = moveStartPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)
-
-
-markHLine :: (Fractional u, FromPtSize u) => LocGraphic u 
-markHLine = lift0R1 markHeight >>= \h -> axialLine (hvec h)
-
-
-markVLine :: (Fractional u, FromPtSize u) => LocGraphic u 
-markVLine = lift0R1 markHeight >>= \h -> axialLine (vvec h) 
-
-
-markX :: (Fractional u, FromPtSize u) => LocGraphic u
-markX = lift0R1 markHeight >>= mkX 
-  where
-    mkX h = let w = 0.75 * h
-              in axialLine (vec w h) `oplus` axialLine (vec (-w) h)
-
-
-
-markPlus :: (Fractional u, FromPtSize u) =>  LocGraphic u
-markPlus = markVLine `oplus` markHLine
-
-
-markCross :: (Floating u, FromPtSize u) =>  LocGraphic u
-markCross = markHeight >>= mkCross
-  where
-    mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (-ang) h)
-    ang       = pi*0.25  
-
--- Note - height is extended slightly to look good...
-
-pathDiamond :: (Fractional u, FromPtSize u) 
-            => LocDrawingInfo u (PrimPath u)
-pathDiamond = 
-    promoteR1 $ \pt -> 
-      markHeight >>= \h -> let cp = diamondCoordPath (0.5*h) (0.66*h) 
-                           in return $ coordinatePrimPath pt cp
-
-
-
--- closedStroke :: (a -> ctx -> prim) 
--- pathDiamond  :: (ctx -> pt -> a)
--- ans          :: (ctx -> pt -> prim)
-
-markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u
-markDiamond = pathDiamond `renderPathWith` closedStroke
-
-markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u
-markFDiamond = pathDiamond `renderPathWith` filledPath
-
-
--- Note - the (const . fn) composition doesn\'t /tell/ much about
--- what is going on - though obviously it can be decoded - make 
--- the function obvious to the second argument. 
--- 
--- A named combinator might be better.
---
-
-markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u
-markBDiamond = pathDiamond `renderPathWith` borderedPath
-
-
--- | Note disk is filled.
---
-markDisk :: (Fractional u, FromPtSize u) => LocGraphic u
-markDisk = lift0R1 markHalfHeight >>= filledDisk 
-
-
-
-markSquare :: (Fractional u, FromPtSize u) => LocGraphic u
-markSquare = 
-    lift0R1 markHeight >>= \h -> 
-    let d = 0.5*(-h) in moveStartPoint (displace d d) $ strokedRectangle h h
-    
-
-
-markCircle :: (Fractional u, FromPtSize u) => LocGraphic u
-markCircle = lift0R1 markHalfHeight >>= strokedDisk 
-
-
-markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u
-markBCircle = lift0R1 markHalfHeight >>= borderedDisk 
-
-
-
-markPentagon :: (Floating u, FromPtSize u) => LocGraphic u
-markPentagon = 
-    promoteR1 $ \pt -> 
-      markHeight >>= \h -> closedStroke $ pentagonPath pt (0.5*h)
-  where
-    pentagonPath pt hh = coordinatePrimPath pt $ polygonCoordPath 5 hh
-
- 
-
-
-markStar :: (Floating u, FromPtSize u) => LocGraphic u 
-markStar = lift0R1 markHeight >>= \h -> starLines (0.5*h)
-
-starLines :: Floating u => u -> LocGraphic u
-starLines hh = 
-    promoteR1 $ \ctr -> let cp = polygonCoordPath 5 hh
-                        in step $ map (fn ctr) $ cp ctr
-  where
-    fn p0 p1    = openStroke $ primPath p0 [lineTo p1]
-    step (x:xs) = oconcat x xs
-    step _      = error "starLines - unreachable"
-
-
-markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u
-markAsterisk = lift0R1 markHeight >>= asteriskLines
-
-asteriskLines :: Floating u => u -> LocGraphic u
-asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3
-  where
-    ang     = (pi*2) / 6
-    lineF1  = axialLine (vvec h)
-    lineF2  = axialLine (avec ((pi*0.5) + ang)    h)
-    lineF3  = axialLine (avec ((pi*0.5) + ang + ang) h)
-
-
-markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u
-markOPlus = markCircle `oplus` markPlus
-
-
-markOCross :: (Floating u, FromPtSize u) => LocGraphic u
-markOCross = markCircle `oplus` markCross
-
-
-markFOCross :: (Floating u, FromPtSize u) => LocGraphic u
-markFOCross = markCross `oplus` markBCircle 
-
-
--- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u
--- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) 
-
-
-
-markTriangle :: (Floating u, FromPtSize u) => LocGraphic u
-markTriangle = tripath `renderPathWith` closedStroke
-  where
-    tripath = promoteR1 $ \pt -> 
-                markHeight >>= \h -> let cp = equilateralTriangleCoordPath h 
-                                     in pure $ coordinatePrimPath pt cp
-
diff --git a/src/Wumpus/Drawing/Dots/SimpleDots.hs b/src/Wumpus/Drawing/Dots/SimpleDots.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Dots/SimpleDots.hs
@@ -0,0 +1,281 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Dots.SimpleDots
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Simple dots - no anchor handles.
+-- 
+-- Use these where you just want to draw Dots, and do not need
+-- connectors between them. 
+--
+-- The text and char marks need loaded glyph metrics for proper 
+-- centering. 
+--
+-- \*\* WARNING \*\* - names are expected to change - filled and
+-- background-filled marks need a naming convention.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Dots.SimpleDots
+  ( 
+
+  -- * Unit for marks (0.75 the font size)
+    MarkSize
+
+  , smallDisk
+  , largeDisk
+  , smallCirc
+  , largeCirc  
+
+
+
+  -- * Dots
+  , dotNone
+
+  , dotChar
+  , dotText
+  , dotEscChar
+  , dotEscText
+
+
+  , dotHBar
+  , dotVBar
+  , dotX
+  , dotPlus
+  , dotCross
+  , dotDiamond
+  , dotFDiamond
+  , dotBDiamond 
+  , dotDisk
+  , dotSquare
+  , dotCircle  
+  , dotPentagon
+  , dotStar
+  , dotAsterisk
+  , dotOPlus
+  , dotOCross
+  , dotFOCross
+  , dotTriangle
+
+  ) where
+
+import Wumpus.Drawing.Basis.ShapeTrails
+import Wumpus.Drawing.Basis.Symbols
+
+import Wumpus.Basic.Kernel        
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.VectorSpace                         -- package: vector-space
+
+import Data.Monoid
+
+-- Marks should be the height of a lower-case letter...
+
+-- NOTES
+--
+-- TikZ has both stroked and bordered (filled and outline-stroked)
+-- marks e.g. square and square*
+--
+
+-- Cap height is a good size for Dots.
+
+
+-- | MarkUnit is a contextual unit like 'Em' and 'En'.
+-- 
+-- It is 3\/4 of the current font size.
+--
+newtype MarkSize = MarkSize { getMarkSize :: Double }
+  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)
+
+instance Show MarkSize where
+  showsPrec p d = showsPrec p (getMarkSize d)
+
+
+instance InterpretUnit MarkSize where
+  normalize sz a = (realToFrac  a) * 0.75 * fromIntegral sz
+  dinterp sz d   = (4/3) * (realToFrac d) / (fromIntegral sz)
+
+instance Tolerance MarkSize where 
+  eq_tolerance     = 0.001
+  length_tolerance = 0.01
+
+
+umark :: InterpretUnit u => LocGraphic MarkSize -> LocGraphic u
+umark = uconvF
+
+
+-- | Filled disk - radius 0.25 MarkSize.
+--
+smallDisk :: InterpretUnit u => LocGraphic u
+smallDisk = umark $ dcDisk DRAW_FILL 0.25
+
+
+-- | Filled disk - radius 1.0 MarkSize.
+--
+largeDisk :: InterpretUnit u => LocGraphic u
+largeDisk = umark $ dcDisk DRAW_FILL 1
+
+
+-- | Stroked disk (circle) - radius 0.25 MarkSize.
+--
+smallCirc :: InterpretUnit u => LocGraphic u
+smallCirc = umark $ scircle 0.25
+
+
+-- | Stroked disk (circle) - radius 1.0 MarkSize.
+--
+largeCirc :: InterpretUnit u => LocGraphic u
+largeCirc = umark $ scircle 1
+
+
+-- possibly:
+-- szCirc :: u -> LocGraphic u
+
+dotNone :: InterpretUnit u => LocGraphic u
+dotNone = emptyLocImage
+
+dotChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u
+dotChar ch = dotText [ch]
+
+
+
+dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u
+dotText ss = ignoreAns $ runPosObject CENTER $ posText ss
+
+dotEscChar :: (Real u, Floating u, InterpretUnit u) 
+           => EscapedChar -> LocGraphic u
+dotEscChar = dotEscText . wrapEscChar
+
+dotEscText :: (Real u, Floating u, InterpretUnit u) 
+           => EscapedText -> LocGraphic u
+dotEscText esc = ignoreAns $ runPosObject CENTER $ posEscText esc
+
+-- TODO - need Upright versions of dots...
+
+
+
+-- | Supplied point is the center.
+--
+axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u
+axialLine v = moveStart (negateV (0.5 *^ v)) (locStraightLine v)
+
+
+dotHBar :: (Fractional u, InterpretUnit u) => LocGraphic u 
+dotHBar = umark $ hbar 1
+
+
+dotVBar :: (Fractional u, InterpretUnit u) => LocGraphic u 
+dotVBar = umark $ vbar 1 
+
+
+dotX :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotX = umark $ axialLine (vec 0.75 1) `mappend` axialLine (vec (-0.75) 1)
+
+
+
+dotPlus :: (Fractional u, InterpretUnit u) =>  LocGraphic u
+dotPlus = dotVBar `mappend` dotHBar
+
+
+dotCross :: (Floating u, InterpretUnit u) =>  LocGraphic u
+dotCross = 
+    umark $ axialLine (avec ang 1) `mappend` axialLine (avec (-ang) 1)
+  where 
+    ang = pi*0.25  
+
+
+
+
+
+dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotDiamond = umark $ renderAnaTrail CSTROKE (diamondTrail 0.5 0.66)
+
+dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotFDiamond = umark $ renderAnaTrail CFILL (diamondTrail 0.5 0.66)
+
+
+
+dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotBDiamond = umark $ renderAnaTrail CFILL_STROKE (diamondTrail 0.5 0.66)
+
+
+-- | Note disk is filled.
+--
+dotDisk :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotDisk = umark $ dcDisk DRAW_FILL 0.5
+
+
+
+dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotSquare = umark $ renderAnaTrail CSTROKE (rectangleTrail 1 1)
+
+
+dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotCircle = umark $ scircle 0.5
+
+
+dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotBCircle = umark $ dcDisk DRAW_FILL_STROKE 0.5
+
+
+
+dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u
+dotPentagon = umark $ renderAnaTrail CSTROKE (polygonTrail 5 0.5)
+ 
+
+
+dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance u) 
+        => LocGraphic u 
+dotStar = umark $ starLines 0.5
+
+starLines :: (Floating u, Ord u, InterpretUnit u, Tolerance u) 
+          => u -> LocGraphic u
+starLines hh = promoteLoc $ \ctr ->
+    let alg = polygonTrail 5 hh
+    in liftQuery (qapplyLoc (anaTrailPoints alg) ctr) >>= \ps -> 
+       step $ map (fn ctr) ps
+  where
+    fn p0 p1    = straightLine p0 p1
+    step (x:xs) = mconcat $ x:xs
+    step _      = error "starLines - unreachable"
+
+dotAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u
+dotAsterisk = umark $ asteriskLines 1
+
+asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u
+asteriskLines h = lineF1 `mappend` lineF2 `mappend` lineF3
+  where
+    ang     = (pi*2) / 6
+    lineF1  = axialLine (vvec h)
+    lineF2  = axialLine (avec ((pi*0.5) + ang)    h)
+    lineF3  = axialLine (avec ((pi*0.5) + ang + ang) h)
+
+
+dotOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u
+dotOPlus = dotCircle `mappend` dotPlus
+
+
+dotOCross :: (Floating u, InterpretUnit u) => LocGraphic u
+dotOCross = dotCircle `mappend` dotCross
+
+
+dotFOCross :: (Floating u, InterpretUnit u) => LocGraphic u
+dotFOCross = dotBCircle `mappend` dotCross
+
+
+-- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u
+-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) 
+
+
+
+dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u
+dotTriangle = umark $ renderAnaTrail CSTROKE $ isosceles_triangle_trail 1 1
diff --git a/src/Wumpus/Drawing/Extras/Axes.hs b/src/Wumpus/Drawing/Extras/Axes.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Extras/Axes.hs
@@ -0,0 +1,75 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Extras.Axes
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Drawing grids
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Extras.Axes
+  ( 
+   
+    orthontAxes
+ 
+  , horizontalLabels
+  , verticalLabels
+
+  ) where
+
+import Wumpus.Drawing.Connectors
+import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.Monoid
+
+-- Note - axes need labels working out...
+
+
+-- | Simple orthonormal axes using snap grid units.
+--
+orthontAxes :: (Real u, Floating u, InterpretUnit u, Tolerance u)
+            => (Int,Int) -> (Int,Int) -> LocGraphic u
+orthontAxes (xl,xr) (yl,yr) = promoteLoc $ \(P2 x y) -> 
+    snapmove (1,1) >>= \(V2 uw uh) ->
+    let conn1 = ignoreAns conn_line
+        xPtl  = P2 (x - (uw * fromIntegral xl)) y
+        xPtr  = P2 (x + (uw * fromIntegral xr)) y
+        yPtl  = P2 x (y - (uh * fromIntegral yl))
+        yPtr  = P2 x (y + (uh * fromIntegral yr))
+    in  localize cap_square $           ignoreAns (connect conn1 xPtl xPtr) 
+                              `mappend` ignoreAns (connect conn1 yPtl yPtr)
+
+
+
+horizontalLabels :: (Num a, Show a, Fractional u, InterpretUnit u) 
+                 => RectAddress -> [a] -> LocGraphic u 
+horizontalLabels addr ns = 
+    snapmove (1,1) >>= \(V2 uw _) -> ignoreAns (distribH uw $ map mf ns)
+  where
+    mf n = runPosObject addr $ posTextUpright $ show n
+
+
+verticalLabels :: (Num a, Show a, Fractional u, InterpretUnit u) 
+               => RectAddress -> [a] -> LocGraphic u 
+verticalLabels addr ns = 
+    snapmove (1,1) >>= \(V2 _ uh) -> ignoreAns (distribV uh $ map mf ns)
+  where
+    mf n = runPosObject addr $ posTextUpright $ show n
+
+
+
+-- Cf. Parsec\'s Token module - remake with same name...
+--
+conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => ArrowConnector u
+conn_line = rightArrowConnector default_connector_props C.conn_line barb45
diff --git a/src/Wumpus/Drawing/Extras/Clip.hs b/src/Wumpus/Drawing/Extras/Clip.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Extras/Clip.hs
@@ -0,0 +1,46 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Extras.Clip
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Clipping paths.
+--
+-- Note - at the moment there is nothing much to this module.
+-- Ideally, clipping would be defined in Wumpus-Basic, but clipping
+-- needs a higher level path object than Wumpus-Basic provides.
+-- 
+-- \*\* WARNING \*\* names need improving.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Extras.Clip
+  ( 
+   
+    locClip
+
+  ) where
+
+
+import Wumpus.Drawing.Paths
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+
+
+-- | Clip a LocGraphic.
+-- 
+-- \*\* WARNING \*\* - AbsPath (coordinate-specific) is the wrong 
+-- object to clip a LocGraphic (coordinate-free). 
+--
+locClip :: InterpretUnit u => AbsPath u -> LocGraphic u -> LocGraphic u
+locClip absp gf = promoteLoc $ \pt -> 
+    liftQuery (toPrimPath absp) >>= \pp -> clipImage pp (gf `at` pt)
+
+
diff --git a/src/Wumpus/Drawing/Extras/Grids.hs b/src/Wumpus/Drawing/Extras/Grids.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Extras/Grids.hs
@@ -0,0 +1,210 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Extras.Grids
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Drawing grids
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Extras.Grids
+  ( 
+   
+    GridContextF
+  , grid
+  , standard_grid
+  , dotted_major_grid
+
+  , grid_major_colour
+  , grid_major_line_width
+  , grid_major_dotnum
+  , grid_minor_subdivisions
+  , grid_minor_colour
+  , grid_minor_line_width
+  , grid_minor_dotnum
+  , grid_point_size
+  , grid_label_colour
+
+  ) where
+
+
+import Wumpus.Drawing.Basis.DrawingPrimitives
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Colour ( black )
+
+import Data.Monoid
+
+
+type GridContextF = GridProps -> GridProps
+
+-- | GridProps control the drawing of grids.
+-- 
+data GridProps = GridProps
+      { gp_major_colour   :: RGBi
+      , gp_major_lnwidth  :: Double
+      , gp_major_dotnum   :: Int
+      , gp_minor_subdivs  :: Int
+      , gp_minor_colour   :: RGBi
+      , gp_minor_lnwidth  :: Double
+      , gp_minor_dotnum   :: Int
+      , gp_point_size     :: FontSize
+      , gp_label_colour   :: RGBi
+      }
+
+default_grid_props :: GridProps
+default_grid_props = 
+    GridProps { gp_major_colour     = grey1
+              , gp_major_lnwidth    = 1
+              , gp_major_dotnum     = 0
+              , gp_minor_subdivs    = 5
+              , gp_minor_colour     = grey2
+              , gp_minor_lnwidth    = 0.5
+              , gp_minor_dotnum     = 0
+              , gp_point_size       = 10
+              , gp_label_colour     = black
+              }
+  where
+    grey1 = RGBi 100 100 100
+    grey2 = RGBi 150 150 150 
+
+
+
+
+standard_grid :: GridContextF
+standard_grid = id
+
+dotted_major_grid :: GridContextF
+dotted_major_grid = 
+    grid_minor_subdivisions 0 . grid_major_dotnum 2
+
+-- Setters for client code.
+
+grid_major_colour :: RGBi -> GridContextF
+grid_major_colour rgb = (\s -> s { gp_major_colour = rgb })
+
+grid_major_line_width :: Double -> GridContextF
+grid_major_line_width lw = (\s -> s { gp_major_lnwidth = lw })
+
+grid_major_dotnum :: Int -> GridContextF
+grid_major_dotnum n = (\s -> s { gp_major_dotnum = n })
+
+grid_minor_subdivisions :: Int -> GridContextF
+grid_minor_subdivisions n = (\s -> s { gp_minor_subdivs = n })
+
+grid_minor_colour :: RGBi -> GridContextF
+grid_minor_colour rgb = (\s -> s { gp_minor_colour = rgb })
+
+grid_minor_line_width :: Double -> GridContextF
+grid_minor_line_width lw = (\s -> s { gp_minor_lnwidth = lw })
+
+grid_minor_dotnum :: Int -> GridContextF
+grid_minor_dotnum n = (\s -> s { gp_minor_dotnum = n })
+
+
+grid_point_size :: FontSize -> GridContextF
+grid_point_size i = (\s -> s { gp_point_size = i })
+
+
+grid_label_colour :: RGBi -> GridContextF
+grid_label_colour rgb = (\s -> s { gp_label_colour = rgb })
+
+
+
+
+-- Drawing context updaters...
+
+major_line_update :: GridProps -> DrawingContextF
+major_line_update (GridProps { gp_major_colour  = rgb
+                             , gp_major_lnwidth = lnwidth
+                             , gp_major_dotnum  = dotnum }) = 
+    lineProps rgb lnwidth dotnum 
+
+minor_line_update :: GridProps -> DrawingContextF
+minor_line_update (GridProps { gp_minor_colour  = rgb
+                             , gp_minor_lnwidth = lnwidth
+                             , gp_minor_dotnum  = dotnum }) = 
+    lineProps rgb lnwidth dotnum 
+
+
+lineProps :: RGBi -> Double -> Int -> DrawingContextF
+lineProps rgb lw n 
+    | n < 1     = stroke_colour rgb . set_line_width lw . solid_line 
+    | otherwise = stroke_colour rgb . set_line_width lw . dashesF 
+  where
+    dashesF = set_dash_pattern $ Dash 0 [(1,n)]
+
+
+
+--------------------------------------------------------------------------------
+
+
+grid :: (Fractional u, InterpretUnit u) 
+     => GridContextF -> Int -> Int -> LocGraphic u  
+grid upd nx ny = 
+    snapmove (1,1) >>= \(V2 uw uh) ->
+    let props  = upd default_grid_props
+        width  = uw * fromIntegral nx
+        height = uh * fromIntegral ny
+        intrr  = gridInterior nx width uw ny height uh props
+        rect   = localize (major_line_update props) $ 
+                   blRectangle DRAW_STROKE width height
+    in intrr `mappend` rect
+
+                 
+
+gridInterior :: (Fractional u, InterpretUnit u) 
+             => Int -> u -> u -> Int -> u -> u -> GridProps -> LocGraphic u
+gridInterior nx w uw ny h uh props = hlines `mappend` vlines
+  where
+    hlines = horizontalLines ny w uh props
+    vlines = verticalLines   nx h uw props
+
+
+horizontalLines :: (Fractional u, InterpretUnit u) 
+                => Int -> u -> u -> GridProps -> LocGraphic u
+horizontalLines numh w uh props@(GridProps { gp_minor_subdivs = subs })
+    | subs > 0  = let dy = uh / (fromIntegral subs)
+                      n  = (numh * subs) - 1
+                  in moveStart (vvec dy) $ minorMajor n subs (vvec dy) mnr mjr
+    | otherwise = moveStart (vvec uh) $ duplicate numh (vvec uh) mjr
+  where
+    mnr  = localize (minor_line_update props) $ horizontalLine w
+    mjr  = localize (major_line_update props) $ horizontalLine w
+
+
+
+verticalLines :: (Fractional u, InterpretUnit u) 
+              => Int -> u -> u -> GridProps -> LocGraphic u
+verticalLines numv h uw props@(GridProps { gp_minor_subdivs = subs })
+    | subs > 0  = let dx = uw / (fromIntegral subs)
+                      n  = (numv * subs) - 1
+                  in moveStart (hvec dx) $ minorMajor n subs (hvec dx) mnr mjr
+    | otherwise = moveStart (hvec uw) $ duplicate numv (hvec uw) mjr
+  where
+    mnr  = localize (minor_line_update props) $ verticalLine h
+    mjr  = localize (major_line_update props) $ verticalLine h
+
+
+
+
+minorMajor :: InterpretUnit u 
+           => Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u 
+           -> LocGraphic u
+minorMajor count alt mv mnr mjr = runLocTrace (step count)
+  where
+    step n | n <= 0           = ureturn
+           | n `mod` alt == 0 = insertl mjr >> moveby mv >> step (n-1)
+           | otherwise        = insertl mnr >> moveby mv >> step (n-1)
+ 
+
+
diff --git a/src/Wumpus/Drawing/Extras/Loop.hs b/src/Wumpus/Drawing/Extras/Loop.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Extras/Loop.hs
@@ -0,0 +1,93 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Extras.Loop
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Open loop for a circle (useful for automata diagrams).
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Extras.Loop
+  ( 
+
+    loopPath
+  , loopTrail
+
+  ) where
+
+
+import Wumpus.Drawing.Paths
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+import Data.Monoid
+
+
+
+loopPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+      => u -> Point2 u -> Radian -> AbsPath u
+loopPath zradius ctr incl = anaTrailPath ctr $ loopTrail zradius incl
+
+
+
+
+-- This is a legacy definition updated to use Trails, hence it is 
+-- not so clear.
+
+loopTrail :: (Real u, Floating u) => u -> Radian -> AnaTrail u
+loopTrail circ_radius incl = 
+    anaCatTrail (pvec zeroPt startl) $ 
+       mconcat [ diffCurve startl cp1 cp2 kitel
+               , diffCurve kitel  cp3 cp4 top
+               , diffCurve top    cp5 cp6 kiter
+               , diffCurve kiter  cp7 cp8 startr
+               ]
+  where
+    hw          = 1.25  * circ_radius
+    height      = 3.8   * circ_radius
+    hminor      = 2.72  * circ_radius
+    hbase       = circ_radius / 3
+    theta       = toRadian $ asin $ hbase / circ_radius
+    start_vec   = avec (circularModulo $ incl - quarter_pi) (0.26 * circ_radius)
+    end_vec     = avec (circularModulo $ incl + quarter_pi) (0.26 * circ_radius)    
+    minor_down  = negate $ 0.8 * circ_radius 
+    major_up    = 0.52 * circ_radius
+    top_right   = negate $ 0.8 * circ_radius
+    top_left    = 0.8 * circ_radius
+
+    top         = dispParallel height incl zeroPt
+    kiter       = dispOrtho hminor (-hw) incl zeroPt
+    kitel       = dispOrtho hminor   hw  incl zeroPt
+    
+    startr      = zeroPt .+^ avec (circularModulo $ incl - theta) circ_radius
+    startl      = zeroPt .+^ avec (circularModulo $ incl + theta) circ_radius
+
+    -- quadrant III
+    cp1         = startl .+^ end_vec 
+    cp2         = dispParallel minor_down incl kitel
+
+    -- quadrant II 
+    cp3         = dispParallel major_up incl kitel
+    cp4         = dispPerpendicular top_left incl top
+
+    -- quadrant I
+    cp5         = dispPerpendicular top_right incl top
+    cp6         = dispParallel major_up incl kiter
+
+    -- quadrant IV 
+    cp7         = dispParallel minor_down incl kiter
+    cp8         = startr .+^ start_vec
+
diff --git a/src/Wumpus/Drawing/Geometry/Intersection.hs b/src/Wumpus/Drawing/Geometry/Intersection.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Geometry/Intersection.hs
+++ /dev/null
@@ -1,173 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Geometry.Intersection
--- Copyright   :  (c) Stephen Tetley 2010-2011
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Intersection of line to line and line to plane
--- 
--- \*\* - WARNING \*\* - half baked. 
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Geometry.Intersection
-  ( 
-    LineSegment(..)
-  , PointSlope
-  , pointSlope
-  , LineEqn
-  , lineEqn
-  , toLineEqn
-  , findIntersect
-  , intersection
-
-  , rectangleLines
-  , polygonLines
-  , langle
-
-  ) 
-  where
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AffineSpace                         -- package: vector-space
-import Data.VectorSpace
-
-
--- WARNING - This module is not very good (neither particularly 
--- robust, nor efficient).
--- 
--- I really need to find an algorithm that does this properly.
---
-
-data LineSegment u = LS (Point2 u) (Point2 u)
-  deriving (Eq,Ord,Show)
-
-
-data PointSlope u = PointSlope 
-      { _point_slope_point :: Point2 u
-      , _point_slope_slope :: u
-      }
-  deriving (Eq,Show)
-
-pointSlope :: Fractional u => Point2 u -> Radian -> PointSlope u 
-pointSlope pt theta = PointSlope pt (fromRadian $ tan theta)
-
-
--- | Line in equational form, i.e. @Ax + By + C = 0@.
-data LineEqn u = LineEqn 
-      { _line_eqn_A :: !u
-      , _line_eqn_B :: !u
-      , _line_eqn_C :: !u 
-      }
-  deriving (Eq,Show)
-
-lineEqn :: Num u => Point2 u -> Point2 u -> LineEqn u
-lineEqn (P2 x1 y1) (P2 x2 y2) = LineEqn a b c 
-  where
-    a = y1 - y2
-    b = x2 - x1
-    c = (x1*y2) - (x2*y1)
-
-
-toLineEqn :: Num u => PointSlope u -> LineEqn u
-toLineEqn (PointSlope (P2 x0 y0) m) = LineEqn m (-1) ((-m) * x0 + y0)
-
-
-
-
-data IntersectionResult u = Intersects u u | Contained | NoIntersect
-  deriving (Eq,Show)
-
-
--- Note the uses a /plane/ so is susceptible to picking the 
--- wrong quadrant...
---
-findIntersect :: (Floating u, Real u, Ord u)
-               => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u)
-findIntersect ctr ang0 = step 
-  where
-    theta       = circularModulo ang0
-    eqn         = toLineEqn $ pointSlope ctr theta
-    step []     = Nothing
-    step (x:xs) = case intersection x eqn of 
-                     Just pt | quadrantCheck theta ctr pt -> Just pt
-                     _       -> step xs
-
-
-quadrantCheck :: (Real u, Floating u) 
-              => Radian -> Point2 u -> Point2 u -> Bool
-quadrantCheck theta ctr pt = theta == langle ctr pt
-
-intersection :: (Fractional u, Ord u) 
-             => LineSegment u -> LineEqn u -> Maybe (Point2 u)
-intersection ls@(LS p q) eqn = case intersect1 ls eqn of
-    Intersects fp fq -> let t = fp / (fp-fq) in Just $ affineComb p q t 
-    Contained        -> Just p
-    NoIntersect      -> Nothing
-
-
-
-intersect1 :: (Num u, Ord u) 
-           => LineSegment u -> LineEqn u -> IntersectionResult u
-intersect1 (LS p q) eqn = 
-     if inters fp fq then Intersects fp fq
-                     else if contained fp fq then Contained else NoIntersect
-  where
-    inters a b    = (a < 0 && b >= 0) || (a > 0 && b <= 0)
-    contained a b = a == 0 && b == 0
-    fp            = lineF p eqn
-    fq            = lineF q eqn
- 
-lineF :: Num u => Point2 u -> LineEqn u -> u
-lineF (P2 x y) (LineEqn a b c) = a*x + b*y + c
-
-affineComb :: Num u => Point2 u -> Point2 u -> u -> Point2 u
-affineComb p q t = p .+^ t *^ (q .-. p)
-
-
-
-
-rectangleLines :: Num u => Point2 u -> u -> u -> [LineSegment u]
-rectangleLines ctr hw hh = [LS br tr, LS tr tl, LS tl bl, LS bl br]
-  where
-    br = ctr .+^ (vec hw    (-hh))
-    tr = ctr .+^ (vec hw    hh)
-    tl = ctr .+^ (vec (-hw) hh)
-    bl = ctr .+^ (vec (-hw) (-hh))
-
-
-polygonLines :: [Point2 u] -> [LineSegment u]
-polygonLines []     = error "polygonLines - emptyList"
-polygonLines (x:xs) = step x xs 
-  where
-    step a []        = [LS a x]
-    step a (b:bs)    = LS a b : step b bs
-
-
-
--- | Calculate the counter-clockwise angle between two points 
--- and the x-axis.
---
-langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian
-langle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1)
-  where
-    -- north-east quadrant 
-    step x y | pve x && pve y = toRadian $ atan (y/x)          
-    
-    -- north-west quadrant
-    step x y | pve y          = pi     - (toRadian $ atan (y / abs x))
-
-    -- south-east quadrant
-    step x y | pve x          = (2*pi) - (toRadian $ atan (abs y / x)) 
-
-    -- otherwise... south-west quadrant
-    step x y                  = pi     + (toRadian $ atan (y/x))
-
-    pve a                     = signum a >= 0
diff --git a/src/Wumpus/Drawing/Geometry/Paths.hs b/src/Wumpus/Drawing/Geometry/Paths.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Geometry/Paths.hs
+++ /dev/null
@@ -1,138 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Geometry.Paths
--- Copyright   :  (c) Stephen Tetley 2010-2011
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Paths for /elementary/ shapes - rectangles...
--- 
--- \*\* - WARNING \*\* - half baked. 
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Geometry.Paths
-  ( 
-    LocCoordPath
-  , coordinatePrimPath
-
-  , rectangleCoordPath
-  , diamondCoordPath
-  , polygonCoordPath
-  , isoscelesTriangleCoordPath
-  , isoscelesTrianglePoints
-  , equilateralTriangleCoordPath
-  , equilateralTrianglePoints
-  ) 
-  where
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AffineSpace                         -- package: vector-space
-
-
-import Data.List ( unfoldr )
-
-
--- | A functional type from /initial point/ to point list.
---
-type LocCoordPath u = Point2 u -> [Point2 u]
-
-
--- Note - extraction needs a naming scheme - extractFROM or 
--- extractTO? - in either case this might be queuing up 
--- name-clash problems.
---
--- The Path data type will also need a similar function...
---
- 
-coordinatePrimPath :: Num u => Point2 u -> LocCoordPath u -> PrimPath u
-coordinatePrimPath pt fn = go (fn pt)
-  where
-    go ps@(_:_) = vertexPath ps
-    go []       = emptyPath pt        -- fallback
-
-
--- NOTE - These functions need changing to generate LocCoordPaths...
-
--- | Supplied point is /bottom-left/, subsequenct points are 
--- counter-clockise so [ bl, br, tr, tl ] .
---
-rectangleCoordPath :: Num u => u -> u -> LocCoordPath u
-rectangleCoordPath w h bl = [ bl, br, tr, tl ]
-  where
-    br = bl .+^ hvec w
-    tr = br .+^ vvec h
-    tl = bl .+^ vvec h 
-
-
-
--- | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @
---
-diamondCoordPath :: Num u => u -> u -> LocCoordPath u
-diamondCoordPath hw hh ctr = [ s,e,n,w ]
-  where
-    s     = ctr .+^ vvec (-hh)
-    e     = ctr .+^ hvec hw
-    n     = ctr .+^ vvec hh
-    w     = ctr .+^ hvec (-hw)
-    
-
--- | 'polygonCoordPath' : @ num_points * radius * center -> [point] @ 
---
-polygonCoordPath :: Floating u => Int -> u -> LocCoordPath u
-polygonCoordPath n radius ctr = unfoldr phi (0,(pi*0.5))
-  where
-    theta = (pi*2) / fromIntegral n
-    
-    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))
-                | otherwise = Nothing
-
-
-
--- | @isocelesTriangle bw h pt@
---
--- Supplied point is the centriod of the triangle. This has a 
--- nicer visual balance than using half-height.
---
-isoscelesTriangleCoordPath :: Floating u => u -> u -> LocCoordPath u
-isoscelesTriangleCoordPath bw h ctr = [bl,br,top]
-  where
-    (bl,br,top) = isoscelesTrianglePoints bw h ctr
-
-
--- | @isocelesTriangle bw h pt@
---
--- Supplied point is the centriod of the triangle. This has a 
--- nicer visual balance than using half-height.
---
-isoscelesTrianglePoints :: Floating u 
-                        => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u)
-isoscelesTrianglePoints bw h ctr = (bl, br, top) 
-  where
-    hw         = 0.5*bw 
-    theta      = atan $ h / hw
-    centroid_h = hw * tan (0.5*theta)
-    top        = ctr .+^ vvec (h - centroid_h)
-    br         = ctr .+^ V2   hw  (-centroid_h)
-    bl         = ctr .+^ V2 (-hw) (-centroid_h)
-
-
--- | @ side_length * ctr -> [Points] @
---
-equilateralTriangleCoordPath :: Floating u => u -> LocCoordPath u
-equilateralTriangleCoordPath sl ctr = [bl, br, top] 
-  where
-    (bl,br,top) = equilateralTrianglePoints sl ctr
-
-equilateralTrianglePoints :: Floating u 
-                          => u -> Point2 u -> (Point2 u, Point2 u, Point2 u)
-equilateralTrianglePoints sl = isoscelesTrianglePoints sl h
-  where
-    h = sl * sin (pi/3)
-
diff --git a/src/Wumpus/Drawing/Paths.hs b/src/Wumpus/Drawing/Paths.hs
--- a/src/Wumpus/Drawing/Paths.hs
+++ b/src/Wumpus/Drawing/Paths.hs
@@ -3,29 +3,28 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Drawing.Paths
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2011
 -- License     :  BSD3
 --
 -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
 -- Stability   :  highly unstable
 -- Portability :  GHC
 --
--- Shim import module for Paths.
+-- Shim import module for the Absolute Path modules.
+--
 -- 
 --------------------------------------------------------------------------------
 
-module Wumpus.Drawing.Paths 
+module Wumpus.Drawing.Paths
   ( 
 
     module Wumpus.Drawing.Paths.Base
-  , module Wumpus.Drawing.Paths.Connectors
-  , module Wumpus.Drawing.Paths.ControlPoints
-  , module Wumpus.Drawing.Paths.MonadicConstruction
+  , module Wumpus.Drawing.Paths.PathBuilder
+  , module Wumpus.Drawing.Paths.Vamps
 
   ) where
 
 import Wumpus.Drawing.Paths.Base
-import Wumpus.Drawing.Paths.Connectors
-import Wumpus.Drawing.Paths.ControlPoints
-import Wumpus.Drawing.Paths.MonadicConstruction
+import Wumpus.Drawing.Paths.PathBuilder
+import Wumpus.Drawing.Paths.Vamps
 
diff --git a/src/Wumpus/Drawing/Paths/Base.hs b/src/Wumpus/Drawing/Paths/Base.hs
--- a/src/Wumpus/Drawing/Paths/Base.hs
+++ b/src/Wumpus/Drawing/Paths/Base.hs
@@ -5,646 +5,1099 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Drawing.Paths.Base
--- Copyright   :  (c) Stephen Tetley 2010-2011
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Extended path type - more amenable for complex drawings than
--- the type in Wumpus-Core.
---
--- \*\* WARNING \*\* this module is an experiment, and may 
--- change significantly or even be dropped from future revisions.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Paths.Base
-  ( 
-
-    Path
-  , DPath
-  , length
-  , append
-  , pconcat
-  , line
-  , curve
-  , pivot
-  , traceLinePoints
-  , traceCurvePoints
-  , curveByAngles
-
-  , toPrimPath 
-
-  , tipL
-  , tipR
-
-  , shortenPath
-  , shortenL
-  , shortenR
-  , directionL
-  , directionR
-
-  , midway
-  , midway_
-  , atstart
-  , atstart_
-  , atend
-  , atend_
-
-  , PathViewL(..)
-  , DPathViewL
-  , PathViewR(..)
-  , DPathViewR
-  , PathSegment(..)
-  , DPathSegment
-  , pathViewL
-  , pathViewR
-
-
-  , roundTrail
-  , roundInterior
-
-  ) where
-
-
-import Wumpus.Drawing.Geometry.Intersection ( langle )
-
--- package: wumpus-basic
-import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl
-                                   , ViewR(..), viewr, cons, snoc, join )
-import qualified Wumpus.Basic.Utils.JoinList as JL
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AffineSpace
-import Data.VectorSpace
-
-import Data.List ( foldl' ) 
-
-import Prelude hiding ( length )
-
-data Path u = Path { _path_length   :: u 
-                   , _path_start    :: Point2 u
-                   , _path_elements :: JoinList (PathSeg u)
-                   , _path_end      :: Point2 u
-                   }
-  deriving (Eq,Show)
-
-type DPath = Path Double
-
--- Annotating each segment with length is \*\* good \*\*.
--- Makes it much more efficient to find the midway point.
---
--- But what do we do about the start point:
---
--- a) put it in the segment - too much info in the type, allows 
--- consistency problems vis-a-vis gaps in the path.
---
--- b) leave it out - too little info in the type, allows 
--- consistency problems with length.
---
--- Option (a) is probably most convenient espcially as the 
--- constructors won\'t be exported.
-
--- Annotation is length...
--- 
-data PathSeg u = LineSeg  { _line_length  :: u 
-                          , _line_start   :: Point2 u
-                          , _line_end     :: Point2 u
-                          }
-               | CurveSeg { _curve_length :: u 
-                          , _curve_start  :: Point2 u
-                          , _ctrl_pt_one  :: Point2 u
-                          , _ctrl_pt_two  :: Point2 u
-                          , _curve_end    :: Point2 u
-                          }
-  deriving (Eq,Show)
-
-
-type instance DUnit (Path u)    = u
-type instance DUnit (PathSeg u) = u
-
-
-infixr 1 `append`
-
-length :: Num u => Path u -> u
-length (Path u _ _ _) = u
-
-append :: Floating u => Path u -> Path u -> Path u
-append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2) 
-    | end1 == start2 = Path (len1+len2) start1 (se1 `join` se2) end2 
-    | otherwise      = let joint     = lineSegment end1 start2
-                           total_len = len1 + len2 + segmentLength joint
-                       in Path total_len start1 (se1 `join` (cons joint se2)) end2 
-
--- CAUTION - @append@ is using Floating Point equality to see if
--- points are equal...
-
-
-pconcat :: Floating u => Path u -> [Path u] -> Path u
-pconcat p0 ps = foldl' append p0 ps
-
-segmentLength :: PathSeg u -> u
-segmentLength (LineSeg u _ _)       = u
-segmentLength (CurveSeg u _ _ _ _)  = u
-
-
-segmentStart :: PathSeg u -> Point2 u
-segmentStart (LineSeg  _ p0 _)      = p0
-segmentStart (CurveSeg _ p0 _ _ _)  = p0
-
-segmentEnd :: PathSeg u -> Point2 u
-segmentEnd (LineSeg  _ _ p1)        = p1
-segmentEnd (CurveSeg _ _ _ _ p3)    = p3
-
-
-
-
-lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u 
-lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1
-
-
-pathZero :: Floating u => Point2 u -> Path u 
-pathZero p0 = Path 0 p0 JL.empty p0
-   
-
-line :: Floating u => Point2 u -> Point2 u -> Path u 
-line p0 p1 = let v = vlength $ pvec p0 p1 
-             in Path v p0 (JL.one $ LineSeg v p0 p1) p1
-   
-
-curve :: (Floating u, Ord u)
-      => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u 
-curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3
-                    in Path v p0 (JL.one $ CurveSeg v p0 p1 p2 p3) p3
-
--- | A draw a /straight line/ of length 0 at the supplied point. 
---
--- This is /might/ be useful in concatenating curved paths
--- as it introduces and extra control point.
--- 
-pivot :: Floating u => Point2 u -> Path u 
-pivot p0 = Path 0 p0 (JL.one $ LineSeg 0 p0 p0) p0
-
-
--- | 'traceLinePoints' throws a runtime error if the supplied list
--- is empty. 
---
-traceLinePoints :: Floating u => [Point2 u] -> Path u
-traceLinePoints []       = error "traceLinePoints - empty point list."
-traceLinePoints [a]      = line a a
-traceLinePoints (a:b:xs) = step (line a b) b xs
-  where
-    step acc _ []     = acc
-    step acc e (y:ys) = step (acc `append` line e y) y ys
-
-
--- | 'traceCurvePoints' consumes 4 points from the list on the 
--- intial step (start, control1, control2, end) then steps 
--- through the list taking 3 points at a time thereafter
--- (control1,control2, end). Leftover points are discarded.    
--- 
--- 'traceCurvePoints' throws a runtime error if the supplied list
--- is has less than 4 elements (start, control1, control2, end). 
---
-traceCurvePoints :: (Floating u, Ord u) => [Point2 u] -> Path u
-traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs
-  where
-    step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs
-    step acc _  _          = acc
-
-traceCurvePoints _            = error "tracePointsCurve - less than 4 elems."
-
-
-curveByAngles :: (Floating u, Ord u) 
-              => Point2 u -> Radian -> Radian -> Point2 u -> Path u
-curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end
-  where
-    sz     = 0.375 * (vlength $ pvec start end)
-    v1     = avec cin  sz
-    v2     = avec cout sz
-
-
-
--- | Turn a Path into an ordinary PrimPath.
---
--- Assumes path is properly formed - i.e. end point of one 
--- segment is the same point as the start point of the next
--- segment.
---
-toPrimPath :: Num u => Path u -> PrimPath u
-toPrimPath (Path _ start segs _) = step1 $ viewl segs
-  where
-    step1 EmptyL                  = emptyPath start
-    step1 (e :< se)               = let (p0,a) = seg1 e in 
-                                    primPath p0 $ a : step2 (viewl se)
-
-    step2 EmptyL                  = []
-    step2 (e :< se)               = seg2 e : step2 (viewl se)
-    
-    seg1 (LineSeg  _ p0 p1)       = (p0, lineTo p1)
-    seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3)
- 
-    seg2 (LineSeg  _ _  p1)       = lineTo p1
-    seg2 (CurveSeg _ _  p1 p2 p3) = curveTo p1 p2 p3
-
-
-
---------------------------------------------------------------------------------
--- Curve length
-
-data StrictCurve u = Curve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)
-
-curveLength :: (Floating u, Ord u)      
-            => Point2 u -> Point2 u -> Point2 u -> Point2 u -> u
-curveLength p0 p1 p2 p3 = gravesenLength 0.1 $ Curve p0 p1 p2 p3
-
-
--- | Jens Gravesen\'s bezier arc-length approximation. 
---
--- Note this implementation is parametrized on error tolerance.
---
-gravesenLength :: (Floating u, Ord u) => u -> StrictCurve u -> u
-gravesenLength err_tol crv = step crv where
-  step c = let l1 = ctrlPolyLength c
-               l0 = cordLength c
-           in if   l1-l0 > err_tol
-              then let (a,b) = subdivide c in step a + step b
-              else 0.5*l0 + 0.5*l1
-
-
-ctrlPolyLength :: Floating u => StrictCurve u -> u
-ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3
-  where
-    len pa pb = vlength $ pvec pa pb
-
-cordLength :: Floating u => StrictCurve u -> u
-cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3
-
-
--- | mid-point between two points
---
-pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
-pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0
-
-
--- | Curve subdivision via de Casteljau\'s algorithm.
---
-subdivide :: Fractional u 
-          => StrictCurve u -> (StrictCurve u, StrictCurve u)
-subdivide (Curve p0 p1 p2 p3) =
-    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)
-  where
-    p01   = pointMidpoint p0    p1
-    p12   = pointMidpoint p1    p2
-    p23   = pointMidpoint p2    p3
-    p012  = pointMidpoint p01   p12
-    p123  = pointMidpoint p12   p23
-    p0123 = pointMidpoint p012  p123
-
--- | subdivide with an affine weight along the line...
---
-subdividet :: Real u
-           => u -> StrictCurve u -> (StrictCurve u, StrictCurve u)
-subdividet t (Curve p0 p1 p2 p3) = 
-    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)
-  where
-    p01   = affineCombination t p0    p1
-    p12   = affineCombination t p1    p2
-    p23   = affineCombination t p2    p3
-    p012  = affineCombination t p01   p12
-    p123  = affineCombination t p12   p23
-    p0123 = affineCombination t p012  p123
-
-affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u
-affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1)
-
---------------------------------------------------------------------------------
--- tips 
-
-tipL :: Path u -> Point2 u
-tipL (Path _ sp _ _) = sp
-
-
-tipR :: Path u -> Point2 u
-tipR (Path _ _ _ ep) = ep
-
-
-
-
--- | 'sortenPath' : @ left_dist * right_dist * path -> Path @
---
-shortenPath :: (Real u , Floating u) => u  -> u -> Path u -> Path u
-shortenPath l r = shortenL l .  shortenR r 
-
-
---------------------------------------------------------------------------------
--- shorten from the left...
-
--- | Note - shortening a line from the left by 
--- greater-than-or-equal its length is operationally equivalent 
--- to making a zero-length line at the end point.
---
-shortenL :: (Real u, Floating u) => u -> Path u -> Path u
-shortenL n (Path u _ segs ep) 
-    | n >= u                  = line ep ep
-    | otherwise               = step n (viewl segs)
-  where
-    step _ EmptyL     = line ep ep      -- should be unreachable
-    step d (e :< se)  = let z  = segmentLength e in
-                        case compare d z of
-                          GT -> step (d-z) (viewl se)
-                          EQ -> makeLeftPath (u-n) se ep
-                          LT -> let e1 = shortenSegL d e
-                                in Path (u-n) (segmentStart e1) (e1 `cons` se) ep
-
-
-makeLeftPath :: Floating u => u -> JoinList (PathSeg u) -> Point2 u -> Path u
-makeLeftPath u se ep = 
-    case viewl se of
-      EmptyL   -> line ep ep
-      (e :< _) -> Path u (segmentStart e) se ep
-
-
-shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
-shortenSegL n (LineSeg  u p0 p1)        = 
-    LineSeg  (u-n) (shortenLineL n p0 p1) p1
-
-shortenSegL n (CurveSeg u p0 p1 p2 p3)  = 
-    let (Curve p0' p1' p2' p3') = snd $ subdividet (n/u) (Curve p0 p1 p2 p3)
-    in CurveSeg (u-n) p0' p1' p2' p3'
-
-
-shortenLineL :: (Real u, Floating u) 
-             => u -> Point2 u -> Point2 u -> Point2 u
-shortenLineL n p0 p1 = p0 .+^ v
-  where
-    v0 = p1 .-. p0
-    v  = avec (vdirection v0) n
-
-
-
---------------------------------------------------------------------------------
--- shorten from the right ...
- 
--- | Note - shortening a line from the right by 
--- greater-than-or-equal its length is operationally equivalent 
--- to making a zero-length line at the start point.
---
-shortenR :: (Real u, Floating u) => u -> Path u -> Path u
-shortenR n (Path u sp segs _) 
-    | n >= u                  = line sp sp
-    | otherwise               = step n (viewr segs)
-  where
-    step _ EmptyR     = line sp sp      -- should be unreachable
-    step d (se :> e)  = let z = segmentLength e in
-                        case compare d z of
-                          GT -> step (d-z) (viewr se)
-                          EQ -> makeRightPath n sp se
-                          LT -> let e1 = shortenSegR d e
-                                in Path (u-n) sp (se `snoc` e1) (segmentEnd e1)
-                         
-
-makeRightPath :: Floating u => u -> Point2 u -> JoinList (PathSeg u) -> Path u
-makeRightPath u sp se = 
-    case viewr se of
-      EmptyR   -> line sp sp
-      (_ :> e) -> Path u sp se (segmentEnd e)
-
-
-
-shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
-shortenSegR n (LineSeg  u p0 p1)        = 
-    LineSeg  (u-n) p0 (shortenLineR n p0 p1) 
-
-shortenSegR n (CurveSeg u p0 p1 p2 p3)  = 
-    let (Curve p0' p1' p2' p3') = fst $ subdividet ((u-n)/u) (Curve p0 p1 p2 p3)
-    in CurveSeg (u-n) p0' p1' p2' p3'
-
-
-shortenLineR :: (Real u, Floating u) 
-             => u -> Point2 u -> Point2 u -> Point2 u
-shortenLineR n p0 p1 = p1 .+^ v
-  where
-    v0 = p0 .-. p1
-    v  = avec (vdirection v0) n
-
-
-
-
---------------------------------------------------------------------------------
--- line direction
-
--- | Direction of empty path is considered to be 0.
---
-directionL :: (Real u, Floating u) => Path u -> Radian
-directionL (Path _ _ se _)  = step $ viewl se
-  where
-    step (LineSeg  _ p0 p1 :< _)      = lineDirection p1 p0  -- 1-to-0
-    step (CurveSeg _ p0 p1 _ _ :< _)  = lineDirection p1 p0
-    step _                            = 0       -- should be unreachable
-
-
--- | Direction of empty path is considered to be 0.
---
-directionR :: (Real u, Floating u) => Path u -> Radian
-directionR (Path _ _ se _) = step $ viewr se
-  where
-    step (_ :> LineSeg  _ p0 p1)      = lineDirection p0 p1
-    step (_ :> CurveSeg _ _  _ p2 p3) = lineDirection p2 p3
-    step _                            = 0       -- should be unreachable             
-
-
-
-
---------------------------------------------------------------------------------
-
-
--- Return direction as well because the calculation is expensive...
---
-midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian)
-midway pa@(Path u sp _ _) 
-    | u == 0    = (sp,0)
-    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1)
-
--- Just the midway point.
---
-midway_ :: (Real u, Floating u) => Path u -> Point2 u
-midway_ = fst . midway
-
-
-atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian)
-atstart pa@(Path _ sp _ _) = (sp, directionL pa)
-
-atstart_ :: Path u -> Point2 u
-atstart_ (Path _ sp _ _) = sp
-
-
-atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian)
-atend pa@(Path _ _ _ ep) = (ep, directionR pa)
- 
-
-atend_ :: Path u -> Point2 u
-atend_ (Path _ _ _ ep) = ep
-
-
--- nearstart, nearend, verynear ...
-
-
---------------------------------------------------------------------------------
-
-data PathViewL u = PathOneL (PathSegment u)
-                 | PathSegment u :<< Path u
-  deriving (Eq,Show) 
-
-type DPathViewL = PathViewL Double
-
-data PathViewR u = PathOneR (PathSegment u)
-                 | Path u :>> PathSegment u
-  deriving (Eq,Show) 
-
-type DPathViewR = PathViewR Double
-
-
-data PathSegment u = Line1  (Point2 u) (Point2 u)
-                   | Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u)
-  deriving (Eq,Show) 
-
-type DPathSegment = PathSegment Double
-
-type instance DUnit (PathViewL u)   = u
-type instance DUnit (PathViewR u)   = u
-type instance DUnit (PathSegment u) = u
-
-pathViewL :: Num u => Path u -> PathViewL u
-pathViewL (Path u _ segs ep) = go (viewl segs)
-  where
-    go EmptyL                   = error "pathViewL - (not) unreachable."
-     
-    go (LineSeg v p0 p1 :< se)
-        | JL.null se            = PathOneL (Line1 p0 p1)
-        | otherwise             = Line1 p0 p1 :<< Path (u-v) p1 se ep
-
-    go (CurveSeg v p0 p1 p2 p3 :< se) 
-        | JL.null se            = PathOneL (Curve1 p0 p1 p2 p3)
-        | otherwise             = Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep
-
-
-pathViewR :: Num u => Path u -> PathViewR u
-pathViewR (Path u _ segs ep) = go (viewr segs)
-  where
-    go EmptyR                   = error "pathViewR - (not) unreachable."
-
-    go (se :> LineSeg v p0 p1) 
-        | JL.null se            = PathOneR (Line1 p0 p1)
-        | otherwise             = Path (u-v) p1 se ep :>> Line1 p0 p1
-
-    go (se :> CurveSeg v p0 p1 p2 p3) 
-        | JL.null se            = PathOneR (Curve1 p0 p1 p2 p3)
-        | otherwise             = Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3
-
-
-
-
---------------------------------------------------------------------------------
--- Round corners
-
--- | The length of the control-point vector wants to be slighly 
--- longer than half of /d/ (d - being the distance between the 
--- /truncated/ points and the corner).
---
-cornerCurve :: (Real u, Floating u) 
-            => Point2 u -> Point2 u -> Point2 u -> Path u
-cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3
-  where
-    len1 = 0.6 *  (vlength $ pvec p1 p2)
-    len2 = 0.6 *  (vlength $ pvec p3 p2)
-    cp1  = p1 .+^ (avec (langle p1 p2) len1)
-    cp2  = p3 .+^ (avec (langle p3 p2) len2)
-
-
--- | 'roundTrail' : @ rounding_distance * [point] -> Path @
---
--- Build a path from the list of vertices, all the interior 
--- corners are rounded by the rounding distance \*and\* final 
--- round corner is created \"incorporating\" the start point (as 
--- the start point becomes a rounded corner the actual path will 
--- not intersect it). 
--- 
--- It is expected that this function will be used to create round 
--- cornered shapes.
--- 
--- 'roundTrail' throws a runtime error if the input list is empty. 
--- If the list has one element /the null path/ is built, if the 
--- list has two elements a straight line is built.
---
-roundTrail :: (Real u, Floating u) 
-           => u -> [Point2 u] -> Path u 
-roundTrail _ []             = error "roundTrail - empty list."
-roundTrail _ [a]            = pathZero a
-roundTrail _ [a,b]          = line a b
-roundTrail u (start:b:c:xs) = step (lineCurveTrail u start b c) (b:c:xs)
-  where
-    step acc (m:n:o:ps)     = step (acc `append` lineCurveTrail u m n o) (n:o:ps)
-    step acc [n,o]          = acc `append` lineCurveTrail u n o start
-                                  `append` lineCurveTrail u o start b 
-    step acc _              = acc
-
-
-
--- | Two parts - line and corner curve...
---
--- Note - the starting point is moved, this function is for 
--- closed, rounded paths.
---
-lineCurveTrail :: (Real u, Floating u) 
-               => u -> Point2 u -> Point2 u -> Point2 u -> Path u
-lineCurveTrail u a b c = line p1 p2 `append` cornerCurve p2 b p3
-  where
-    p1 = a .+^ (avec (vdirection $ pvec a b) u)
-    p2 = b .+^ (avec (vdirection $ pvec b a) u)
-    p3 = b .+^ (avec (vdirection $ pvec b c) u)
-
-
--- | 'roundInterior' : @ rounding_distance * [point] -> Path @
---
--- Build a path from the list of vertices, all the interior 
--- corners are rounded by the rounding distance. Unlike 
--- 'roundTrail' there is no /loop around/ to the start point,
--- and start path will begin exactly on the start point and end 
--- exactly on the end point. 
--- 
--- 'roundInterior' throws a runtime error if the input list is 
--- empty. If the list has one element /the null path/ is built, 
--- if the list has two elements a straight line is built.
---
-roundInterior :: (Real u, Floating u) 
-           => u -> [Point2 u] -> Path u 
-roundInterior _ []             = error "roundEveryInterior - empty list."
-roundInterior _ [a]            = pathZero a
-roundInterior _ [a,b]          = line a b
-roundInterior u (start:b:c:xs) = let (path1,p1) = lineCurveInter1 u start b c
-                                 in step path1 (p1:c:xs)
-  where
-    step acc (m:n:o:ps)     = let (seg2,p1) = lineCurveInter1 u m n o
-                              in step (acc `append` seg2) (p1:o:ps)
-    step acc [n,o]          = acc `append` line n o
-    step acc _              = acc
-
-
-
--- | Two parts - line and corner curve...
---
--- Note - draws a straight line from the starting point - this is 
--- the first step of an interior (non-closed) rounded path
---
-lineCurveInter1 :: (Real u, Floating u) 
-                => u -> Point2 u -> Point2 u -> Point2 u -> (Path u, Point2 u)
-lineCurveInter1 u a b c = 
-    (line a p2 `append` cornerCurve p2 b p3, p3)
-  where
-    p2 = b .+^ (avec (vdirection $ pvec b a) u)
-    p3 = b .+^ (avec (vdirection $ pvec b c) u)
- 
+-- Copyright   :  (c) Stephen Tetley 2010-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Absolute path type - this should be more amenable for building 
+-- complex drawings than the PrimPath type in Wumpus-Core.
+--
+-- Note - there is no concatenation (i.e. no Monoid instance),
+-- this is because concatenating \*\* absolute \*\* paths has no 
+-- obvious interpretation - draw a join between the paths, move
+-- the second path to start where the first ends...
+--
+-- Use @CatTrail@ from Wumpus-Basic if you need a relative-path 
+-- like object that supports concatenation, then convert it in a 
+-- final step to an @AbsPath@.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Paths.Base
+  ( 
+
+  -- * Absolute path type
+    AbsPath
+  , DAbsPath
+
+
+  -- * Construction
+  , emptyPath
+  , line1
+  , curve1
+  , vertexPath
+  , curvePath
+  , controlCurve
+
+  , vectorPath
+  , vectorPathTheta
+
+  , anaTrailPath
+  , catTrailPath
+
+  -- * Queries
+  , null
+  , length
+
+  -- * Concat and extension
+  , snocLine
+  , snocLineTo
+  , snocCurve
+  , snocCurveTo
+
+
+  -- * Conversion
+  , toPrimPath
+
+  , renderPath
+  , renderPath_
+
+  -- * Shortening
+  , shortenPath
+  , shortenL
+  , shortenR
+
+  -- * Tips and inclination
+  , tipL
+  , tipR
+  , inclinationL
+  , inclinationR
+
+  , isBezierL
+  , isBezierR
+
+
+  -- * Path anchors
+  , midway
+  , midway_
+  , atstart
+  , atstart_
+  , atend
+  , atend_
+
+
+  -- * Views
+  , PathViewL(..)
+  , DPathViewL
+  , PathViewR(..)
+  , DPathViewR
+  , PathSegment(..)
+  , DPathSegment
+  , pathViewL
+  , pathViewR
+
+  , optimizeLines
+
+  , roundExterior
+  , roundInterior
+
+  , deBezier
+  , pathMajorPoints
+  , pathAllPoints
+
+  -- * Path division
+  , pathdiv
+
+
+  ) where
+
+import Wumpus.Drawing.Basis.BezierCurve
+
+import Wumpus.Basic.Kernel
+import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl
+                                   , ViewR(..), viewr, cons, snoc )
+import qualified Wumpus.Basic.Utils.JoinList as JL
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+import Data.Monoid
+import qualified Data.Traversable as T
+
+import Prelude hiding ( null, length )
+
+--
+-- Design Note
+-- 
+-- Wumpus has no relative path type. An AbsPath is expected to be 
+-- an /answer/ from some function like an anchor point or a 
+-- bounding box.
+--
+-- Wumpus didn\'t always work on this premise, some of the code 
+-- below may contradict this...
+--
+
+
+
+
+
+-- | Absolute path data type.
+--
+data AbsPath u = AbsPath 
+      { _abs_path_length   :: u 
+      , _abs_path_start    :: Point2 u
+      , _abs_path_elements :: JoinList (AbsPathSeg u)
+      , _abs_path_end      :: Point2 u
+      }
+  deriving (Eq,Show)
+
+type instance DUnit (AbsPath u) = u
+
+
+type DAbsPath = AbsPath Double
+
+-- Annotating each segment with length is \*\* good \*\*.
+-- Makes it much more efficient to find the midway point.
+--
+-- But what do we do about the start point:
+--
+-- a) put it in the segment - too much info in the type, allows 
+-- consistency problems vis-a-vis gaps in the path.
+--
+-- b) leave it out - too little info in the type, allows 
+-- consistency problems with length.
+--
+-- Option (a) is probably most convenient espcially as the 
+-- constructors won\'t be exported.
+
+-- Annotation is length...
+-- 
+data AbsPathSeg u = AbsLineSeg  u (Vec2 u)
+                  | AbsCurveSeg u (Vec2 u) (Vec2 u) (Vec2 u)
+  deriving (Eq,Show)
+
+
+type instance DUnit (AbsPathSeg u) = u
+
+-- 
+-- DESIGN NOTE
+--
+-- No monoid instance. AbsPaths dont support empty or even concat 
+-- naturally.
+--
+-- Concat is troublesome because AbsPaths are always located 
+-- within a frame.
+--
+-- They can support:
+--
+-- a. Concat with a join between the end of the first path and the
+-- start of the second.
+-- 
+-- b. Shape preserving concat - the second path is moved so it 
+-- continues from the end point of the first path.
+--
+-- It is conceptually simpler to think about extension (adding to 
+-- the path tip) rather than concatenation. 
+--
+
+--------------------------------------------------------------------------------
+
+instance Functor AbsPath where
+  fmap f (AbsPath u sp ls ep) = 
+      AbsPath (f u) (fmap f sp) (fmap (fmap f) ls) (fmap f ep)
+
+instance Functor AbsPathSeg where
+  fmap f (AbsLineSeg u v1)        = 
+      AbsLineSeg (f u) (fmap f v1)
+
+  fmap f (AbsCurveSeg u v1 v2 v3) = 
+      AbsCurveSeg (f u) (fmap f v1) (fmap f v2) (fmap f v3)
+
+
+
+--------------------------------------------------------------------------------
+-- Translate
+
+
+-- | AbsPathSegments are build from vectors so they do not
+-- respond to translation.
+--
+instance Num u => Translate (AbsPathSeg u) where
+  translate _ _ s1 = s1
+
+
+instance (Floating u, Ord u, Tolerance u) => Scale (AbsPathSeg u) where
+  scale sx sy (AbsLineSeg _ v1)        = absLineSeg $ scale sx sy v1
+  scale sx sy (AbsCurveSeg _ v1 v2 v3) = 
+    absCurveSeg (scale sx sy v1) (scale sx sy v2) (scale sx sy v3)
+
+
+
+-- | Translate is cheap on AbsPath it just moves the start and
+-- end points. The path itself is otherwise built from vectors
+-- so it doesn\'t respond to translation (translate == id).
+--
+instance Num u => Translate (AbsPath u) where
+  translate x y (AbsPath len sp se ep) = 
+      AbsPath len (translate x y sp) se (translate x y ep)
+
+
+
+-- | This is expensive on paths - needs a traversal.
+--
+instance (Floating u, Ord u, Tolerance u) => Scale (AbsPath u) where
+  scale sx sy = rebuildPath (scale sx sy) (scale sx sy)
+                            (\v1 v2 v3 -> ( scale sx sy v1
+                                          , scale sx sy v2
+                                          , scale sx sy v3 ))
+
+
+-- | This is expensive on paths - needs a traversal.
+--
+instance (Real u, Floating u, Ord u, Tolerance u) => Rotate (AbsPath u) where
+  rotate ang = rebuildPath (rotate ang) (rotate ang)
+                           (\v1 v2 v3 -> ( rotate ang v1
+                                         , rotate ang v2
+                                         , rotate ang v3 ))
+
+-- | This is expensive on paths - needs a traversal.
+--
+instance (Real u, Floating u, Ord u, Tolerance u) => RotateAbout (AbsPath u) where
+  rotateAbout ang pt = 
+    rebuildPath (rotateAbout ang pt) (rotateAbout ang pt)
+                (\v1 v2 v3 -> ( rotateAbout ang pt v1
+                              , rotateAbout ang pt v2
+                              , rotateAbout ang pt v3 ))
+
+
+
+
+rebuildPath :: (Floating u, Ord u, Tolerance u) 
+            => (Point2 u -> Point2 u) 
+            -> (Vec2 u -> Vec2 u) 
+            -> (Vec2 u -> Vec2 u -> Vec2 u -> (Vec2 u, Vec2 u, Vec2 u))
+            -> AbsPath u 
+            -> AbsPath u
+rebuildPath pointf linef curvef (AbsPath _ sp segs _) = 
+    step (emptyPath $ pointf sp) (viewl segs)
+  where
+    step ac EmptyL                         = ac
+
+    step ac (AbsLineSeg _ v1 :< xs)        = 
+      step (snocLine ac $ linef v1) (viewl xs) 
+
+    step ac (AbsCurveSeg _ v1 v2 v3 :< xs) = 
+      step (snocCurve ac $ curvef v1 v2 v3) (viewl xs) 
+
+--------------------------------------------------------------------------------
+-- Construction
+
+absLineSeg :: Floating u => Vec2 u -> AbsPathSeg u
+absLineSeg v1 = AbsLineSeg (vlength v1) v1
+
+absCurveSeg :: (Floating u, Ord u, Tolerance u) 
+            => Vec2 u -> Vec2 u -> Vec2 u -> AbsPathSeg u
+absCurveSeg v1 v2 v3 = 
+    AbsCurveSeg (bezierLength $ vbezierCurve v1 v2 v3 zeroPt) v1 v2 v3
+
+-- | Create the empty path.
+-- 
+-- Note - an absolute path needs /locating/ and cannot be built 
+-- without a start point. Figuratively, the empty path is a path
+-- from the start point to the end point.
+--
+-- Thus AbsPath operates as a semigroup but not a monoid.
+--
+emptyPath :: Floating u => Point2 u -> AbsPath u
+emptyPath = zeroPath
+
+
+-- | Create an absolute path as a straight line between the 
+-- supplied points.
+--
+line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u 
+line1 p0 p1 = AbsPath len p0 (JL.one s1) p1
+  where
+    s1@(AbsLineSeg len _) = absLineSeg $ pvec p0 p1
+
+-- | Create an absolute path from a single cubic Bezier curve.
+--
+curve1 :: (Floating u, Ord u, Tolerance u)
+      => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u 
+curve1 p0 p1 p2 p3 = 
+    AbsPath len p0 (JL.one $ AbsCurveSeg len v1 v2 v3) p3
+  where
+    v1  = pvec p0 p1
+    v2  = pvec p1 p2
+    v3  = pvec p2 p3
+    len = bezierLength (BezierCurve p0 p1 p2 p3)
+
+
+-- | 'vertexPath' throws a runtime error if the supplied list
+-- is empty. 
+--
+vertexPath :: (Floating u, Ord u, Tolerance u) 
+           => [Point2 u] -> AbsPath u
+vertexPath []       = error "traceLinePoints - empty point list."
+vertexPath [a]      = line1 a a
+vertexPath (a:b:xs) = step (line1 a b) xs
+  where
+    step acc []     = acc
+    step acc (y:ys) = step (snocLineTo acc y) ys
+
+
+
+-- | 'curvePath' consumes 4 points from the list on the 
+-- intial step (start, control1, control2, end) then steps 
+-- through the list taking 3 points at a time thereafter
+-- (control1,control2, end). Leftover points are discarded.    
+-- 
+-- 'curvePath' throws a runtime error if the supplied list
+-- is has less than 4 elements (start, control1, control2, end). 
+--
+curvePath :: (Floating u, Ord u, Tolerance u) 
+          => [Point2 u] -> AbsPath u
+curvePath (a:b:c:d:xs) = step (curve1 a b c d) xs
+  where
+    step acc (x:y:z:zs) = step (snocCurveTo acc (x,y,z)) zs
+    step acc _          = acc
+
+curvePath _            = error "curvePath - less than 4 elems."
+
+
+
+-- NOTE - need a proper arc path builder.
+
+
+
+-- | This is not an arc...
+-- 
+controlCurve :: (Floating u, Ord u, Tolerance u) 
+         => Point2 u -> Radian -> Radian -> Point2 u -> AbsPath u
+controlCurve start cin cout end = 
+    curve1 start (start .+^ v1) (end .+^ v2) end
+  where
+    sz     = 0.375 * (vlength $ pvec start end)
+    v1     = avec cin  sz
+    v2     = avec cout sz
+
+
+
+
+
+vectorPath :: (Floating u, Ord u, Tolerance u) 
+           => [Vec2 u] -> Point2 u -> AbsPath u
+vectorPath vecs p0 = vertexPath $ p0 : step p0 vecs
+  where
+    step _ []       = []
+    step pt (v1:vs) = let p1 = pt .+^ v1 in p1 : step p1 vs 
+
+
+vectorPathTheta :: (Real u, Floating u, Tolerance u) 
+                => [Vec2 u] -> Radian -> Point2 u -> AbsPath u 
+vectorPathTheta vs ang = vectorPath $ map (rotate ang) vs
+
+
+anaTrailPath :: (Floating u, Ord u, Tolerance u) 
+             => Point2 u -> AnaTrail u -> AbsPath u
+anaTrailPath pt trl = 
+    let (v1,ss) = destrAnaTrail trl in step (emptyPath $ pt .+^ v1) ss
+  where
+    step ac []                   = ac
+    step ac (TLine v1:xs)        = step (ac `snocLine` v1) xs
+    step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs
+  
+catTrailPath :: (Floating u, Ord u, Tolerance u) 
+             => Point2 u -> CatTrail u -> AbsPath u
+catTrailPath pt trl = step (emptyPath pt) $ destrCatTrail trl
+  where
+    step ac []                   = ac
+    step ac (TLine v1:xs)        = step (ac `snocLine` v1) xs
+    step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs
+  
+
+--------------------------------------------------------------------------------
+-- Queries
+
+-- | Is the path empty?
+--
+null :: AbsPath u -> Bool
+null = JL.null . _abs_path_elements
+
+-- | Length of the Path.
+--
+-- Length is the length of the path as it is drawn, it is not a 
+-- count of the number or path segments.
+--
+-- Length is cached so this operation is cheap - though this puts
+-- a tax on the build operations. 
+-- 
+length :: Num u => AbsPath u -> u
+length (AbsPath u _ _ _) = u
+
+
+--------------------------------------------------------------------------------
+-- Extension
+
+infixl 5 `snocLine`
+
+
+-- | Extend the path with a straight line segment from the 
+-- end-point defined by the supplied vector.
+--
+-- > infixl 5 `snocLine`
+--
+snocLine :: Floating u => AbsPath u -> Vec2 u -> AbsPath u
+snocLine (AbsPath u sp se ep) v1 = 
+  let u1        = vlength v1 
+      tail_line = AbsLineSeg u1 v1
+  in AbsPath (u + u1) sp (JL.snoc se tail_line) (ep .+^ v1)
+
+
+
+infixl 5 `snocLineTo`
+
+
+-- | Extend the path with a straight line segment from the 
+-- end-point to the supplied point.
+--
+-- > infixl 5 `snocLineTo`
+--
+snocLineTo :: Floating u => AbsPath u -> Point2 u -> AbsPath u
+snocLineTo (AbsPath u sp se1 ep) p1 = AbsPath (u + len) sp (snoc se1 s1) p1
+  where
+    s1@(AbsLineSeg len _) = lineSegment ep p1
+
+
+infixl 5 `snocCurve`
+
+-- | Extend the path from the end-point with a Bezier curve 
+-- segment formed by the supplied points.
+--
+-- > infixl 5 `snocCurve`
+-- 
+snocCurve :: (Floating u, Ord u, Tolerance u)
+          => AbsPath u -> (Vec2 u, Vec2 u, Vec2 u) -> AbsPath u
+snocCurve absp@(AbsPath _ _ _ ep) (v1,v2,v3) = snocCurveTo absp (p1,p2,p3)
+  where
+    p1 = ep .+^ v1
+    p2 = p1 .+^ v2
+    p3 = p2 .+^ v3
+ 
+
+infixl 5 `snocCurveTo`
+
+
+-- | Extend the path from the end-point with a Bezier curve 
+-- segment formed by the supplied points.
+--
+-- > infixl 5 `snocCurveTo`
+-- 
+snocCurveTo :: (Floating u, Ord u, Tolerance u)
+            => AbsPath u -> (Point2 u, Point2 u, Point2 u) -> AbsPath u
+snocCurveTo (AbsPath u sp se1 ep) (p1,p2,p3) = 
+    AbsPath (u + len) sp (snoc se1 s1) p3
+  where
+    s1@(AbsCurveSeg len _ _ _) = curveSegment ep p1 p2 p3
+ 
+
+-------------------------------------------------------------------------------- 
+
+
+
+segmentLength :: AbsPathSeg u -> u
+segmentLength (AbsLineSeg u _)       = u
+segmentLength (AbsCurveSeg u _ _ _)  = u
+
+
+segmentVector :: Num u => AbsPathSeg u -> Vec2 u
+segmentVector (AbsLineSeg  _ v1)       = v1
+segmentVector (AbsCurveSeg _ v1 v2 v3) = v1 ^+^ v2 ^+^ v3
+
+
+
+-- | Helper - construct a line segment.
+-- 
+lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u 
+lineSegment p0 p1 = lineSegmentV $ pvec p0 p1
+
+-- | Helper - construct a line segment.
+-- 
+lineSegmentV :: Floating u => Vec2 u -> AbsPathSeg u 
+lineSegmentV v1 = AbsLineSeg (vlength v1) v1
+
+
+-- | Helper - construct a curve segment.
+-- 
+curveSegment :: (Floating u, Ord u, Tolerance u) 
+             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPathSeg u 
+curveSegment p0 p1 p2 p3 = AbsCurveSeg len v1 v2 v3
+  where
+    len = bezierLength (BezierCurve p0 p1 p2 p3)
+    v1  = pvec p0 p1
+    v2  = pvec p1 p2
+    v3  = pvec p2 p3
+
+
+-- | Helper - construct the /empty/ but located path.
+-- 
+zeroPath :: Floating u => Point2 u -> AbsPath u 
+zeroPath p0 = AbsPath 0 p0 JL.empty p0
+   
+
+
+renderPath :: InterpretUnit u 
+         => PathMode -> AbsPath u -> Image u (AbsPath u)
+renderPath mode rp = replaceAns rp $ 
+    liftQuery (toPrimPath rp) >>= dcPath mode
+
+
+renderPath_ :: InterpretUnit u 
+          => PathMode -> AbsPath u -> Graphic u
+renderPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode
+
+
+-- | Turn a Path into an ordinary PrimPath.
+--
+-- Assumes path is properly formed - i.e. end point of one 
+-- segment is the same point as the start point of the next
+-- segment.
+--
+toPrimPath :: InterpretUnit u => AbsPath u -> Query u PrimPath
+toPrimPath (AbsPath _ start segs _) = 
+    uconvertCtxF start       >>= \dstart -> 
+    T.mapM uconvertCtxF segs >>= \dsegs  ->
+    return $ step1 dstart dsegs
+  where
+    step1 p0 se | JL.null se          = emptyPrimPath p0
+                | otherwise           = absPrimPath p0 $ step2 p0 (viewl se)
+
+    step2 _  EmptyL                   = []
+    step2 pt (e :< se)                = let (p1,s) = mkSeg pt e
+                                        in s : step2 p1 (viewl se)
+    
+    mkSeg p0 (AbsLineSeg  _ v1)       = let p1 = p0 .+^ v1
+                                        in (p1, absLineTo p1)
+    mkSeg p0 (AbsCurveSeg _ v1 v2 v3) = let p1 = p0 .+^ v1
+                                            p2 = p1 .+^ v2
+                                            p3 = p2 .+^ v3
+                                        in (p3, absCurveTo p1 p2 p3)
+
+
+
+
+
+
+-- | 'sortenPath' : @ left_dist * right_dist * path -> Path @
+--
+shortenPath :: (Real u , Floating u) 
+            => u  -> u -> AbsPath u -> AbsPath u
+shortenPath l r = shortenL l .  shortenR r 
+
+
+--------------------------------------------------------------------------------
+-- shorten from the left...
+
+-- | Note - shortening a line from the left by 
+-- greater-than-or-equal its length is operationally equivalent 
+-- to making a zero-length line at the end point.
+--
+shortenL :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u
+shortenL n path1@(AbsPath u startp segs ep) 
+    | n <  0                  = path1
+    | n >= u                  = AbsPath 0 ep mempty ep 
+    | otherwise               = step n startp (viewl segs)
+  where
+    step _ _  EmptyL    = AbsPath 0 ep mempty ep 
+    step d sp (e :< se) = let z     = segmentLength e
+                              snext = sp .+^ segmentVector e
+                          in case compare d z of
+                             GT -> step (d-z) snext (viewl se)
+                             EQ -> makeLeftPath (u-n) snext se ep
+                             LT -> let (spart,e1) = shortenSegL d sp e
+                                   in AbsPath (u-n) spart (e1 `cons` se) ep
+
+
+makeLeftPath :: Floating u 
+             => u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u 
+             -> AbsPath u
+makeLeftPath u sp se ep | JL.null se = line1 sp ep
+                        | otherwise  = AbsPath u sp se ep
+
+
+
+shortenSegL :: (Real u, Floating u) 
+            => u -> Point2 u -> AbsPathSeg u -> (Point2 u, AbsPathSeg u)
+shortenSegL n sp (AbsLineSeg  u v1)        = 
+    let v2  = shortenVec n v1 
+        sp' = sp .+^ avec (vdirection v1) n
+    in (sp', AbsLineSeg  (u-n) v2)
+
+shortenSegL n sp (AbsCurveSeg u v1 v2 v3)  = 
+    (q0, AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3))
+  where
+    (BezierCurve q0 q1 q2 q3) = let p1 = sp .+^ v1
+                                    p2 = p1 .+^ v2
+                                    p3 = p2 .+^ v3
+                                in snd $ subdividet (n/u) 
+                                                    (BezierCurve sp p1 p2 p3)
+     
+
+
+shortenVec :: (Real u, Floating u) => u -> Vec2 u -> Vec2 u
+shortenVec n v0 = v0 ^-^ v
+  where
+    v  = avec (vdirection v0) n
+
+
+--------------------------------------------------------------------------------
+-- shorten from the right ...
+ 
+-- | Note - shortening a line from the right by 
+-- greater-than-or-equal its length is operationally equivalent 
+-- to making a zero-length line at the start point.
+--
+shortenR :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u
+shortenR n path1@(AbsPath u sp segs endpt) 
+    | n < 0                   = path1
+    | n >= u                  = AbsPath 0 sp mempty sp 
+    | otherwise               = step n (viewr segs) endpt
+  where
+    step _ EmptyR    _  = AbsPath 0 sp mempty sp 
+    step d (se :> e) ep = let z     = segmentLength e 
+                              enext = ep .-^ segmentVector e
+                          in case compare d z of
+                              GT -> step (d-z) (viewr se) enext
+                              EQ -> makeRightPath n sp se enext
+                              LT -> let (e1,epart) = shortenSegR d e ep
+                                    in AbsPath (u-n) sp (se `snoc` e1) epart
+                         
+
+makeRightPath :: Floating u 
+              => u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u 
+              -> AbsPath u
+makeRightPath u sp se ep | JL.null se = line1 sp ep
+                         | otherwise  = AbsPath u sp se ep
+
+
+shortenSegR :: (Real u, Floating u) 
+            => u -> AbsPathSeg u -> Point2 u -> (AbsPathSeg u, Point2 u)
+shortenSegR n (AbsLineSeg u v1)        ep = 
+    let v2  = shortenVec n v1 
+        ep' = ep .-^ avec (vdirection v1) n
+    in (AbsLineSeg (u-n) v2, ep')
+
+shortenSegR n (AbsCurveSeg u v1 v2 v3) ep = 
+    (AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3), q3)
+  where
+    (BezierCurve q0 q1 q2 q3) = let p2 = ep .-^ v3
+                                    p1 = p2 .-^ v2
+                                    p0 = p1 .-^ v1
+                                in fst $ subdividet ((u-n)/u) 
+                                                    (BezierCurve p0 p1 p2 ep)
+     
+
+
+
+
+--------------------------------------------------------------------------------
+-- tips 
+
+tipL :: AbsPath u -> Point2 u
+tipL (AbsPath _ sp _ _) = sp
+
+
+tipR :: AbsPath u -> Point2 u
+tipR (AbsPath _ _ _ ep) = ep
+
+
+--------------------------------------------------------------------------------
+-- line direction
+
+
+
+-- | Direction of empty path is considered to be 0.
+--
+inclinationL :: (Real u, Floating u) => AbsPath u -> Radian
+inclinationL (AbsPath _ _ se _)  = step $ viewl se
+  where
+    step (AbsLineSeg  _ v1 :< _)       = vdirection v1
+    step (AbsCurveSeg _ v1 _  _  :< _) = vdirection v1
+    step _                             = 0
+
+
+-- | Direction of empty path is considered to be 0.
+--
+inclinationR :: (Real u, Floating u) => AbsPath u -> Radian
+inclinationR (AbsPath _ _ se _) = step $ viewr se
+  where
+    step (_ :> AbsLineSeg  _ v1)       = vdirection v1
+    step (_ :> AbsCurveSeg _ _  _  v3) = vdirection v3
+    step _                             = 0
+
+
+ 
+-- | Is the left tip a Bezier curve?
+--
+isBezierL :: AbsPath u -> Bool
+isBezierL (AbsPath _ _ se _) = step $ viewl se
+  where
+    step (AbsCurveSeg _ _ _ _ :< _) = True 
+    step _                          = False
+
+
+ 
+-- | Is the right tip a Bezier curve?
+-- 
+isBezierR :: AbsPath u -> Bool
+isBezierR (AbsPath _ _ se _) = step $ viewr se
+  where
+    step (_ :> AbsCurveSeg _ _ _ _) = True 
+    step _                          = False
+
+
+--------------------------------------------------------------------------------
+
+
+-- Return direction as well because the calculation is expensive...
+--
+midway :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)
+midway pa@(AbsPath u sp _ _) 
+    | u == 0    = (sp,0)
+    | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, inclinationR pa1)
+
+-- Just the midway point.
+--
+midway_ :: (Real u, Floating u) => AbsPath u -> Point2 u
+midway_ = fst . midway
+
+
+atstart :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)
+atstart pa@(AbsPath _ sp _ _) = (sp, inclinationL pa)
+
+atstart_ :: AbsPath u -> Point2 u
+atstart_ (AbsPath _ sp _ _) = sp
+
+
+atend :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian)
+atend pa@(AbsPath _ _ _ ep) = (ep, inclinationR pa)
+ 
+
+atend_ :: AbsPath u -> Point2 u
+atend_ (AbsPath _ _ _ ep) = ep
+
+
+-- nearstart, nearend, verynear ...
+
+
+
+
+--------------------------------------------------------------------------------
+-- Path Views cf. Data.Sequence
+
+
+infixr 5 :<<
+infixl 5 :>>
+
+data PathViewL u = EmptyPathL
+                 | PathSegment u :<< AbsPath u
+  deriving (Eq,Show) 
+
+type instance DUnit (PathViewL u) = u 
+
+type DPathViewL = PathViewL Double
+
+data PathViewR u = EmptyPathR
+                 | AbsPath u :>> PathSegment u
+  deriving (Eq,Show) 
+
+type instance DUnit (PathViewR u) = u 
+
+type DPathViewR = PathViewR Double
+
+
+
+-- | PathSegments are annotated with length.
+--
+--
+data PathSegment u = LineSeg  u (Point2 u) (Point2 u)
+                   | CurveSeg u (Point2 u) (Point2 u) (Point2 u) (Point2 u)
+  deriving (Eq,Show) 
+
+type instance DUnit (PathSegment u) = u 
+
+
+type DPathSegment = PathSegment Double
+
+
+--------------------------------------------------------------------------------
+
+instance Functor PathSegment where
+  fmap f (LineSeg d p0 p1)        = LineSeg (f d) (fmap f p0) (fmap f p1)
+  fmap f (CurveSeg d p0 p1 p2 p3) = 
+      CurveSeg (f d) (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3)
+
+instance Functor PathViewL where
+  fmap _ EmptyPathL   = EmptyPathL
+  fmap f (a :<< as)   = fmap f a :<< fmap f as
+
+instance Functor PathViewR where
+  fmap _ EmptyPathR   = EmptyPathR
+  fmap f (as :>> a)   = fmap f as :>> fmap f a
+
+--------------------------------------------------------------------------------
+
+
+
+pathViewL :: Num u => AbsPath u -> PathViewL u
+pathViewL (AbsPath len sp segs ep) = go (viewl segs)
+  where
+    go EmptyL                           = EmptyPathL
+     
+    go (AbsLineSeg d v1 :< se)        =
+        let p1 = sp .+^ v1 in LineSeg d sp p1 :<< AbsPath (len - d) p1 se ep
+
+    go (AbsCurveSeg d v1 v2 v3 :< se) =
+        let p1 = sp .+^ v1
+            p2 = p1 .+^ v2
+            p3 = p2 .+^ v3
+        in CurveSeg d sp p1 p2 p3 :<< AbsPath (len - d) p3 se ep
+
+
+pathViewR :: Num u => AbsPath u -> PathViewR u
+pathViewR (AbsPath len sp segs ep) = go (viewr segs)
+  where
+    go EmptyR                           = EmptyPathR 
+
+    go (se :> AbsLineSeg d v1)        = 
+       let p0 = ep .-^ v1 in AbsPath (len - d) sp se p0 :>> LineSeg d p0 ep
+
+    go (se :> AbsCurveSeg d v1 v2 v3) =  
+       let p2 = ep .-^ v3
+           p1 = p2 .-^ v2
+           p0 = p1 .-^ v1
+       in AbsPath (len - d) sp se p0 :>> CurveSeg d p0 p1 p2 ep
+
+
+
+--------------------------------------------------------------------------------
+
+
+-- Path should be same length afterwards.
+
+optimizeLines :: (Real u, Floating u, Ord u, Tolerance u) 
+              => AbsPath u -> AbsPath u
+optimizeLines (AbsPath _ sp0 segs _) =
+    outer (zeroPath sp0) (viewl segs)
+  where
+    outer acc (AbsLineSeg _ v1 :< se)              = 
+        inner acc (vdirection v1) v1 (viewl se)
+
+    outer acc (AbsCurveSeg u v1 v2 v3  :< se)      = 
+        outer (snocC acc u v1 v2 v3) (viewl se)
+
+    outer acc EmptyL                               = acc
+
+    inner acc d0 v0 (AbsLineSeg _ v1 :< se)        =
+        let d1 = vdirection v1
+        in if (d0 == vdirection v1) 
+          then inner acc d1 (v0 ^+^ v1) (viewl se)
+          else inner (snocV acc v0) d1 v1 (viewl se)
+
+    inner acc _  v0 (AbsCurveSeg u v1 v2 v3 :< se) = 
+        let acc1 = snocC (snocV acc v0) u v1 v2 v3
+        in outer acc1 (viewl se)
+
+    inner acc _  v0 EmptyL                         = snocV acc v0
+
+    snocC (AbsPath u sp se ep) u1 v1 v2 v3         = 
+        let tail_curve = AbsCurveSeg u1 v1 v2 v3 
+            vtotal     = v1 ^+^ v2 ^+^ v3 
+        in AbsPath (u+u1) sp (JL.snoc se tail_curve) (ep .+^ vtotal)
+
+    snocV (AbsPath u sp se ep) v1                  =
+        let u1        = vlength v1
+            tail_line = AbsLineSeg u1 v1
+        in AbsPath (u+u1) sp (JL.snoc se tail_line) (ep .+^ v1)
+
+
+--------------------------------------------------------------------------------
+-- Round corners
+
+
+segToCatTrail :: AbsPathSeg u -> CatTrail u
+segToCatTrail (AbsLineSeg _ v1)        = catline v1
+segToCatTrail (AbsCurveSeg _ v1 v2 v3) = catcurve v1 v2 v3
+
+-- | Because lookahead of 2 makes the rounding algos easier we
+-- decons to a list...
+--
+segmentListL :: AbsPath u -> (Point2 u, [AbsPathSeg u])
+segmentListL (AbsPath _ sp se _) = (sp, JL.toList se)
+
+-- | Round interior corners of a Path.
+--
+-- The path is treated as open - the start of the initial and end
+-- of the final segments are not rounded. Only straight line to 
+-- straight line joins are rounded, joins to or from Bezier 
+-- curves are not rounded.
+-- 
+-- Caution - all path segments are expected to be longer than
+-- 2x the round corner length, though this is not checked..
+--
+roundInterior :: (Real u, Floating u,Tolerance u) 
+              => u -> AbsPath u -> AbsPath u
+roundInterior du pth0 = catTrailPath pt ctrail
+  where
+    (pt,ss) = segmentListL pth0
+    ctrail  = roundInteriorCat du ss
+
+
+roundInteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u
+roundInteriorCat _  []     = mempty
+roundInteriorCat du (z:zs) = step mempty z zs
+  where
+    step ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) = 
+      let (x,k) = roundAB du v1 v2 in step (ac `mappend` x) k xs
+
+    step ac prev            (x:xs)             = 
+       let tprev = segToCatTrail prev in step (ac `mappend` tprev) x xs
+
+    step ac prev            []                 = ac `mappend` segToCatTrail prev
+
+roundAB :: (Real u, Floating u) 
+        => u -> Vec2 u -> Vec2 u -> (CatTrail u, AbsPathSeg u)
+roundAB du v1 v2 = 
+    (catline v1' `mappend` tcurve, lineSegmentV v2')
+  where
+    v1'      = shortenVec du v1
+    v2'      = shortenVec du v2
+
+    tv1      = avec (vdirection v1) du
+    tv2      = avec (vdirection v2) du
+    base_vec = tv1 ^+^ tv2
+    bw       = vlength base_vec
+    h        = sqrt $ pow2 du - (pow2 $ 0.5 * bw)
+    clockd   = clockDirection v1 v2
+    tcurve   = triCurve clockd bw (-h) (vdirection base_vec)
+    
+    -- note the (-h) in tricurve is wrong, we need to account 
+    -- for CCW or CW properly...
+
+pow2 :: Num a => a -> a
+pow2 x = x ^ (2::Int)
+
+-- Form corners inside a /triangle/ Bezier.
+
+
+-- | Round a \"closed\" path. 
+--
+-- Caution - all path sgements are expected to be longer than
+-- 2x the round corner length, though this is not checked..
+--
+roundExterior :: (Real u, Floating u, Tolerance u) 
+              => u -> AbsPath u -> AbsPath u
+roundExterior du pth0 
+   | isBezierR pth0 || isBezierL pth0 = roundInterior du pth0
+   | otherwise                        = catTrailPath pt ctrail
+  where
+   (pt,ss) = segmentListL pth0
+   ctrail  = roundExteriorCat du ss
+
+
+roundExteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u
+roundExteriorCat _  []                        = mempty
+
+roundExteriorCat _  (AbsCurveSeg _ _ _ _ : _) = 
+    error "runExteriorCat - unreachable."
+
+roundExteriorCat du (z@(AbsLineSeg _ v0):zs)  = step0 z zs
+  where
+    step0 (AbsLineSeg _ v1) xs = 
+      let seg0 = lineSegmentV $ shortenVec du v1 in step1 mempty seg0 xs
+
+    step0 _                 _  = error "roundExteriorCat - unreachable 1."
+    
+    step1 ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) = 
+      let (x,k) = roundAB du v1 v2 in step1 (ac `mappend` x) k xs
+
+    step1 ac prev              (x:xs)             = 
+      let tprev = segToCatTrail prev in step1 (ac `mappend` tprev) x xs
+
+    step1 ac (AbsLineSeg _ v1) []                 = 
+      let (t,_) = roundAB du v1 v0 in ac `mappend` t
+
+    step1 _  _                 []                 = 
+      error "roundExteriorCat - unreachable 2."
+
+
+-- | Redraw an 'AbsPath' replacing the Bezier curves with three 
+-- lines along the control vectors.
+--
+deBezier :: Floating u => AbsPath u -> AbsPath u
+deBezier (AbsPath _ sp segs _) = 
+    step (emptyPath sp) (viewl segs)
+  where
+    step ac EmptyL                         = ac
+
+    step ac (AbsLineSeg _ v1 :< xs)        = 
+      step (ac `snocLine` v1) (viewl xs) 
+
+    step ac (AbsCurveSeg _ v1 v2 v3 :< xs) = 
+      step (ac `snocLine` v1 `snocLine` v2 `snocLine` v3) (viewl xs) 
+
+-- | This does not extract the control points of Bezier curves.
+-- 
+pathMajorPoints :: Num u => AbsPath u -> [Point2 u]
+pathMajorPoints (AbsPath _ sp segs _) = sp : step sp (viewl segs)
+  where
+    step _  EmptyL = []
+
+    step pt (AbsLineSeg _ v1 :< xs)        = 
+      let p1 = pt .+^ v1 in p1 : step p1 (viewl xs) 
+
+    step pt (AbsCurveSeg _ v1 v2 v3 :< xs) = 
+      let p1 = pt .+^ v1 in p1 : step (p1 .+^ (v2 ^+^ v3)) (viewl xs) 
+    
+
+-- | This extracts the control points of Bezier curves.
+-- 
+pathAllPoints :: Num u => AbsPath u -> [Point2 u]
+pathAllPoints (AbsPath _ sp segs _) = sp : step sp (viewl segs)
+  where
+    step _  EmptyL                         = []
+    
+    step pt (AbsLineSeg _ v1 :< xs)        = 
+      let p1 = pt .+^ v1 in p1 : step p1 (viewl xs) 
+
+    step pt (AbsCurveSeg _ v1 v2 v3 :< xs) = 
+      let p1 = pt .+^ v1 
+          p2 = p1 .+^ v2
+          p3 = p2 .+^ v3
+      in p1 : p2 : p3 : step p3 (viewl xs) 
+
+
+
+--------------------------------------------------------------------------------
+-- Path division
+
+
+-- | Divide a path returning intermediate points and direction
+--
+-- Args are initial-prefix, division size, trailing size.
+-- 
+-- Generation is stopped if the remainder of the path is shorter
+-- than the trailing size.
+--
+pathdiv :: (Real u, Floating u) 
+        => u -> u -> u -> AbsPath u -> [(Point2 u, Radian)]
+pathdiv ana sz end = step . shortenL ana 
+  where
+    step pth | length pth < end = []
+             | otherwise         = atstart pth : step (shortenL sz pth)
+                          
diff --git a/src/Wumpus/Drawing/Paths/Connectors.hs b/src/Wumpus/Drawing/Paths/Connectors.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Paths/Connectors.hs
+++ /dev/null
@@ -1,247 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Paths.Connectors
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Library of connector paths...
---
--- \*\* WARNING \*\* this module is experimental and may change 
--- significantly in future revisions.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Paths.Connectors
-  ( 
-
-    ConnectorPath
-  , DConnectorPath
-  , sconnect
-
-  , connLine
-
-  , connRightVH
-  , connRightHV
-  , connRightVHV
-  , connRightHVH
-
-  , connIsosceles
-  , connIsosceles2
-  , connLightningBolt
-
-  , connIsoscelesCurve
-  , connSquareCurve
-  , connUSquareCurve
-
-  , connTrapezoidCurve
-  , connZSquareCurve
-  , connUZSquareCurve
-
-  ) where
-
-import Wumpus.Drawing.Paths.Base
-import Wumpus.Drawing.Paths.ControlPoints
-
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AffineSpace                         -- package: vector-space
-
-import Control.Applicative
-import Prelude hiding ( length )
-
-
--- | Note - a ConnectorPath is not drawn automatically, it is a
--- @ConnectorCF@ not a @ConnectorGraphic@ or @ConnectorImage@.
---
-type ConnectorPath u = ConnectorCF u (Path u)
-
-type DConnectorPath = ConnectorPath Double
-
-
-
--- Maybe this should be ConnectorPath u -> ConnectorImage u (Path u) instead?
--- This would be closer to the new shapes...
---
-sconnect :: Num u 
-         => ConnectorPath u -> Point2 u -> Point2 u -> Image u (Path u)
-sconnect mf p0 p1 = 
-    connect mf p0 p1 >>= \cpath -> 
-    intoImage (pure cpath) (openStroke $ toPrimPath cpath)  
-                    
-
--- | Build the path with interior round corners.
--- 
-roundCornerPath :: (Real u, Floating u, FromPtSize u) 
-                => [Point2 u] -> CF (Path u)
-roundCornerPath xs = getRoundCornerSize >>= \sz -> 
-    if sz == 0 then return (traceLinePoints xs) 
-               else return (roundInterior  sz xs)
-
-
-
---------------------------------------------------------------------------------
-
--- | Connect with a straight line.
---
-connLine :: Floating u => ConnectorPath u
-connLine = promoteR2 $ \p0 p1 -> pure $ line p0 p1
-
-
-
--- | Right-angled connector - go vertical, then go horizontal.
---
-connRightVH :: (Real u, Floating u, FromPtSize u) => ConnectorPath u
-connRightVH = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->
-    let mid = P2 x0 y1 in roundCornerPath [p0, mid, p1]
-
-
-
--- | Right-angled connector - go horizontal, then go vertical.
---
-connRightHV :: (Real u, Floating u, FromPtSize u) 
-            => ConnectorPath u
-connRightHV = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> 
-    let mid = P2 x1 y0 in roundCornerPath [p0, mid, p1]
-
--- | Right-angled connector - go vertical for the supplied 
--- distance, go horizontal, go vertical again for the 
--- remaining distance.
--- 
-connRightVHV :: (Real u, Floating u, FromPtSize u) 
-             => u -> ConnectorPath u
-connRightVHV v = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 x1 _) ->
-    let a0 = p0 .+^ vvec v
-        a1 = a0 .+^ hvec (x1 - x0)
-    in roundCornerPath [p0, a0, a1, p1]
-
-
--- | Right-angled connector - go horizontal for the supplied 
--- distance, go verical, go horizontal again for the 
--- remaining distance.
--- 
-connRightHVH :: (Real u, Floating u, FromPtSize u) 
-             => u -> ConnectorPath u
-connRightHVH h = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 _ y1) -> 
-    let a0 = p0 .+^ hvec h
-        a1 = a0 .+^ vvec (y1 - y0)
-    in roundCornerPath [p0,a0,a1,p1]
-
-
--- | /Triangular/ joint.
--- 
--- @u@ is the altitude of the triangle.
---
-connIsosceles :: (Real u, Floating u, FromPtSize u) 
-              => u -> ConnectorPath u 
-connIsosceles dy = promoteR2 $ \ p0 p1 -> 
-    let mid_pt  = midpointIsosceles dy p0 p1
-    in roundCornerPath [p0, mid_pt, p1]
- 
-    
-
-
-
--- | Double /triangular/ joint.
--- 
--- @u@ is the altitude of the triangle.
---
-connIsosceles2 :: (Real u, Floating u, FromPtSize u)
-               => u -> ConnectorPath u 
-connIsosceles2 u = promoteR2 $ \ p0 p1 -> 
-    let (cp0,cp1) = dblpointIsosceles u p0 p1
-    in roundCornerPath [ p0, cp0, cp1, p1 ]
-
-
-
--- | /Lightning bolt/ joint - a two joint connector with an /axis/
--- perpendicular to the connector direction.
--- 
--- @u@ is the half length of the of the axis.
---
-connLightningBolt :: (Real u, Floating u, FromPtSize u) 
-                  => u -> ConnectorPath u 
-connLightningBolt u = promoteR2 $ \ p0 p1 -> 
-    let cp0 = midpointIsosceles   u  p0 p1
-        cp1 = midpointIsosceles (-u) p0 p1
-    in roundCornerPath [ p0, cp0, cp1, p1 ]
-
---------------------------------------------------------------------------------
-
-
-
--- | Form a curve inside an isosceles triangle. 
---
--- The two Bezier control points take the same point - the
--- altitude of the triangle. The curve tends to be quite shallow
--- relative to the altitude.
---
--- @u@ is the altitude of the triangle.
---
-connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u 
-connIsoscelesCurve u = promoteR2 $ \ p0 p1 ->
-    let control_pt  = midpointIsosceles u p0 p1
-    in pure $ traceCurvePoints [p0, control_pt, control_pt, p1]
-   
-    
-
--- | Form a curve inside a square. 
---
--- The two Bezier control points take the /top/ corners. The
--- curve tends to be very deep.
--- 
-connSquareCurve :: (Real u, Floating u) => ConnectorPath u 
-connSquareCurve = promoteR2 $ \ p0 p1 ->
-    let (cp0,cp1) = squareFromBasePoints p0 p1
-    in pure $ traceCurvePoints [p0, cp0, cp1, p1]
-
-
-
--- | Form a curve inside a square. 
---
--- As per 'connSquareCurve' but the curve is drawn /underneath/
--- the line formed between the start and end points.
--- 
--- (Underneath is modulo the direction, of course).
--- 
-connUSquareCurve :: (Real u, Floating u) => ConnectorPath u 
-connUSquareCurve = promoteR2 $ \ p0 p1 -> 
-    let (cp0,cp1) = usquareFromBasePoints p0 p1
-    in pure $ traceCurvePoints [p0, cp0, cp1, p1]
-
-
--- | altitude * ratio_to_base 
---
--- Form a curve inside a trapeziod.
--- 
-connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u 
-connTrapezoidCurve u ratio_to_base = promoteR2 $ \p0 p1 -> 
-    let (cp0,cp1)  = trapezoidFromBasePoints u ratio_to_base p0 p1
-    in pure $ traceCurvePoints [p0, cp0, cp1, p1]
-
-
--- | Make a curve within a square, following the corner points as
--- a Z.
---
-connZSquareCurve :: (Real u, Floating u) => ConnectorPath u 
-connZSquareCurve = promoteR2 $ \p0 p1 -> 
-    let (cp0,cp1)  = squareFromCornerPoints p0 p1
-    in pure $ traceCurvePoints [p0,cp0,cp1,p1]
-
--- | Make a curve within a square, following the corner points as
--- a Z.
---
--- The order of tracing flips the control points, so this is an
--- /underneath/ version of 'connZSquareCurve'.
--- 
-connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u 
-connUZSquareCurve = promoteR2 $ \ p0 p1 ->  
-   let (cp0,cp1)  = squareFromCornerPoints p0 p1 
-   in pure $ traceCurvePoints [p0,cp1,cp0,p1]
-
diff --git a/src/Wumpus/Drawing/Paths/ControlPoints.hs b/src/Wumpus/Drawing/Paths/ControlPoints.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Paths/ControlPoints.hs
+++ /dev/null
@@ -1,189 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Paths.ControlPoints
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Collection of point manufacturing functions.
---
--- \*\* WARNING \*\* this module is experimental and may change 
--- significantly in future revisions.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Paths.ControlPoints
-  ( 
-
-    midpointIsosceles
-  , dblpointIsosceles
-
-  , rectangleFromBasePoints
-  , squareFromBasePoints
-  , usquareFromBasePoints
-
-  , trapezoidFromBasePoints
-
-  , squareFromCornerPoints
-
-  ) where
-
-import Wumpus.Basic.Kernel
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AffineSpace                         -- package: vector-space
-
-
-
-
--- | 'midpointIsosceles' : 
--- @ altitude * start_pt * end_pt -> mid_pt @
---
--- Triangular midpoint.
--- 
--- @u@ is the altitude of the triangle - negative values of u 
--- form the triangle below the line.
---
-midpointIsosceles :: (Real u, Floating u) 
-                  => u -> Point2 u -> Point2 u -> Point2 u
-midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = 
-    mid_pt .+^ avec perp_ang u
-  where
-    mid_pt    = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1))
-    perp_ang  = (pi*0.5) + vdirection (pvec p1 p2) 
-
-
-
--- | 'dblpointIsosceles' : 
--- @ altitude * start_pt * end_pt * (third_pt, two_thirds_pt) @
--- 
--- Double triangular joint - one joint at a third of the line
--- length, the other at two thirds.
--- 
-dblpointIsosceles :: (Real u, Floating u) 
-                      => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u)  
-dblpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = 
-    (mid1 .+^ avec perp_ang u, mid2 .-^ avec perp_ang u)
-  where
-    mid1      = P2 (x1 + 0.33*(x2-x1)) (y1 + 0.33*(y2-y1))
-    mid2      = P2 (x1 + 0.66*(x2-x1)) (y1 + 0.66*(y2-y1))
-    perp_ang  = (pi*0.5) + vdirection (pvec p1 p2) 
-
-
---------------------------------------------------------------------------------
-
-
-
--- | 'rectangleFromBasePoints' : 
--- @ altitude * start_pt * end_pt * (top_left, top_right) @
--- 
--- Control points forming a rectangle. 
---
--- The two manufactured control points form the top corners, 
--- so the supplied points map as @start_point == bottom_left@ and 
--- @end_point == bottom_right@.
---
-rectangleFromBasePoints :: (Real u, Floating u) 
-                  => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u)
-rectangleFromBasePoints u p1 p2 = (cp1, cp2)
-  where
-    base_vec  = pvec p1 p2
-    theta     = vdirection base_vec
-    cp1       = displacePerpendicular u theta p1
-    cp2       = displacePerpendicular u theta p2
-
-
--- | 'squareFromBasePoints' : 
--- @ start_pt -> end_pt -> (top_left, top_right) @
--- 
--- Control points forming a square - side_len derived from the 
--- distance between start and end points.
---
--- The two manufactured control points form the top corners, 
--- so the supplied points map as @start_point == bottom_left@ and 
--- @end_point == bottom_right@.
---
-squareFromBasePoints :: (Real u, Floating u) 
-                     => Point2 u -> Point2 u -> (Point2 u, Point2 u)
-squareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2
-  where
-    side_len  = vlength $ pvec p1 p2
-
-
--- | 'usquareFromBasePoints' : 
--- @ start_pt -> end_pt -> (bottom_left, bottom_right) @
--- 
--- Control points forming a square - side_len derived from the 
--- distance between start and end points.
---
--- As per 'squareFromBasePoints' but the square is drawn 
--- /underneath/ the line formed between the start and end points.
--- (Underneath is modulo the direction, of course).
---
--- The two manufactured control points form the /bottom/ corners, 
--- so the supplied points map as @start_point == top_left@ and 
--- @end_point == top_right@.
--- 
-usquareFromBasePoints :: (Real u, Floating u) 
-                      => Point2 u -> Point2 u -> (Point2 u, Point2 u)
-usquareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2
-  where
-    side_len  = negate $ vlength $ pvec p1 p2
-
-
-
-
-
--- | 'trapezoidFromBasePoints' : 
--- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @
---
--- Control points form an isosceles trapezoid.
---
--- The two manufactured control points form the top corners, 
--- so the supplied points map as @start_point == bottom_left@ and 
--- @end_point == bottom_right@.
--- 
-trapezoidFromBasePoints :: (Real u, Floating u) 
-                        => u -> u -> Point2 u -> Point2 u 
-                        -> (Point2 u, Point2 u) 
-trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2)
-  where
-    base_vec  = pvec p1 p2
-    base_len  = vlength base_vec
-    theta     = vdirection base_vec
-    half_ulen = 0.5 * ratio_to_base * base_len
-    base_mid  = displaceParallel (0.5 * base_len) theta p1
-    ubase_mid = displacePerpendicular u theta base_mid
-    cp1       = displaceParallel (-half_ulen) theta ubase_mid
-    cp2       = displaceParallel   half_ulen  theta ubase_mid
-
-
-
-
--- | 'squareFromCornerPoints' : 
--- @ altitude * start_pt * end_pt * (top_left, bottom_right) @
--- 
--- Control points forming a square bisected by the line from 
--- start_pt to end_pt. 
---
--- The two manufactured control points form the top_left and
--- bottom_right corners, so the supplied points map as 
--- @start_point == bottom_left@ and @end_point == top_right@.
---
-squareFromCornerPoints :: (Real u, Floating u) 
-                       => Point2 u -> Point2 u -> (Point2 u, Point2 u) 
-squareFromCornerPoints p1 p2 = (cp1, cp2)
-  where
-    base_vec  = pvec p1 p2
-    half_len  = 0.5 * (vlength base_vec)
-    theta     = vdirection base_vec
-    base_mid  = displaceParallel half_len theta p1
-    cp1       = displacePerpendicular   half_len  theta base_mid
-    cp2       = displacePerpendicular (-half_len) theta base_mid
-
diff --git a/src/Wumpus/Drawing/Paths/Illustrate.hs b/src/Wumpus/Drawing/Paths/Illustrate.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Paths/Illustrate.hs
@@ -0,0 +1,61 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Paths.Illustrate
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Illustrate a path - show the construction of its Bezier curves.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Paths.Illustrate
+  ( 
+
+    path_as_control_box
+  , path_with_control_points
+    
+  ) where
+
+import Wumpus.Drawing.Paths.Base
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Colour
+import Data.Monoid
+
+
+
+grey1 :: RGBi
+grey1 = RGBi 200 200 200
+
+-- | Illustrate the control points as a /boxed/ path - Bezier 
+-- curves are replaced with straight lines spanning the 
+-- control points.
+--
+path_as_control_box :: (Floating u, InterpretUnit u) => AbsPath u -> Graphic u
+path_as_control_box path1 = pic1 `mappend` pic2
+  where
+    pic1  = localize (set_line_width 8 . stroke_colour grey1) $
+              renderPath_ OSTROKE path1
+    pic2  = localize (set_line_width 1 . stroke_colour black) $
+              renderPath_ OSTROKE $ deBezier path1
+
+
+path_with_control_points :: (Floating u, InterpretUnit u) => AbsPath u -> Graphic u
+path_with_control_points path1 = pic1 `mappend` pic2
+  where
+    pic1  = localize (fill_colour grey1) $
+              mconcat $ map (disk1 `at`) $ pathAllPoints path1
+
+    pic2  = localize (set_line_width 1 . stroke_colour black) $
+              renderPath_ OSTROKE path1
+
+    disk1 = dcDisk DRAW_FILL 3
+
diff --git a/src/Wumpus/Drawing/Paths/Intersection.hs b/src/Wumpus/Drawing/Paths/Intersection.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Paths/Intersection.hs
@@ -0,0 +1,318 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Paths.Intersection
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Intersection of Paths with (infinite) lines.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Paths.Intersection
+  ( 
+
+    Line(..)
+  , inclinedLine
+  , vectorLine
+  , Ray(..)
+  , inclinedRay
+
+  , lineLineIntersection
+  , linePathIntersection
+  , linePathSegmentIntersection
+  , rayPathIntersection
+  , rayPathSegmentIntersection
+
+  , rectangleRadialIntersect
+  , isoscelesTriangleRadialIntersect
+
+  ) where
+
+import Wumpus.Drawing.Basis.BezierCurve
+import Wumpus.Drawing.Basis.ShapeTrails
+import Wumpus.Drawing.Paths.Base
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+--------------------------------------------------------------------------------
+
+
+--
+-- Private types - LineEquation, 2x2 matrix and bezier curve.
+--
+-- Although these types are /general/ exposing them just leads 
+-- to a bloated API.
+--
+-- If these types are fund to be more useful - they can go into 
+-- @Drawing.Basis@.
+--
+
+
+-- | Line in equational form, i.e. @Ax + By + C = 0@.
+--
+data LineEquation u = LineEquation 
+      { _line_eqn_A :: !u
+      , _line_eqn_B :: !u
+      , _line_eqn_C :: !u 
+      }
+  deriving (Eq,Show)
+
+type instance DUnit (LineEquation u) = u
+
+
+-- | 'lineEquation' : @ point1 * point2 -> LineEquation @
+-- 
+-- Construct a line in equational form bisecting the supplied 
+-- points.
+--
+lineEquation :: Num u => Point2 u -> Point2 u -> LineEquation u
+lineEquation (P2 x1 y1) (P2 x2 y2) = LineEquation a b c 
+  where
+    a = y1 - y2
+    b = x2 - x1
+    c = (x1*y2) - (x2*y1)
+
+-- | 2x2 matrix, considered to be in row-major form.
+-- 
+-- > (M2'2 a b
+-- >       c d)
+--
+-- 
+
+data Matrix2'2 u = M2'2 !u !u   !u !u
+  deriving (Eq)
+
+type instance DUnit (Matrix2'2 u) = u
+
+
+-- | Determinant of a 2x2 matrix.
+--
+det2'2 :: Num u => Matrix2'2 u -> u
+det2'2 (M2'2 a b c d) = a*d - b*c
+
+
+
+
+
+--------------------------------------------------------------------------------
+
+-- | Infinite line represented by two points.
+--
+data Line u = Line (Point2 u) (Point2 u)
+  deriving (Eq,Show)
+
+type instance DUnit (Line u) = u
+
+
+
+-- | 'inclinedLine' : @ point * ang -> Line @
+--
+
+
+-- | Make an infinite line passing through the supplied point 
+-- inclined by @ang@.
+--
+inclinedLine :: Floating u => Point2 u -> Radian -> Line u
+inclinedLine radial_ogin ang = Line radial_ogin (radial_ogin .+^ avec ang 100)
+
+vectorLine :: Num u => Vec2 u -> Point2 u -> Line u
+vectorLine v1 p0 = Line p0 (p0 .+^ v1)
+
+
+-- | A 'Ray' extends from the first point, through the second to
+-- infinity.
+--
+-- ('Line' extends to infinity in both directions.
+--
+data Ray u = Ray (Point2 u) (Point2 u) 
+  deriving (Eq,Show)
+
+type instance DUnit (Ray u) = u
+
+
+-- | Make an infinite ray starting from the supplied point 
+-- inclined by @ang@.
+--
+inclinedRay :: Floating u => Point2 u -> Radian -> Ray u
+inclinedRay ray_ogin ang = Ray ray_ogin (ray_ogin .+^ avec ang 100)
+  
+
+
+
+
+pointOnLineSeg :: (Real u, Floating u, Ord u, Tolerance u) 
+               => Point2 u -> (Point2 u, Point2 u) -> Bool
+pointOnLineSeg pt (p0,p1) 
+    | pt == p0 || pt == p1 = True
+    | otherwise            = 
+        vdirection v1 == vdirection v0 && vlength v1 `tLTE`  vlength v0
+  where
+    v0 = pvec p0 p1
+    v1 = pvec p0 pt
+                 
+
+-- | 'interLineLine' : @ line1 * line2 -> Maybe Point @
+-- 
+-- Find the intersection of two lines, if there is one. 
+--
+-- Lines are infinite they are represented by points on them, 
+-- they are not line segments.
+--
+-- An answer of @Nothing@ may indicate either the lines coincide
+-- or the are parallel.
+--
+lineLineIntersection :: (Fractional u, Ord u, Tolerance u)
+                     => Line u -> Line u -> Maybe (Point2 u)
+lineLineIntersection (Line p1 p2) (Line q1 q2) = 
+    if det_co `tEQ` 0 then Nothing 
+                      else Just $ P2 (det_xm / det_co) (det_ym / det_co)
+  where
+    -- Ax + By + C = 0
+    LineEquation a1 b1 c1 = lineEquation p1 p2
+    LineEquation a2 b2 c2 = lineEquation q1 q2
+
+    coeffM                = M2'2 a1 b1  a2 b2
+    det_co                = det2'2 coeffM
+
+    xM                    = M2'2  (negate c1) b1  (negate c2) b2
+    det_xm                = det2'2 xM
+
+    yM                    = M2'2  a1 (negate c1) a2 (negate c2)
+    det_ym                = det2'2 yM
+
+
+linePathIntersection :: (Real u, Floating u, Ord u, Tolerance u) 
+                     => Line u -> AbsPath u -> Maybe (Point2 u)
+linePathIntersection ln = step . pathViewL
+  where
+    step EmptyPathL = Nothing
+    step (a :<< bs) = let ans = linePathSegmentIntersection ln a
+                      in case ans of
+                         Nothing -> step (pathViewL bs)
+                         _       -> ans
+
+linePathSegmentIntersection :: (Real u, Floating u, Ord u, Tolerance u) 
+                            => Line u -> PathSegment u -> Maybe (Point2 u)
+linePathSegmentIntersection ln1 (LineSeg _ p0 p1)        = 
+    mbWithin p0 p1 $ lineLineIntersection ln1 (Line p0 p1)
+
+linePathSegmentIntersection (Line pa pb) (CurveSeg _ p0 p1 p2 p3) = 
+    lineEqnCurveIntersection (lineEquation pa pb) (BezierCurve p0 p1 p2 p3)
+
+
+mbWithin :: (Real u, Floating u, Ord u, Tolerance u) 
+         => Point2 u -> Point2 u -> Maybe (Point2 u) -> Maybe (Point2 u)
+mbWithin p0 p1 mb = mb >>= \pt -> 
+    if pointOnLineSeg pt (p0,p1) then Just pt else Nothing
+
+lineEqnCurveIntersection :: (Floating u, Ord u, Tolerance u) 
+                         => LineEquation u -> BezierCurve u -> Maybe (Point2 u)
+lineEqnCurveIntersection eqnline c0 = step c0
+  where
+    step c  = case cut eqnline c of
+                Left pt     -> Just pt      -- cut at start or end
+                Right False -> Nothing
+                Right True  -> let (a,b) = subdivide c
+                               in case step a of
+                                   Just pt -> Just pt
+                                   Nothing -> step b
+
+
+rayPathIntersection :: (Real u, Floating u, Ord u, Tolerance u) 
+                    => Ray u -> AbsPath u -> Maybe (Point2 u)
+rayPathIntersection ry = step . pathViewL
+  where
+    step EmptyPathL = Nothing
+    step (a :<< bs) = let ans = rayPathSegmentIntersection ry a
+                      in case ans of
+                         Nothing -> step (pathViewL bs)
+                         _       -> ans
+
+rayPathSegmentIntersection :: (Real u, Floating u, Ord u, Tolerance u) 
+                           => Ray u -> PathSegment u -> Maybe (Point2 u)
+rayPathSegmentIntersection (Ray p0 p1) seg = 
+    test =<< linePathSegmentIntersection (Line p0 p1) seg
+  where
+    test pt = if vdirection (pvec p0 p1) == vdirection (pvec p0 pt)
+              then Just pt else Nothing
+ 
+-- | Is the curve cut by the line? 
+--
+-- The curve might cut at the start or end points - which is good
+-- as it saves performing a subdivision, but it makes the return 
+-- type a bit involved.
+--
+cut :: (Floating u , Ord u, Tolerance u)
+    => LineEquation u -> BezierCurve u -> Either (Point2 u) Bool
+cut eqnline (BezierCurve p0 p1 p2 p3) = 
+    if d0 `tEQ` 0 then Left p0 else
+    if d3 `tEQ` 0 then Left p3 else
+    let ds = [d0,d1,d2,d3] in Right $ not $ all pve ds || all nve ds
+  where
+    pve = (>= 0)
+    nve = (< 0)
+    d0  = pointLineDistance p0 eqnline 
+    d1  = pointLineDistance p1 eqnline 
+    d2  = pointLineDistance p2 eqnline 
+    d3  = pointLineDistance p3 eqnline 
+
+
+
+
+-- | 'pointLineDistance' : @ point -> line -> Distance @
+--
+-- Find the distance from a point to a line in equational form
+-- using this formula:
+-- 
+-- > P(u,v) 
+-- > L: Ax + By + C = 0
+-- >
+-- > (A*u) + (B*v) + C 
+-- > -----------------
+-- > sqrt $ (A^2) +(B^2)
+--
+-- A positive distance indicates the point is above the line, 
+-- negative indicates below.
+--
+pointLineDistance :: Floating u => Point2 u -> LineEquation u -> u
+pointLineDistance (P2 u v) (LineEquation a b c) = 
+    ((a*u) + (b*v) + c) / base
+  where
+    base = sqrt $ (a^two) + (b^two)
+    two  :: Integer
+    two  = 2
+
+
+--------------------------------------------------------------------------------
+-- Intersections on common shapes
+
+-- | Answer is vector from center.
+--
+rectangleRadialIntersect :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                         => u -> u -> Radian -> Maybe (Vec2 u) 
+rectangleRadialIntersect w h ang = 
+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp 
+  where
+    rp = anaTrailPath zeroPt $ rectangle_trail w h
+
+
+
+-- | Answer is vector from centroid.
+--
+isoscelesTriangleRadialIntersect :: (Real u, Floating u
+                                    , InterpretUnit u, Tolerance u) 
+                                 => u -> u -> Radian -> Maybe (Vec2 u) 
+isoscelesTriangleRadialIntersect bw h ang = 
+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp 
+  where
+    rp = anaTrailPath zeroPt $ isosceles_triangle_trail bw h
diff --git a/src/Wumpus/Drawing/Paths/MonadicConstruction.hs b/src/Wumpus/Drawing/Paths/MonadicConstruction.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Paths/MonadicConstruction.hs
+++ /dev/null
@@ -1,160 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Paths.MonadicConstruction
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Build paths monadically.
---
--- \*\* WARNING \*\* this module is an experiment, and may 
--- change significantly or even be dropped from future revisions.
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Paths.MonadicConstruction
-  ( 
-
-    PathM
-  , runPath
-  , execPath
-
-  , tip
-
-  , lineto
-  , rlineto
-  , hline
-  , vline
-
-  , bezierto
-  , curveto
-
-  , verticalHorizontal
-  , horizontalVertical
-
-  ) where
-
-import Wumpus.Basic.Utils.HList
-import Wumpus.Drawing.Paths.Base
-
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AffineSpace                         -- package: vector-space
-
-import Control.Applicative
-import Data.List
-
-
--- Are connectors and paths quite different things?
---
--- It looks like they are - connectors always know start and end 
--- points.
---
-
-
--- State monad version is quite good - it ameliorates the problem
--- of joining to the end point of an empty path...
-
-data St u = St
-      { current_point :: Point2 u 
-      , path_acc      :: H (Path u)
-      }
-
-
-newtype PathM u a = PathM { getPathM :: St u -> (a,St u) }
-
-
-instance Functor (PathM u) where
-  fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1)
-
-
-instance Applicative (PathM u) where
-  pure a    = PathM $ \s -> (a,s)
-  mf <*> ma = PathM $ \s -> let (f,s1) = getPathM mf s
-                                (a,s2) = getPathM ma s1
-                            in (f a,s2)
-
-instance Monad (PathM u) where
-  return a  = PathM $ \s -> (a,s)
-  m >>= k   = PathM $ \s -> let (a,s1) = getPathM m s in
-                            (getPathM . k) a s1
-
-
-
--- Running the path is (probably) agnostic to the DrawingCtx.
---
-runPath :: Floating u => Point2 u -> PathM u a -> (a, Path u)
-runPath start mf = 
-    let (a,s') = getPathM mf s in (a, post $ toListH $ path_acc s')
-  where
-    s = St { current_point = start
-           , path_acc      = emptyH
-           }
-    post []     = line start start
-    post (x:xs) = foldl' append x xs  
-
-execPath :: Floating u => Point2 u -> PathM u a -> Path u
-execPath start mf = snd $ runPath start mf
-
-snocline :: Floating u => Vec2 u -> PathM u ()
-snocline v = PathM $ \(St pt ac) -> let ep = pt .+^ v 
-                                    in ((), St ep (ac `snocH` line pt ep))
-
-
-tip :: PathM u (Point2 u)
-tip = PathM $ \s -> (current_point s,s)
-
-
-lineto :: Floating u => Point2 u -> PathM u ()
-lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `snocH` line p0 pt))
-
-rlineto :: Floating u => Vec2 u -> PathM u ()
-rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy))
-
-
-hline :: Floating u => u -> PathM u ()
-hline len = snocline (hvec len) 
-
-vline :: Floating u => u -> PathM u ()
-vline len = snocline (vvec len) 
-
-
-
-bezierto :: (Floating u, Ord u) 
-         => Point2 u -> Point2 u -> Point2 u -> PathM u ()
-bezierto c1 c2 ep = PathM $ \(St p0 ac) -> 
-    ((), St ep (ac `snocH` curve p0 c1 c2 ep))
-
-
-
-
-
---
-
-
-curveto :: (Floating u, Ord u) 
-        => Radian -> Radian -> Point2 u -> PathM u ()
-curveto cin cout end = PathM $ \(St p0 ac) -> 
-    let seg  = curveByAngles p0 cin cout end 
-        ac1  = ac `snocH` seg
-        end1 = tipR seg
-    in ((), St end1 ac1) 
-
-
-
-
-verticalHorizontal :: Floating u => Point2 u -> PathM u ()
-verticalHorizontal (P2 x y) = 
-    tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y)
-
-horizontalVertical :: Floating u => Point2 u -> PathM u ()
-horizontalVertical (P2 x y) = 
-    tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y)
-
diff --git a/src/Wumpus/Drawing/Paths/PathBuilder.hs b/src/Wumpus/Drawing/Paths/PathBuilder.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Paths/PathBuilder.hs
@@ -0,0 +1,470 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Paths.PathBuilder
+-- Copyright   :  (c) Stephen Tetley 2011-2012
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Build relative paths monadically.
+--
+-- \*\* WARNING \*\* this module is an experiment, and may 
+-- change significantly or even be dropped from future revisions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Paths.PathBuilder
+  ( 
+
+
+    GenPathSpec
+  , PathSpec
+  , Vamp(..)
+
+
+  , runGenPathSpec
+  , execGenPathSpec
+  , evalGenPathSpec
+  , stripGenPathSpec
+
+  , runPathSpec
+  , runPathSpec_
+
+  , runPivot
+
+
+  , penline
+  , pencurve
+ 
+  
+  , breakPath
+  , hpenline
+  , vpenline
+  , apenline
+
+  , penlines
+  , pathmoves
+
+  , vamp
+  , cycleSubPath
+  , updatePen
+ 
+  ) where
+
+import Wumpus.Drawing.Paths.Base
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+import Prelude hiding ( null, cycle, lines )
+
+-- 
+-- TODO - possibly we need two drawing contexts one for the pen 
+-- and one for the decoration trace.
+-- 
+-- Alternatively PathSt should have a local DrawingContext for the 
+-- pen.
+--
+
+
+-- | Note - a path spec has an immutable start point like 
+-- @LocDrawing@.
+--
+-- Effectively a path is draw in a local coordinate system with 
+-- @(0,0)@ as the origin.
+--
+newtype GenPathSpec st u a = GenPathSpec { 
+    getGenPathSpec :: DrawingContext -> PathSt st -> (a, PathSt st, CatPrim) }
+
+type instance DUnit   (GenPathSpec st u a) = u
+type instance UState  (GenPathSpec st u a) = st
+
+type PathSpec u a = GenPathSpec () u a
+
+
+data PathSt st = PathSt
+      { st_active_pen       :: ActivePen
+      , st_pen_ctx          :: DrawingContext
+      , st_cumulative_path  :: AbsPath Double
+      , st_user_state       :: st
+      }
+
+
+-- | Note - this formulation doesn\'t support monoidal append.
+-- 
+-- Information gets lost for this one (we really would want to 
+-- draw the left-hand-side):
+--
+-- > PEN_DOWN _ _ `mappend` PEN_UP
+--
+-- So it has to be part of the state not the writer.
+-- 
+data ActivePen = PEN_UP 
+               | PEN_DOWN (AbsPath Double)
+                         
+
+
+zeroActivePen :: DPoint2 -> ActivePen
+zeroActivePen pt = PEN_DOWN (emptyPath pt)
+
+
+data Vamp u = Vamp
+       { vamp_move :: Vec2 u
+       , vamp_conn :: ConnectorGraphic u
+       }
+
+type instance DUnit (Vamp u) = u
+
+
+--------------------------------------------------------------------------------
+-- Instances
+
+
+-- Functor
+
+instance Functor (GenPathSpec st u) where
+  fmap f ma = GenPathSpec $ \ctx s -> 
+                let (a,s1,w1) = getGenPathSpec ma ctx s 
+                in (f a,s1,w1)
+
+
+-- Applicative
+
+instance Applicative (GenPathSpec st u) where
+  pure a    = GenPathSpec $ \_   s -> (a, s, mempty)
+  mf <*> ma = GenPathSpec $ \ctx s -> 
+                let (f,s1,w1) = getGenPathSpec mf ctx s
+                    (a,s2,w2) = getGenPathSpec ma ctx s1
+                in (f a, s2, w1 `mappend` w2)
+
+
+-- Monad
+
+instance Monad (GenPathSpec st u) where
+  return a  = GenPathSpec $ \_   s -> (a, s, mempty)
+  ma >>= k  = GenPathSpec $ \ctx s -> 
+                let (a,s1,w1) = getGenPathSpec ma ctx s
+                    (b,s2,w2) = (getGenPathSpec . k) a ctx s1
+                in (b, s2, w1 `mappend` w2)
+
+
+-- Monoid 
+
+instance Monoid a => Monoid (GenPathSpec st u a) where
+  mempty           = GenPathSpec $ \_   s -> (mempty, s, mempty)
+  ma `mappend` mb  = GenPathSpec $ \ctx s -> 
+                       let (a,s1,w1) = getGenPathSpec ma ctx s
+                           (b,s2,w2) = getGenPathSpec mb ctx s1
+                       in (a `mappend` b, s2, w1 `mappend` w2)
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (GenPathSpec st u) where
+  askDC           = GenPathSpec $ \ctx s -> (ctx, s, mempty)
+  asksDC f        = GenPathSpec $ \ctx s -> (f ctx, s, mempty)
+  localize upd ma = GenPathSpec $ \ctx s -> 
+                      getGenPathSpec ma (upd ctx) s
+
+
+-- UserStateM 
+
+instance UserStateM (GenPathSpec st u) where
+  getState        = GenPathSpec $ \_ s -> 
+                      (st_user_state s, s, mempty)
+  setState ust    = GenPathSpec $ \_ s -> 
+                      ((), s {st_user_state = ust} , mempty)
+  updateState upd = GenPathSpec $ \_ s -> 
+                      let ust = st_user_state s
+                      in ((), s {st_user_state =  upd ust}, mempty)
+
+
+
+-- Note - all these need to peek at the cumulative path
+
+-- LocationM
+
+instance InterpretUnit u => LocationM (GenPathSpec st u) where
+  location = locationImpl
+
+
+-- CursorM 
+
+instance InterpretUnit u => CursorM (GenPathSpec st u) where
+  moveby   = movebyImpl
+
+
+-- InsertlM
+
+instance InterpretUnit u => InsertlM (GenPathSpec st u) where
+  insertl  = insertlImpl
+
+
+           
+--------------------------------------------------------------------------------
+-- Run functions
+
+runGenPathSpec :: InterpretUnit u 
+               => st -> PathMode -> GenPathSpec st u a 
+               -> LocImage u (a, st, AbsPath u)
+runGenPathSpec st mode ma = promoteLoc $ \pt -> 
+    askDC >>= \ctx ->
+    let P2 dx dy  = normalizeF (dc_font_size ctx) pt
+        st_zero   = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) st
+        (a,s1,w1) = getGenPathSpec ma ctx st_zero
+        dpath     = translate dx dy $ st_cumulative_path s1
+        upath     = dinterpF (dc_font_size ctx) dpath
+        pctx      = st_pen_ctx s1
+        (_,w2)    = runImage pctx (renderActivePen mode $ st_active_pen s1) 
+        wfinal    = cpmove (V2 dx dy) $ w1 `mappend` w2
+    in replaceAns (a, st_user_state s1, upath) $ primGraphic wfinal
+
+
+-- Note - eval and exec return the AbsPath this is as-per RWS
+-- which returns @w@ for execRWS (s,w) and evalRWS (a,w)
+--
+
+evalGenPathSpec :: InterpretUnit u
+                => st -> PathMode -> GenPathSpec st u a
+                -> LocImage u (a, AbsPath u)
+evalGenPathSpec st mode ma = 
+    (\(a,_,w) -> (a,w)) <$> runGenPathSpec st mode ma
+
+    
+
+execGenPathSpec :: InterpretUnit u
+                => st -> PathMode -> GenPathSpec st u a
+                -> LocImage u (st, AbsPath u)
+execGenPathSpec st mode ma =
+    (\(_,s,w) -> (s,w)) <$> runGenPathSpec st mode ma
+
+
+
+stripGenPathSpec :: InterpretUnit u
+                 => st -> PathMode -> GenPathSpec st u a
+                 -> LocQuery u (a, st, AbsPath u)
+stripGenPathSpec st mode ma = stripLocImage $ runGenPathSpec st mode ma
+
+
+runPathSpec :: InterpretUnit u
+            => PathMode -> PathSpec u a -> LocImage u (a, AbsPath u)
+runPathSpec mode ma = evalGenPathSpec () mode ma
+
+runPathSpec_ :: InterpretUnit u
+             => PathMode -> PathSpec u a -> LocGraphic u
+runPathSpec_ mode ma = ignoreAns $ evalGenPathSpec () mode ma
+
+
+
+-- Monad run function nomenclature:
+--
+-- > run  - both
+-- > eval - answer (no state)
+-- > exec - state (no answer)
+-- 
+-- Note RWS always returns the @w@.
+--
+-- For Wumpus:
+-- 
+-- > run  - monadic answer, and the writer /construction/
+-- > eval - just the monadic answer
+-- > exec - just the writer /construction/.
+--
+-- In all case the CatPrim inside the LocImage may contain 
+-- additional graphics.
+--
+-- Client code can use @ignoreAns@ to generate a @LocGraphic@
+-- from the @LocImage@.
+
+
+
+-- | Helper.
+--
+renderActivePen :: PathMode -> ActivePen -> DGraphic 
+renderActivePen _    PEN_UP              = mempty
+renderActivePen mode (PEN_DOWN abs_path) = renderPath_ mode abs_path
+
+
+
+
+
+
+
+-- | Form a \"pivot path\" drawing from two path specifications.
+-- The start point of the drawing is the pivot formed by joining
+-- the paths.
+--
+runPivot :: (Floating u, InterpretUnit u)
+          => PathSpec u a -> PathSpec u a -> LocGraphic u
+runPivot ma mb = promoteLoc $ \pt -> 
+    askDC >>= \ctx ->
+    let dpt        = normalizeF (dc_font_size ctx) pt
+        st_zero    = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) ()
+        (p1,s1,w1) = getGenPathSpec mz ctx st_zero
+        dp1        = normalizeF (dc_font_size ctx) p1
+        v1         = pvec dpt dp1
+        pctx       = st_pen_ctx s1
+        (_,w2)     = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s1
+        wfinal     = w1 `mappend` w2
+    in primGraphic $ cpmove (negateV v1) wfinal
+  where
+    mz = ma >> location >>= \pt -> mb >> return pt
+
+
+--------------------------------------------------------------------------------
+-- operations
+
+
+locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u)
+locationImpl = GenPathSpec $ \ctx s ->
+    let pt  = tipR $ st_cumulative_path s 
+        upt = dinterpF (dc_font_size ctx) pt
+    in (upt, s, mempty)
+
+
+-- | 'extendPaths' extends both the @cumulative_path@ and the 
+-- @active_pen@. If the pen is up it, changes to a pendown.
+--
+extendPaths :: DVec2 -> PathSt st -> PathSt st
+extendPaths v1 s@(PathSt { st_cumulative_path = cp
+                         , st_active_pen      = pen} )  = 
+    s { st_cumulative_path = snocLine cp v1, st_active_pen = upd pen }
+  where
+    upd PEN_UP          = let pt = tipR cp in PEN_DOWN $ line1 pt (pt .+^ v1)
+    upd (PEN_DOWN absp) = PEN_DOWN $ snocLine absp v1
+
+
+
+
+-- | Extend the path with a line, drawn by the pen.
+-- 
+penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()
+penline v1 = GenPathSpec $ \ctx s -> 
+   let sz  = dc_font_size ctx
+       dv1 = normalizeF sz v1
+   in ((), extendPaths dv1 s, mempty)
+
+
+
+-- | @extendPenC@ causes a pendown.
+--
+extendPathsC :: DVec2 -> DVec2 -> DVec2 -> PathSt st -> PathSt st
+extendPathsC v1 v2 v3 s@(PathSt { st_cumulative_path = cp
+                                , st_active_pen      = pen} )  = 
+    s { st_cumulative_path = snocCurve cp (v1,v2,v3), st_active_pen = upd pen }
+  where
+    upd PEN_UP          = let p0 = tipR cp 
+                              p1 = p0 .+^ v1
+                              p2 = p1 .+^ v2
+                              p3 = p2 .+^ v3
+                          in PEN_DOWN $ curve1 p0 p1 p2 p3
+    upd (PEN_DOWN absp) = PEN_DOWN $ snocCurve absp (v1,v2,v3)
+
+
+
+-- | Extend the path with a curve, drawn by the pen.
+-- 
+pencurve :: InterpretUnit u 
+        => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u ()
+pencurve v1 v2 v3 = GenPathSpec $ \ctx s -> 
+   let sz  = dc_font_size ctx
+       dv1 = normalizeF sz v1
+       dv2 = normalizeF sz v2
+       dv3 = normalizeF sz v3
+   in ((), extendPathsC dv1 dv2 dv3 s, mempty)
+
+
+-- | @moveby@ causes a pen up.
+--
+movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()
+movebyImpl v1 = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) ->
+    let sz      = dc_font_size ctx
+        dv1     = normalizeF sz v1
+        (_,w1)  = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s
+        cpath   = snocLine (st_cumulative_path s) dv1
+    in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }, w1)
+
+
+breakPath :: InterpretUnit u => GenPathSpec st u ()
+breakPath = movebyImpl (V2 0 0)
+
+hpenline :: InterpretUnit u => u -> GenPathSpec st u ()
+hpenline dx = penline (hvec dx)
+
+vpenline :: InterpretUnit u => u -> GenPathSpec st u ()
+vpenline dy = penline (vvec dy)
+
+
+apenline :: (Floating u, InterpretUnit u) 
+         => Radian -> u -> GenPathSpec st u ()
+apenline ang d = penline (avec ang d)
+
+penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()
+penlines = mapM_ penline
+
+pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()
+pathmoves = mapM_ moveby
+
+
+
+insertlImpl :: InterpretUnit u 
+            => LocImage u a -> GenPathSpec st u a
+insertlImpl gf = GenPathSpec $ \ctx s ->
+    let upt     = dinterpF (dc_font_size ctx) (tipR $ st_cumulative_path s)
+        (a,wcp) = runLocImage ctx upt gf
+    in (a, s, wcp)
+
+
+
+vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u ()
+vamp (Vamp v1 conn) = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) ->
+    let sz     = dc_font_size ctx
+        dv1    = normalizeF sz v1
+        (_,w1) = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s
+        upt    = dinterpF sz (tipR $ st_cumulative_path s)
+        (_,w2) = runConnectorImage ctx upt (upt .+^ v1) conn
+        cpath  = snocLine (st_cumulative_path s) dv1
+    in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }
+          , w1 `mappend` w2)
+
+
+cycleSubPath :: DrawMode -> GenPathSpec st u ()
+cycleSubPath mode = GenPathSpec $ \_ s@(PathSt {st_pen_ctx = pctx}) ->
+    let (_,w1) = runImage pctx $ renderActivePen (fn mode) (st_active_pen s)
+    in ((), s { st_active_pen = PEN_UP }, w1)
+  where
+    fn DRAW_STROKE      = CSTROKE
+    fn DRAW_FILL        = CFILL
+    fn DRAW_FILL_STROKE = CFILL_STROKE
+
+
+
+-- Design note 
+--
+-- Should pen changing be @local@ style vis the Reader monad or a 
+-- state change with the State monad?
+-- 
+-- Now switched to state change.
+--
+
+
+-- | Note - updates the pen but doesn\'t draw, the final path
+-- will be drawing with the last updated context.
+--
+updatePen :: DrawingContextF -> GenPathSpec st u ()
+updatePen upd = GenPathSpec $ \_ s@(PathSt { st_pen_ctx = pctx})  ->
+    ((), s { st_pen_ctx = upd pctx}, mempty )
+
diff --git a/src/Wumpus/Drawing/Paths/Vamps.hs b/src/Wumpus/Drawing/Paths/Vamps.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Paths/Vamps.hs
@@ -0,0 +1,53 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Paths.Vamps
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Library of vamps (currently small).
+--
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Paths.Vamps
+  ( 
+
+    squareWE
+
+  ) where
+
+import Wumpus.Drawing.Paths.PathBuilder ( Vamp(..) )
+import Wumpus.Drawing.Paths.Base
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+-- TODO - library of useful / illustrative vamps (circle, square etc.)
+
+
+
+-- 
+--
+squareWE :: (Real u, Floating  u, Ord u, Tolerance u, InterpretUnit u) 
+         => u -> Vamp u
+squareWE diam = Vamp { vamp_move = hvec diam
+                     , vamp_conn = conn }
+  where
+    conn = promoteConn $ \p1 p2 -> 
+             let dir = vdirection $ pvec p1 p2
+             in renderPath_ CSTROKE $ vectorPathTheta path1 dir p1
+
+    hdiam = 0.5 * diam 
+    path1 = [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ]
+
+
+-- Drawing a cirle picks the half point on the vamp_move vector...
+
diff --git a/src/Wumpus/Drawing/Shapes.hs b/src/Wumpus/Drawing/Shapes.hs
--- a/src/Wumpus/Drawing/Shapes.hs
+++ b/src/Wumpus/Drawing/Shapes.hs
@@ -20,12 +20,29 @@
   , module Wumpus.Drawing.Shapes.Circle
   , module Wumpus.Drawing.Shapes.Diamond
   , module Wumpus.Drawing.Shapes.Ellipse
+  , module Wumpus.Drawing.Shapes.InvSemicircle
+  , module Wumpus.Drawing.Shapes.InvSemiellipse
+  , module Wumpus.Drawing.Shapes.InvTriangle
+  , module Wumpus.Drawing.Shapes.Parallelogram
   , module Wumpus.Drawing.Shapes.Rectangle
-
+  , module Wumpus.Drawing.Shapes.Semicircle
+  , module Wumpus.Drawing.Shapes.Semiellipse
+  , module Wumpus.Drawing.Shapes.Trapezium
+  , module Wumpus.Drawing.Shapes.Triangle
   ) where
 
 import Wumpus.Drawing.Shapes.Base
 import Wumpus.Drawing.Shapes.Circle
 import Wumpus.Drawing.Shapes.Diamond
 import Wumpus.Drawing.Shapes.Ellipse
+import Wumpus.Drawing.Shapes.InvSemicircle
+import Wumpus.Drawing.Shapes.InvSemiellipse
+import Wumpus.Drawing.Shapes.InvTriangle
+import Wumpus.Drawing.Shapes.Parallelogram
 import Wumpus.Drawing.Shapes.Rectangle
+import Wumpus.Drawing.Shapes.Semicircle
+import Wumpus.Drawing.Shapes.Semiellipse
+import Wumpus.Drawing.Shapes.Trapezium
+import Wumpus.Drawing.Shapes.Triangle
+
+
diff --git a/src/Wumpus/Drawing/Shapes/Base.hs b/src/Wumpus/Drawing/Shapes/Base.hs
--- a/src/Wumpus/Drawing/Shapes/Base.hs
+++ b/src/Wumpus/Drawing/Shapes/Base.hs
@@ -1,10 +1,9 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
 -- |
--- Module      :  Wumpus.Drawing.Shapes.Base2
+-- Module      :  Wumpus.Drawing.Shapes.Base
 -- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
@@ -21,69 +20,199 @@
   ( 
 
 
-    LocShape
-  , intoLocShape
+    Shape
+  , DShape
+
+  , shapeMap
+  , makeShape
   , strokedShape
+  , dblStrokedShape
   , filledShape
   , borderedShape
+  , rstrokedShape
+  , rfilledShape
+  , rborderedShape
 
   , roundCornerShapePath
 
+  , updatePathAngle
+  , setDecoration
+
   , ShapeCTM
   , makeShapeCTM
   , ctmCenter
   , ctmAngle
-  , projectPoint
-
- 
+  , ctmLocale
+  , projectFromCtr
 
   ) where
 
-import Wumpus.Basic.Kernel
 import Wumpus.Drawing.Paths
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Colour ( white )
 
+import Data.AffineSpace                         -- package: vector-space
 
 import Control.Applicative
 
+-- import Data.Traversable ( Traversable )
+-- import qualified Data.Traversable as T
 
-type LocShape u a = LocCF u (a, Path u)
+-- | Shape is a record of three /LocTheta/ functions - 
+-- functions /from Point and Angle to answer/. 
+--
+-- The @shape_path_fun@ returns a path. When the Shape is drawn, 
+-- the rendering function (@strokedShape@, etc.) uses the path for 
+-- drawing and returns the polymorphic answer @a@ of the 
+-- @shape_ans_fun@. Lastly the @shape_decoration@ function can 
+-- instantiated to add decoration (e.g. text) to the Shape as it 
+-- is rendered.
+--
+-- The @a@ of the @shape_ans_fun@ represents some concrete shape 
+-- object (e.g. a Rectangle, Triangle etc.). Crucial for shape 
+-- objects is that they support Anchors - this allows connectors 
+-- to address specific locations on the Shape border so 
+-- \"node and link\" diagrams can be made easily.
+--
+data Shape t u = Shape 
+      { shape_ans_fun     :: LocThetaQuery u (t u)
+      , shape_path_fun    :: LocThetaQuery u (AbsPath u) 
+      , shape_decoration  :: LocThetaGraphic u
+      }
 
+type instance DUnit (Shape t u) = u
 
-intoLocShape :: LocCF u a -> LocCF u (Path u) -> LocCF u (a,Path u)
-intoLocShape = liftA2 (,)
+type DShape t = Shape t Double
 
-strokedShape :: Num u => LocShape u a -> LocImage u a
-strokedShape mf = 
-   promoteR1 $ \pt -> 
-     (mf `at` pt) >>= \(a,spath) -> 
-     intoImage (pure a) (closedStroke $ toPrimPath spath)
 
+--------------------------------------------------------------------------------
 
-filledShape :: Num u => LocShape u a -> LocImage u a
-filledShape mf = 
-   promoteR1 $ \pt -> 
-     (mf `at` pt) >>= \(a,spath) -> 
-     intoImage (pure a) (filledPath $ toPrimPath spath)
+shapeMap :: InterpretUnit u 
+         => (t u -> t' u) -> Shape t u -> Shape t' u
+shapeMap f = (\s sf -> s { shape_ans_fun = qpromoteLocTheta $ \pt ang -> 
+                                           fmap f $ qapplyLocTheta sf pt ang }) 
+                <*> shape_ans_fun
 
 
-borderedShape :: Num u => LocShape u a -> LocImage u a
-borderedShape mf = 
-   promoteR1 $ \pt -> 
-     (mf `at` pt) >>= \(a,spath) -> 
-     intoImage (pure a) (borderedPath $ toPrimPath spath)
+-- Note - there are no instances of Applicative, Monad, 
+-- DrawingCtxM... so Shapes cannot have localized drawing props.
+--
+-- @localize@ must be performed in the context of @strokeShape@, 
+-- @fillShape@ etc.
+--
 
+
+
+--------------------------------------------------------------------------------
+
+
+makeShape :: InterpretUnit u
+          => LocThetaQuery u (t u) -> LocThetaQuery u (AbsPath u) -> Shape t u
+makeShape f g = Shape { shape_ans_fun    = f
+                      , shape_path_fun   = g
+                      , shape_decoration = emptyLocThetaImage
+                      }
+
+
+
+
+strokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)
+strokedShape = shapeToLoc (dcClosedPath DRAW_STROKE)
+
+
+-- | Note - this is simplistic double stroking - draw a background 
+-- line with triple thickness and draw a white line on top.
+--
+-- I think this is what TikZ does, but it works better for TikZ 
+-- where the extra thickness seems to be accounted for by the 
+-- anchors. For Wumpus, arrows cut into the outside black line.
+--
+-- Probably Wumpus should calculate two paths instead.
+--
+dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)
+dblStrokedShape sh = decorateAbove back fore 
+  where
+    img  = shapeToLoc (dcClosedPath DRAW_STROKE) sh
+    back = getLineWidth >>= \lw ->
+           localize (set_line_width $ lw * 3.0) img
+    fore = ignoreAns $ localize (stroke_colour white) img
+
+
+
+filledShape :: InterpretUnit u => Shape t u -> LocImage u (t u)
+filledShape = shapeToLoc (dcClosedPath DRAW_FILL)
+
+
+borderedShape :: InterpretUnit u => Shape t u -> LocImage u (t u)
+borderedShape = shapeToLoc (dcClosedPath DRAW_FILL_STROKE)
+
+
+shapeToLoc :: InterpretUnit u
+           => (PrimPath -> Graphic u) -> Shape t u -> LocImage u (t u)
+shapeToLoc drawF sh = promoteLoc $ \pt -> 
+    applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh)  pt 0 >>= \a -> 
+    applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt 0 >>= \spath -> 
+    let g2 = atIncline (shape_decoration sh) pt 0 
+    in replaceAns a (decorateAbove g2 $ liftQuery (toPrimPath spath) >>= drawF)
+
+
+
+rstrokedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)
+rstrokedShape = shapeToLocTheta (dcClosedPath DRAW_STROKE)
+
+
+rfilledShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)
+rfilledShape = shapeToLocTheta (dcClosedPath DRAW_FILL)
+
+
+rborderedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u)
+rborderedShape = shapeToLocTheta (dcClosedPath DRAW_FILL_STROKE)
+
+
+shapeToLocTheta :: InterpretUnit u
+                => (PrimPath -> Graphic u) -> Shape t u -> LocThetaImage u (t u)
+shapeToLocTheta drawF sh = promoteLocTheta $ \pt theta -> 
+    applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh) pt theta >>= \a -> 
+    applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt theta >>= \spath -> 
+    let g2 = atIncline (shape_decoration sh) pt theta
+    in replaceAns a $ decorateAbove g2 (liftQuery (toPrimPath spath) >>= drawF)
+
+
+
 -- | Draw the shape path with round corners.
 -- 
-roundCornerShapePath :: (Real u, Floating u, FromPtSize u) 
-                     => [Point2 u] -> CF (Path u)
-roundCornerShapePath xs = getRoundCornerSize >>= \sz -> 
-    if sz == 0 then return (traceLinePoints xs) 
-               else return (roundTrail  sz xs)
+roundCornerShapePath :: (Real u, Floating u, InterpretUnit u, Tolerance u)
+                     => u -> [Point2 u] -> Query u (AbsPath u)
+roundCornerShapePath sz xs = 
+    if sz `tEQ` 0 then return (vertexPath xs) 
+                  else return (roundExterior sz $ vertexPath xs)
 
+-- | The path angle can be modified. This allows /inverse/ 
+-- versions of shapes (e.g. InvTriangle) to be made by
+-- wrapping a base Shape but rotating the path prior to drawing 
+-- it.
+-- 
+-- Only the Path needs rotating, the decoration takes the original 
+-- angle. The anchors are typically implemented by rotating the 
+-- correspoding anchor of the wrapped Shape about its center.
+-- 
+updatePathAngle :: InterpretUnit u 
+                => (Radian -> Radian) -> Shape t u -> Shape t u
+updatePathAngle f = 
+    (\s fi -> s { shape_path_fun = qpromoteLocTheta $ \pt ang -> 
+                                   qapplyLocTheta fi pt (mvTheta ang) })
+      <*> shape_path_fun
+  where
+    mvTheta = circularModulo . f 
 
+setDecoration :: LocThetaGraphic u -> Shape t u -> Shape t u
+setDecoration gf = (\s -> s { shape_decoration = gf })
 
+
+
 --------------------------------------------------------------------------------
 -- CTM
 
@@ -93,33 +222,50 @@
 
 data ShapeCTM u = ShapeCTM 
       { ctm_center              :: Point2 u
-      , ctm_scale_x             :: !u
-      , ctm_scale_y             :: !u
+      , ctm_scale_x             :: !Double
+      , ctm_scale_y             :: !Double
       , ctm_rotation            :: Radian
       }
   deriving (Eq,Ord,Show)
 
-
 type instance DUnit (ShapeCTM u) = u
 
-makeShapeCTM :: Num u => Point2 u -> ShapeCTM u
-makeShapeCTM pt = ShapeCTM { ctm_center   = pt
-                           , ctm_scale_x  = 1
-                           , ctm_scale_y  = 1
-                           , ctm_rotation = 0 }
 
+instance Functor ShapeCTM where
+  fmap f = (\s i -> s { ctm_center = fmap f i }) <*> ctm_center
 
 
+makeShapeCTM :: Point2 u -> Radian -> ShapeCTM u
+makeShapeCTM pt ang = ShapeCTM { ctm_center   = pt
+                               , ctm_scale_x  = 1
+                               , ctm_scale_y  = 1
+                               , ctm_rotation = ang }
 
-instance Num u => Scale (ShapeCTM u) where
-  scale sx sy = (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy })
-                  <*> ctm_scale_x <*> ctm_scale_y
 
+ctmCenter :: ShapeCTM u -> Point2 u
+ctmCenter = ctm_center
 
-instance Rotate (ShapeCTM u) where
-  rotate ang = (\s i -> s { ctm_rotation = circularModulo $ i+ang })
-                  <*> ctm_rotation
+ctmAngle :: ShapeCTM u -> Radian
+ctmAngle = ctm_rotation
 
+ctmLocale :: ShapeCTM u -> (Point2 u, Radian)
+ctmLocale ctm = (ctm_center ctm, ctm_rotation ctm)
+
+
+instance (Fractional u) => Scale (ShapeCTM u) where
+  scale sx sy = (\s x y pt -> s { ctm_scale_x = x*sx
+                                , ctm_scale_y = y*sy 
+                                , ctm_center  = scale sx sy pt })
+                    <*> ctm_scale_x <*> ctm_scale_y <*> ctm_center
+
+
+instance (Real u, Floating u) => Rotate (ShapeCTM u) where
+  rotate ang = (\s i pt -> let ctr = rotate ang pt
+                           in s { ctm_rotation = circularModulo $ i+ang
+                                , ctm_center   = ctr })
+                    <*> ctm_rotation <*> ctm_center
+
+
 instance (Real u, Floating u) => RotateAbout (ShapeCTM u) where
   rotateAbout ang pt = 
     (\s ctr i -> s { ctm_rotation = circularModulo $ i+ang
@@ -127,25 +273,18 @@
       <*> ctm_center <*> ctm_rotation
 
 
-instance Num u => Translate (ShapeCTM u) where
-  translate dx dy = (\s (P2 x y) -> s { ctm_center = P2 (x+dx) (y+dy) })
-                      <*> ctm_center
-
+instance (Num u) => Translate (ShapeCTM u) where
+  translate dx dy = 
+    (\s i -> s { ctm_center = translate dx dy i })
+      <*> ctm_center
 
 
 
-ctmCenter :: ShapeCTM u  -> Point2 u
-ctmCenter = ctm_center
-
-ctmAngle :: ShapeCTM u -> Radian
-ctmAngle = ctm_rotation
-
-
+projectFromCtr :: (Real u, Floating u) => Vec2 u -> ShapeCTM u -> Anchor u
+projectFromCtr v (ShapeCTM { ctm_center   = ctr
+                           , ctm_scale_x  = sx
+                           , ctm_scale_y  = sy
+                           , ctm_rotation = theta }) = 
+     let v1 = rotate theta $ scale sx sy $ v in ctr .+^ v1
 
-projectPoint :: (Real u, Floating u) => Point2 u -> ShapeCTM u  -> Point2 u
-projectPoint (P2 x y) (ShapeCTM { ctm_center   = (P2 dx dy)
-                                , ctm_scale_x  = sx
-                                , ctm_scale_y  = sy
-                                , ctm_rotation = theta     }) =
-    translate dx dy $ rotate theta $ P2 (sx*x) (sy*y)
 
diff --git a/src/Wumpus/Drawing/Shapes/Circle.hs b/src/Wumpus/Drawing/Shapes/Circle.hs
--- a/src/Wumpus/Drawing/Shapes/Circle.hs
+++ b/src/Wumpus/Drawing/Shapes/Circle.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -32,7 +31,6 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space 
 
 import Control.Applicative
 
@@ -45,49 +43,56 @@
       { circ_ctm    :: ShapeCTM u
       , circ_radius :: !u 
       }
-  deriving (Eq,Show)
-  
-type DCircle = Circle Double
 
-type instance DUnit (Circle u) = u
+type instance DUnit (Circle u) = u  
 
+type DCircle = Circle Double
 
+instance Functor Circle where
+  fmap f (Circle ctm r) = Circle (fmap f ctm) (f r)
 
 
-mapCircleCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u
-mapCircleCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm
+--------------------------------------------------------------------------------
+-- Affine trans
 
-instance Num u => Scale (Circle u) where
-  scale sx sy = mapCircleCTM (scale sx sy)
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u
+mapCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm
 
 
-instance Rotate (Circle u) where
-  rotate ang = mapCircleCTM (rotate ang)
-                  
 
+instance (Real u, Floating u) => Rotate (Circle u) where
+  rotate ang            = mapCTM (rotate ang)
+                  
 instance (Real u, Floating u) => RotateAbout (Circle u) where
-  rotateAbout ang pt = mapCircleCTM (rotateAbout ang pt)
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
 
+instance Fractional u => Scale (Circle u) where
+  scale sx sy           = mapCTM (scale sx sy)
 
 instance Num u => Translate (Circle u) where
-  translate dx dy = mapCircleCTM (translate dx dy)
+  translate dx dy       = mapCTM (translate dx dy)
 
 
+--------------------------------------------------------------------------------
+-- Anchors
 
-runCircle :: (u -> ShapeCTM u -> a) -> Circle u -> a
-runCircle fn (Circle { circ_ctm = ctm, circ_radius = radius }) = 
-    fn radius ctm
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> Vec2 u) -> Circle u -> Anchor u
+runDisplaceCenter fn (Circle { circ_ctm    = ctm
+                             , circ_radius = radius }) = 
+    projectFromCtr (fn radius) ctm
 
+-- Anchors look like they need ctx...
 
 instance (Real u, Floating u) => CenterAnchor (Circle u) where
-  center = runCircle (\_ -> ctmCenter)
+  center = runDisplaceCenter $ \_ -> V2 0 0 
 
 
 instance (Real u, Floating u) => CardinalAnchor (Circle u) where
-  north = runCircle $ \r -> projectPoint $ P2 0    r
-  south = runCircle $ \r -> projectPoint $ P2 0  (-r)
-  east  = runCircle $ \r -> projectPoint $ P2 r    0
-  west  = runCircle $ \r -> projectPoint $ P2 (-r) 0
+  north = runDisplaceCenter $ \r -> V2 0    r
+  south = runDisplaceCenter $ \r -> V2 0  (-r)
+  east  = runDisplaceCenter $ \r -> V2 r    0
+  west  = runDisplaceCenter $ \r -> V2 (-r) 0
 
 
 instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where
@@ -98,29 +103,35 @@
 
 
 instance (Real u, Floating u) => RadialAnchor (Circle u) where
-  radialAnchor theta = runCircle $ \r -> projectPoint $ zeroPt .+^ avec theta r
-
+  radialAnchor ang = runDisplaceCenter $ \r -> avec ang r
 
 
 
 
+--------------------------------------------------------------------------------
+-- Construction
 
--- | 'circle'  : @ radius -> shape @
+-- | 'circle'  : @ radius -> Shape @
 --
-circle :: (Real u, Floating u) => u -> LocShape u (Circle u)
-circle radius = intoLocShape (mkCircle radius) (mkCirclePath radius)
+circle :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+       => u -> Shape Circle u
+circle radius = makeShape (mkCircle radius) (mkCirclePath radius)
           
 
 
-mkCircle :: Num u => u -> LocCF u (Circle u)
-mkCircle radius = promoteR1 $ \ctr -> 
-    pure $ Circle { circ_ctm = makeShapeCTM ctr, circ_radius = radius }
-
+mkCircle :: InterpretUnit u => u -> LocThetaQuery u (Circle u)
+mkCircle radius = qpromoteLocTheta $ \ctr theta -> 
+    pure $ Circle { circ_ctm    = makeShapeCTM ctr theta
+                  , circ_radius = radius 
+                  }
 
 
-mkCirclePath :: (Floating u, Ord u) => u -> LocCF u (Path u)
-mkCirclePath radius = promoteR1 $ \ctr -> 
-    pure $ traceCurvePoints $ bezierCircle 2 radius ctr 
+-- Rotation (theta) can be ignored.
+--
+mkCirclePath :: (Floating u, Ord u, InterpretUnit u, Tolerance u)
+             => u -> LocThetaQuery u (AbsPath u)
+mkCirclePath radius = qpromoteLocTheta $ \ctr _ ->
+    pure $ curvePath $ bezierCircle radius ctr 
 
 
 
diff --git a/src/Wumpus/Drawing/Shapes/Diamond.hs b/src/Wumpus/Drawing/Shapes/Diamond.hs
--- a/src/Wumpus/Drawing/Shapes/Diamond.hs
+++ b/src/Wumpus/Drawing/Shapes/Diamond.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -12,7 +11,7 @@
 -- Stability   :  highly unstable
 -- Portability :  GHC
 --
--- Simple shapes - rectangle, circle diamond, ellipse.
+-- Diamond (rhombus).
 -- 
 --------------------------------------------------------------------------------
 
@@ -26,17 +25,17 @@
 
   ) where
 
-import Wumpus.Drawing.Geometry.Intersection
-import Wumpus.Drawing.Geometry.Paths
+
+import Wumpus.Drawing.Basis.ShapeTrails
+import Wumpus.Drawing.Basis.Geometry
 import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Paths.Intersection
 import Wumpus.Drawing.Shapes.Base
 
 import Wumpus.Basic.Kernel                      -- package: wumpus-basic
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space 
-import Data.VectorSpace
 
 import Control.Applicative
 
@@ -53,46 +52,72 @@
       , dia_hh    :: !u
       }
 
+type instance DUnit (Diamond u) = u
+
 type DDiamond = Diamond Double
 
-type instance DUnit (Diamond u) = u
 
+instance Functor Diamond where
+  fmap f (Diamond ctm hw hh) = Diamond (fmap f ctm) (f hw) (f hh)
 
-mapDiamondCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u
-mapDiamondCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm
+--------------------------------------------------------------------------------
+-- Affine trans
 
-instance Num u => Scale (Diamond u) where
-  scale sx sy = mapDiamondCTM (scale sx sy)
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u
+mapCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm
 
 
-instance Rotate (Diamond u) where
-  rotate ang = mapDiamondCTM (rotate ang)
-                  
 
+instance (Real u, Floating u) => Rotate (Diamond u) where
+  rotate ang            = mapCTM (rotate ang)
+              
 instance (Real u, Floating u) => RotateAbout (Diamond u) where
-  rotateAbout ang pt = mapDiamondCTM (rotateAbout ang pt)
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
 
+instance Fractional u => Scale (Diamond u) where
+  scale sx sy           = mapCTM (scale sx sy)
 
 instance Num u => Translate (Diamond u) where
-  translate dx dy = mapDiamondCTM (translate dx dy)
+  translate dx dy       = mapCTM (translate dx dy)
 
 
+--------------------------------------------------------------------------------
+-- Anchors
 
-runDiamond :: (u -> u -> ShapeCTM u  -> a) -> Diamond u -> a
-runDiamond fm (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = 
-   fm hw hh ctm
+-- | 'runDisplaceCenter' : @ ( half_width 
+--                           * half_height -> Vec ) * diamond -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> u -> Vec2 u) -> Diamond u -> Anchor u
+runDisplaceCenter fn (Diamond { dia_ctm = ctm
+                              , dia_hw = hw
+                              , dia_hh = hh }) = 
+   projectFromCtr (fn hw hh) ctm
 
 
 instance (Real u, Floating u) => CenterAnchor (Diamond u) where
-  center = runDiamond (\_ _ -> ctmCenter)
+  center = runDisplaceCenter $ \_ _ -> V2 0 0
 
+instance (Real u, Floating u) => ApexAnchor (Diamond u) where
+  apex = runDisplaceCenter $ \_  hh -> V2 0 hh
+
+instance (Real u, Floating u) => 
+    SideMidpointAnchor (Diamond u) where
+  sideMidpoint n a = step (n `mod` 4) 
+    where
+      step 1 = midpoint (north a) (west a)
+      step 2 = midpoint (west a)  (south a)
+      step 3 = midpoint (south a) (east a)
+      step _ = midpoint (east a)  (north a)
+
+
 instance (Real u, Floating u) => CardinalAnchor (Diamond u) where
-  north = runDiamond $ \_  hh -> projectPoint $ P2 0 hh
-  south = runDiamond $ \_  hh -> projectPoint $ P2 0 (-hh)
-  east  = runDiamond $ \hw _  -> projectPoint $ P2 hw 0
-  west  = runDiamond $ \hw _  -> projectPoint $ P2 (-hw) 0
+  north = apex
+  south = runDisplaceCenter $ \_  hh -> V2 0 (-hh)
+  east  = runDisplaceCenter $ \hw _  -> V2 hw 0
+  west  = runDisplaceCenter $ \hw _  -> V2 (-hw) 0
 
-instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where
+instance (Real u, Floating u) => CardinalAnchor2 (Diamond u) where
   northeast x = midpoint (north x) (east x)
   southeast x = midpoint (south x) (east x)
   southwest x = midpoint (south x) (west x)
@@ -100,53 +125,43 @@
 
 
 
-instance (Real u, Floating u) => RadialAnchor (Diamond u) where
-   radialAnchor = diamondIntersect
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+      RadialAnchor (Diamond u) where
+  radialAnchor ang = runDisplaceCenter $ \hw hh -> 
+      maybe zeroVec id $ diamondRadialAnchor hw hh ang
 
 
--- Utils.Intersection needs improving...
 
-
-diamondIntersect :: (Real u, Floating u) 
-                 => Radian -> Diamond u -> Point2 u
-diamondIntersect theta (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = 
-    let ps  = diamondPoints hw hh ctm 
-        ctr = ctmCenter ctm
-    in maybe ctr id $ findIntersect ctr theta $ polygonLines ps
-    
-
-
-midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
-midpoint p1 p2 = let v = 0.5 *^ pvec p1 p2 in p1 .+^ v
+diamondRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                    => u -> u -> Radian -> Maybe (Vec2 u) 
+diamondRadialAnchor hw hh ang = 
+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp 
+  where
+    rp = anaTrailPath zeroPt $ diamond_trail (2*hw) (2*hh)
 
 
+--------------------------------------------------------------------------------
+-- Construction
 
 -- | 'diamond'  : @ half_width * half_height -> shape @
 --
 -- Note - args might change to tull_width and full_height...
 --
-diamond :: (Real u, Floating u, FromPtSize u) 
-        => u -> u -> LocShape u (Diamond u)
-diamond hw hh = intoLocShape (mkDiamond hw hh) (mkDiamondPath hw hh)
-
-
-mkDiamond :: Num u => u -> u -> LocCF u (Diamond u)
-mkDiamond hw hh = promoteR1 $ \ctr -> 
-    pure $ Diamond { dia_ctm = makeShapeCTM ctr, dia_hw = hw, dia_hh = hh }
+diamond :: (Real u, Floating u, InterpretUnit u, Tolerance u)
+        => u -> u -> Shape Diamond u
+diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath hw hh)
 
 
-mkDiamondPath :: (Real u, Floating u, FromPtSize u) 
-              => u -> u -> LocCF u (Path u)
-mkDiamondPath hw hh = promoteR1 $ \ctr -> 
-    roundCornerShapePath $ diamondCoordPath hw hh ctr
+mkDiamond :: InterpretUnit u => u -> u -> LocThetaQuery u (Diamond u)
+mkDiamond hw hh = qpromoteLocTheta $ \ctr theta -> 
+    pure $ Diamond { dia_ctm = makeShapeCTM ctr theta
+                   , dia_hw  = hw
+                   , dia_hh  = hh 
+                   }
 
 
-diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]
-diamondPoints hw hh ctm = map (projectPoint `flip` ctm) [ s, e, n, w ]
-  where
-    s = P2   0  (-hh)
-    e = P2   hw    0
-    n = P2   0    hh
-    w = P2 (-hw)   0 
-
+mkDiamondPath :: (Real u, Floating u, InterpretUnit u, Tolerance u)
+              => u -> u -> LocThetaQuery u (AbsPath u)
+mkDiamondPath hw hh = qpromoteLocTheta $ \ctr theta -> 
+    return $ anaTrailPath ctr $ rdiamond_trail (2*hw) (2*hh) theta
 
diff --git a/src/Wumpus/Drawing/Shapes/Ellipse.hs b/src/Wumpus/Drawing/Shapes/Ellipse.hs
--- a/src/Wumpus/Drawing/Shapes/Ellipse.hs
+++ b/src/Wumpus/Drawing/Shapes/Ellipse.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -28,6 +27,7 @@
 
   ) where
 
+import Wumpus.Drawing.Basis.ShapeTrails
 import Wumpus.Drawing.Paths
 import Wumpus.Drawing.Shapes.Base
 
@@ -35,7 +35,6 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space 
 
 import Control.Applicative
 
@@ -47,55 +46,73 @@
 -- Ellipse
 
 
+
 data Ellipse u = Ellipse
-      { ell_ctm     :: ShapeCTM u 
+      { ell_ctm     :: ShapeCTM u
       , ell_rx      :: !u
       , ell_ry      :: !u
       }
 
-type DEllipse = Ellipse Double
-
 type instance DUnit (Ellipse u) = u
 
+type DEllipse = Ellipse Double
 
 
-mapEllipseCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u
-mapEllipseCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm
+instance Functor Ellipse where
+  fmap f (Ellipse ctm rx ry) = Ellipse (fmap f ctm) (f rx) (f ry)
 
-instance Num u => Scale (Ellipse u) where
-  scale sx sy = mapEllipseCTM (scale sx sy)
 
+--------------------------------------------------------------------------------
+-- Affine trans
 
-instance Rotate (Ellipse u) where
-  rotate ang = mapEllipseCTM (rotate ang)
-                  
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u
+mapCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm
 
+
+instance (Real u, Floating u) => Rotate (Ellipse u) where
+  rotate ang            = mapCTM (rotate ang)
+              
 instance (Real u, Floating u) => RotateAbout (Ellipse u) where
-  rotateAbout ang pt = mapEllipseCTM (rotateAbout ang pt)
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
 
+instance Fractional u => Scale (Ellipse u) where
+  scale sx sy           = mapCTM (scale sx sy)
 
-instance Num u => Translate (Ellipse u) where
-  translate dx dy = mapEllipseCTM (translate dx dy)
+instance InterpretUnit u => Translate (Ellipse u) where
+  translate dx dy       = mapCTM (translate dx dy)
 
 
-runEllipse :: (u -> u -> ShapeCTM u  -> a) -> Ellipse u -> a
-runEllipse fn (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) = 
-    fn rx ry ctm
+--------------------------------------------------------------------------------
+-- Anchors
 
+-- Note - this is monadic for Ellipse...
 
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> u -> Vec2 u) -> Ellipse u -> Anchor u
+runDisplaceCenter fn (Ellipse { ell_ctm = ctm
+                              , ell_rx  = rx
+                              , ell_ry  = ry }) = 
+    projectFromCtr (fn rx ry) ctm
+
+
+-- NOTE - the Affine instances provided by Wumpus-Core for Point 
+-- and Vector may be contradictory for Wumpus-Basic.
+
+
 -- | x_radius is the unit length.
 --
-scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t
-scaleEll rx ry = scale 1 (ry/rx) 
+scaleEll :: (Real u, Fractional u)
+         => u -> u -> Vec2 u -> Vec2 u
+scaleEll rx ry v = let rat = realToFrac (ry/rx) in scale 1 rat v
 
 
 instance (Real u, Floating u) => CenterAnchor (Ellipse u) where
-  center = runEllipse $ \_ _ -> ctmCenter
+  center = runDisplaceCenter $ \_ _ -> V2 0 0
 
 
 instance (Real u, Floating u) => RadialAnchor (Ellipse u) where
-  radialAnchor theta = runEllipse $ \rx ry -> 
-    projectPoint $ scaleEll rx ry $ zeroPt .+^ avec theta rx
+  radialAnchor theta = runDisplaceCenter $ \rx ry -> 
+                         scaleEll rx ry $ avec theta rx
 
 
 instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where
@@ -112,23 +129,27 @@
   northwest = radialAnchor (0.75*pi)
 
 
-
+--------------------------------------------------------------------------------
+-- Construction
 
 -- | 'ellipse'  : @ x_radii * y_radii -> shape @
 --
-ellipse :: (Floating u, Ord u) => u -> u -> LocShape u (Ellipse u)
-ellipse rx ry = 
-    intoLocShape (mkEllipse rx ry) (mkEllipsePath rx ry)
+ellipse :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) 
+        => u -> u -> Shape Ellipse u
+ellipse rx ry = makeShape (mkEllipse rx ry) (mkEllipsePath rx ry)
 
 
-mkEllipse :: Num u => u -> u -> LocCF u (Ellipse u)
-mkEllipse rx ry = promoteR1 $ \ctr -> 
-    pure $ Ellipse { ell_ctm = makeShapeCTM ctr, ell_rx = rx, ell_ry = ry }
+mkEllipse :: InterpretUnit u => u -> u -> LocThetaQuery u (Ellipse u)
+mkEllipse rx ry = qpromoteLocTheta $ \ctr theta -> 
+    pure $ Ellipse { ell_ctm = makeShapeCTM ctr theta
+                   , ell_rx  = rx
+                   , ell_ry  = ry 
+                   }
 
--- This is wrong...
---
-mkEllipsePath :: (Floating u, Ord u) => u -> u -> LocCF u (Path u)
-mkEllipsePath rx ry = promoteR1 $ \(P2 x y) -> 
-    pure $ traceCurvePoints $ map (translate x y . scaleEll rx ry) 
-                            $ bezierCircle 2 rx zeroPt
+
+mkEllipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+              => u -> u -> LocThetaQuery u (AbsPath u)
+mkEllipsePath rx ry = qpromoteLocTheta $ \ctr theta -> 
+    return $ anaTrailPath ctr $ rellipse_trail rx ry theta
+
 
diff --git a/src/Wumpus/Drawing/Shapes/InvSemicircle.hs b/src/Wumpus/Drawing/Shapes/InvSemicircle.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Shapes/InvSemicircle.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.InvSemicircle
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Inverse semicircle. 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.InvSemicircle
+  ( 
+
+    InvSemicircle
+  , DInvSemicircle
+  , invsemicircle
+
+  ) where
+
+import Wumpus.Drawing.Shapes.Base
+import Wumpus.Drawing.Shapes.Semicircle
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+
+
+--------------------------------------------------------------------------------
+-- Inverse semicircle
+
+newtype InvSemicircle u = InvSemicircle { getInvSemicircle :: Semicircle u }
+
+type instance DUnit (InvSemicircle u) = u
+  
+type DInvSemicircle = InvSemicircle Double
+
+
+instance Functor InvSemicircle where
+  fmap f = InvSemicircle . fmap f . getInvSemicircle
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapInner :: (Semicircle u -> Semicircle u) 
+         -> InvSemicircle u 
+         -> InvSemicircle u
+mapInner f = InvSemicircle . f . getInvSemicircle
+
+
+instance (Real u, Floating u) => Rotate (InvSemicircle u) where
+  rotate ang            = mapInner (rotate ang)
+              
+instance (Real u, Floating u) => RotateAbout (InvSemicircle u) where
+  rotateAbout ang pt    = mapInner (rotateAbout ang pt)
+
+instance Fractional u => Scale (InvSemicircle u) where
+  scale sx sy           = mapInner (scale sx sy)
+
+instance InterpretUnit u => Translate (InvSemicircle u) where
+  translate dx dy       = mapInner (translate dx dy)
+
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+runRotateAnchor :: (Real u, Floating u) 
+                => (Semicircle u -> Anchor u) -> InvSemicircle u -> Anchor u
+runRotateAnchor f (InvSemicircle a) = 
+    let ctr = center a in rotateAbout pi ctr (f a)
+
+
+instance (Real u, Floating u) => 
+    CenterAnchor (InvSemicircle u) where
+  center = center . getInvSemicircle
+
+instance (Real u, Floating u) => 
+    ApexAnchor (InvSemicircle u) where
+  apex = runRotateAnchor apex
+
+instance (Real u, Floating u) => 
+    TopCornerAnchor (InvSemicircle u) where
+  topLeftCorner  = runRotateAnchor bottomRightCorner
+  topRightCorner = runRotateAnchor bottomLeftCorner
+
+instance (Real u, Floating u) => 
+    CardinalAnchor (InvSemicircle u) where
+  north = runRotateAnchor south
+  south = runRotateAnchor north
+  east  = runRotateAnchor west
+  west  = runRotateAnchor east
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor2 (InvSemicircle u) where
+  northeast = runRotateAnchor southwest
+  southeast = runRotateAnchor northwest
+  southwest = runRotateAnchor northeast
+  northwest = runRotateAnchor southeast
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    RadialAnchor (InvSemicircle u) where
+  radialAnchor theta = 
+    runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'invsemicircle'  : @ radius -> Shape @
+--
+invsemicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+           => u -> Shape InvSemicircle u
+invsemicircle radius = 
+    shapeMap InvSemicircle $ updatePathAngle (+ pi) $ semicircle radius
diff --git a/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs b/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.InvSemiellipse
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Inverse semiellipse. 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.InvSemiellipse
+  ( 
+
+    InvSemiellipse
+  , DInvSemiellipse
+  , invsemiellipse
+
+  ) where
+
+import Wumpus.Drawing.Shapes.Base
+import Wumpus.Drawing.Shapes.Semiellipse
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+
+
+--------------------------------------------------------------------------------
+-- Inverse semiellipse
+
+newtype InvSemiellipse u = InvSemiellipse { getInvSemiellipse :: Semiellipse u }
+
+type instance DUnit (InvSemiellipse u) = u
+  
+type DInvSemiellipse = InvSemiellipse Double
+
+
+
+instance Functor InvSemiellipse where
+  fmap f = InvSemiellipse . fmap f . getInvSemiellipse
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapInner :: (Semiellipse u -> Semiellipse u) 
+         -> InvSemiellipse u 
+         -> InvSemiellipse u
+mapInner f = InvSemiellipse . f . getInvSemiellipse
+
+instance (Real u, Floating u) => Rotate (InvSemiellipse u) where
+  rotate ang            = mapInner (rotate ang)
+              
+instance (Real u, Floating u) => RotateAbout (InvSemiellipse u) where
+  rotateAbout ang pt    = mapInner (rotateAbout ang pt)
+
+instance Fractional u => Scale (InvSemiellipse u) where
+  scale sx sy           = mapInner (scale sx sy)
+
+instance InterpretUnit u => Translate (InvSemiellipse u) where
+  translate dx dy       = mapInner (translate dx dy)
+
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+runRotateAnchor :: (Real u, Floating u) 
+                => (Semiellipse u -> Anchor u) -> InvSemiellipse u -> Anchor u
+runRotateAnchor f (InvSemiellipse a) =
+    let ctr = center a in rotateAbout pi ctr (f a)
+
+
+
+instance (Real u, Floating u, Tolerance u) => 
+    CenterAnchor (InvSemiellipse u) where
+  center = center . getInvSemiellipse
+
+instance (Real u, Floating u, Tolerance u) => 
+    ApexAnchor (InvSemiellipse u) where
+  apex = runRotateAnchor apex
+
+instance (Real u, Floating u, Tolerance u) => 
+    TopCornerAnchor (InvSemiellipse u) where
+  topLeftCorner  = runRotateAnchor bottomRightCorner
+  topRightCorner = runRotateAnchor bottomLeftCorner
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor (InvSemiellipse u) where
+  north = runRotateAnchor south
+  south = runRotateAnchor north
+  east  = runRotateAnchor west
+  west  = runRotateAnchor east
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor2 (InvSemiellipse u) where
+  northeast = runRotateAnchor southwest
+  southeast = runRotateAnchor northwest
+  southwest = runRotateAnchor northeast
+  northwest = runRotateAnchor southeast
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    RadialAnchor (InvSemiellipse u) where
+  radialAnchor theta = 
+    runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'invsemiellipse'  : @ rx * ry -> Shape @
+--
+invsemiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+           => u -> u -> Shape InvSemiellipse u
+invsemiellipse rx ry = 
+    shapeMap InvSemiellipse $ updatePathAngle (+ pi) $ semiellipse rx ry
diff --git a/src/Wumpus/Drawing/Shapes/InvTriangle.hs b/src/Wumpus/Drawing/Shapes/InvTriangle.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Shapes/InvTriangle.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.InvTriangle
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Inverse version of the Triangle shape.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.InvTriangle
+  ( 
+
+    InvTriangle
+  , DInvTriangle
+  , invtriangle
+
+
+  ) where
+
+import Wumpus.Drawing.Basis.Geometry
+import Wumpus.Drawing.Shapes.Base
+import Wumpus.Drawing.Shapes.Triangle
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+
+-- Datatype
+
+newtype InvTriangle u = InvTriangle { getInvTriangle :: Triangle u }
+
+type instance DUnit (InvTriangle u) = u
+
+
+type DInvTriangle = InvTriangle Double
+
+
+instance Functor InvTriangle where
+  fmap f = InvTriangle . fmap f . getInvTriangle
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapInner :: (Triangle u -> Triangle u) -> InvTriangle u -> InvTriangle u
+mapInner f = InvTriangle . f . getInvTriangle 
+
+instance (Real u, Floating u) => Rotate (InvTriangle u) where
+  rotate ang            = mapInner (rotate ang)
+              
+instance (Real u, Floating u) => RotateAbout (InvTriangle u) where
+  rotateAbout ang pt    = mapInner (rotateAbout ang pt)
+
+instance Fractional u => Scale (InvTriangle u) where
+  scale sx sy           = mapInner (scale sx sy)
+
+instance InterpretUnit u => Translate (InvTriangle u) where
+  translate dx dy       = mapInner (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- Anchors should be rotated about the center by pi...
+
+runRotateAnchor :: (Real u, Floating u) 
+                => (Triangle u -> Anchor u) -> InvTriangle u -> Anchor u
+runRotateAnchor f (InvTriangle a) =
+    let ctr = center a in rotateAbout pi ctr (f a)
+
+
+instance (Real u, Floating u) => 
+    CenterAnchor (InvTriangle u) where
+  center = center . getInvTriangle
+
+
+-- apex is same on InvTriangle as regular triangle
+
+instance (Real u, Floating u) => 
+    ApexAnchor (InvTriangle u) where
+  apex = runRotateAnchor apex
+
+-- Top corners are bottom corners of the wrapped triangle.
+--
+instance (Real u, Floating u) => 
+    TopCornerAnchor (InvTriangle u) where
+  topLeftCorner  = runRotateAnchor bottomRightCorner
+  topRightCorner = runRotateAnchor bottomLeftCorner
+
+
+-- Use established points on the InvTrangle - don\'t delegate to 
+-- the base Triangle.
+--
+instance (Real u, Floating u) => 
+    SideMidpointAnchor (InvTriangle u) where
+  sideMidpoint n a = step (n `mod` 3) 
+    where
+      step 1 = midpoint (topRightCorner a)  (topLeftCorner a)
+      step 2 = midpoint (topLeftCorner a)   (apex a)
+      step _ = midpoint (apex a)            (topRightCorner a)
+
+
+
+-- east and west should be parallel to the centroid.
+--
+
+instance (Real u, Floating u) => 
+    CardinalAnchor (InvTriangle u) where
+  north = runRotateAnchor south
+  south = runRotateAnchor north
+  east  = runRotateAnchor west
+  west  = runRotateAnchor east
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor2 (InvTriangle u) where
+  northeast = runRotateAnchor southwest
+  southeast = runRotateAnchor northwest
+  southwest = runRotateAnchor northeast
+  northwest = runRotateAnchor southeast
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    RadialAnchor (InvTriangle u) where
+  radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)
+
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'invtriangle'  : @ top_base_width * height -> Triangle @
+--
+--
+invtriangle :: (Real u, Floating u, InterpretUnit u, Tolerance u)
+            => u -> u -> Shape InvTriangle u
+invtriangle bw h = 
+    shapeMap InvTriangle $ updatePathAngle (+ pi) $ triangle bw h
+    
+
+
+
diff --git a/src/Wumpus/Drawing/Shapes/Parallelogram.hs b/src/Wumpus/Drawing/Shapes/Parallelogram.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Shapes/Parallelogram.hs
@@ -0,0 +1,240 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Parallelogram
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Parallelogram.
+--
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Parallelogram
+  ( 
+
+    Parallelogram
+  , DParallelogram
+  , parallelogram
+  , zparallelogram
+
+
+  ) where
+
+import Wumpus.Drawing.Basis.Geometry
+import Wumpus.Drawing.Basis.ShapeTrails
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Paths.Intersection
+import Wumpus.Drawing.Shapes.Base
+
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.VectorSpace                         -- package: vector-space
+
+import Control.Applicative
+
+
+
+
+--------------------------------------------------------------------------------
+-- Parallelogram
+
+-- | A Paralleogram.
+--
+data Parallelogram u = Parallelogram 
+      { pll_ctm             :: ShapeCTM u
+      , pll_base_width      :: !u
+      , pll_height          :: !u
+      , pll_base_left_ang   :: Radian
+      }
+
+type instance DUnit (Parallelogram u) = u
+
+
+type DParallelogram = Parallelogram Double
+
+
+instance Functor Parallelogram where
+  fmap f (Parallelogram ctm bw h lang) = 
+      Parallelogram (fmap f ctm) (f bw) (f h) lang
+
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Parallelogram u -> Parallelogram u
+mapCTM f = (\s i -> s { pll_ctm = f i }) <*> pll_ctm
+
+
+instance (Real u, Floating u) => Rotate (Parallelogram u) where
+  rotate ang            = mapCTM (rotate ang)
+              
+instance (Real u, Floating u) => RotateAbout (Parallelogram u) where
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
+
+instance Fractional u => Scale (Parallelogram u) where
+  scale sx sy           = mapCTM (scale sx sy)
+
+instance InterpretUnit u => Translate (Parallelogram u) where
+  translate dx dy       = mapCTM (translate dx dy)
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- | 'runDisplaceCenter' : @ ( base_width
+--                           * height 
+--                           * base_minor
+--                           -> Vec ) * parallelogram -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> u -> Radian -> Vec2 u) -> Parallelogram u -> Anchor u
+runDisplaceCenter fn (Parallelogram { pll_ctm           = ctm
+                                    , pll_base_width    = bw
+                                    , pll_height        = h 
+                                    , pll_base_left_ang = lang }) =
+    projectFromCtr (fn bw h lang) ctm
+
+
+runDisplaceCenterHalves :: (Real u, Floating u)
+                        => (u -> u -> Radian -> Vec2 u) 
+                        -> Parallelogram u 
+                        -> Anchor u
+runDisplaceCenterHalves fn = 
+    runDisplaceCenter $ \bw h bl_ang -> fn (0.5*bw) (0.5*h) bl_ang
+
+
+instance (Real u, Floating u) => 
+    CenterAnchor (Parallelogram u) where
+  center = runDisplaceCenter $ \_ _ _ -> V2 0 0
+
+
+-- | WARNING - WRONG...
+
+-- top anchors swap the base minor and major...
+--
+
+instance (Real u, Floating u) => 
+    TopCornerAnchor (Parallelogram u) where
+  topLeftCorner  = runDisplaceCenterHalves $ \hw hh lang -> 
+      let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang hypo
+
+  topRightCorner = runDisplaceCenterHalves $ \hw hh lang ->
+      let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang hypo
+
+instance (Real u, Floating u) => 
+    BottomCornerAnchor (Parallelogram u) where
+  bottomLeftCorner  = runDisplaceCenterHalves $ \hw hh lang ->
+      let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang (-hypo)
+
+  bottomRightCorner = runDisplaceCenterHalves $ \hw hh lang -> 
+      let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang (-hypo)
+
+
+
+instance (Real u, Floating u) => 
+    SideMidpointAnchor (Parallelogram u) where
+  sideMidpoint n a = step (n `mod` 4) 
+    where
+      step 1 = midpoint (topRightCorner a)    (topLeftCorner a)
+      step 2 = midpoint (topLeftCorner a)     (bottomLeftCorner a)
+      step 3 = midpoint (bottomLeftCorner a)  (bottomRightCorner a)
+      step _ = midpoint (bottomRightCorner a) (topRightCorner a)
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor (Parallelogram u) where
+  north = radialAnchor (0.5 * pi)
+  south = radialAnchor (1.5 * pi)
+  east  = radialAnchor 0
+  west  = radialAnchor pi
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor2 (Parallelogram u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+     RadialAnchor (Parallelogram u) where
+   radialAnchor ang = runDisplaceCenter $ \bw h bl_ang-> 
+      maybe zeroVec id $ pllRadialAnchor bw h bl_ang ang
+
+
+
+-- | Note - it is not worth changing this to a quadrantAlg.
+--
+-- There are pathological parallelograms that the current 
+-- QuadrantAlg code cannot handle, and a better abstraction is
+-- needed (rather than better implementation of QuadrantAlg).
+--
+pllRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                => u -> u -> Radian -> Radian -> Maybe (Vec2 u)
+pllRadialAnchor bw h bl_ang ang =
+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp 
+  where
+    rp = anaTrailPath zeroPt $ parallelogram_trail bw h bl_ang
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+
+-- | 'parallelogram'  : @ width * height * bottom_left_ang -> Parallelogram @
+--
+--
+parallelogram :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+              => u -> u -> Radian -> Shape Parallelogram u
+parallelogram bw h lang =
+    makeShape (mkParallelogram bw h lang) (mkParallelogramPath bw h lang)
+
+
+-- | 'zparallelogram'  : @ base_width * height -> Parallelogram @
+--
+--
+zparallelogram :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+              => u -> u -> Shape Parallelogram u
+zparallelogram bw h = parallelogram bw h ang
+  where
+    ang = d2r (60::Double)
+
+
+--------------------------------------------------------------------------------
+
+
+mkParallelogram :: (Real u, Fractional u, InterpretUnit u, Tolerance u) 
+                => u -> u -> Radian -> LocThetaQuery u (Parallelogram u)
+mkParallelogram bw h bl_ang = qpromoteLocTheta $ \ctr theta -> 
+    pure $ Parallelogram { pll_ctm            = makeShapeCTM ctr theta
+                         , pll_base_width     = bw
+                         , pll_height         = h
+                         , pll_base_left_ang  = bl_ang
+                         }
+
+
+
+
+mkParallelogramPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                    => u -> u -> Radian -> LocThetaQuery u (AbsPath u)
+mkParallelogramPath bw h bl_ang = qpromoteLocTheta $ \ctr theta -> 
+    return $ anaTrailPath ctr $ rparallelogram_trail bw h bl_ang theta
+
+                         
+
+
+
+
diff --git a/src/Wumpus/Drawing/Shapes/Rectangle.hs b/src/Wumpus/Drawing/Shapes/Rectangle.hs
--- a/src/Wumpus/Drawing/Shapes/Rectangle.hs
+++ b/src/Wumpus/Drawing/Shapes/Rectangle.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -13,6 +12,9 @@
 -- Portability :  GHC
 --
 -- Rectangle shape.
+--
+-- Note - CardinalAnchor2 (northeast etc.) point to their radial 
+-- positions (this is a change since earlier versions).
 -- 
 --------------------------------------------------------------------------------
 
@@ -25,12 +27,12 @@
 
   ) where
 
-import Wumpus.Drawing.Geometry.Intersection
-import Wumpus.Drawing.Geometry.Paths
+import Wumpus.Drawing.Basis.ShapeTrails
 import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Paths.Intersection
 import Wumpus.Drawing.Shapes.Base
 
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.Kernel
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -39,8 +41,7 @@
 
 
 
---------------------------------------------------------------------------------
--- Rectangle
+-- Data type
 
 data Rectangle u = Rectangle 
       { rect_ctm    :: ShapeCTM u
@@ -49,88 +50,120 @@
       }
   deriving (Eq,Ord,Show)
 
+type instance DUnit (Rectangle u) = u
+
 type DRectangle = Rectangle Double
 
 
-type instance DUnit (Rectangle u) = u
+instance Functor Rectangle where
+  fmap f (Rectangle ctm hw hh) = Rectangle (fmap f ctm) (f hw) (f hh)
 
+--------------------------------------------------------------------------------
+-- Affine trans
 
-mapRectangleCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u
-mapRectangleCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u
+mapCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm
 
-instance Num u => Scale (Rectangle u) where
-  scale sx sy = mapRectangleCTM (scale sx sy)
 
 
-instance Rotate (Rectangle u) where
-  rotate ang = mapRectangleCTM (rotate ang)
-                  
-
+instance (Real u, Floating u) => Rotate (Rectangle u) where
+  rotate ang            = mapCTM (rotate ang)
+              
 instance (Real u, Floating u) => RotateAbout (Rectangle u) where
-  rotateAbout ang pt = mapRectangleCTM (rotateAbout ang pt)
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
 
+instance Fractional u => Scale (Rectangle u) where
+  scale sx sy           = mapCTM (scale sx sy)
 
-instance Num u => Translate (Rectangle u) where
-  translate dx dy = mapRectangleCTM (translate dx dy)
+instance InterpretUnit u => Translate (Rectangle u) where
+  translate dx dy       = mapCTM (translate dx dy)
 
+--------------------------------------------------------------------------------
+-- Anchors
 
 
 
-runRectangle :: (u -> u -> ShapeCTM u -> a) -> Rectangle u -> a
-runRectangle fn (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) = 
-   fn hw hh ctm
+-- | 'runDisplaceCenter' : @ ( half_width
+--                           * half_height -> Vec ) * rectangle -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> u -> Vec2 u) -> Rectangle u -> Anchor u
+runDisplaceCenter fn (Rectangle { rect_ctm = ctm
+                                , rect_hw  = hw
+                                , rect_hh  = hh }) = 
+   projectFromCtr (fn hw hh) ctm
 
-instance (Real u, Floating u) => CenterAnchor (Rectangle u) where
-  center = runRectangle (\ _ _ -> ctmCenter)
 
-instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where
-  north = runRectangle $ \_  hh -> projectPoint $ P2 0 hh
-  south = runRectangle $ \_  hh -> projectPoint $ P2 0 (-hh)
-  east  = runRectangle $ \hw _  -> projectPoint $ P2 hw 0
-  west  = runRectangle $ \hw _  -> projectPoint $ P2 (-hw) 0
+instance (Real u, Floating u) => 
+    CenterAnchor (Rectangle u) where
+  center = runDisplaceCenter $ \_ _ -> V2 0 0
 
-instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where
-  northeast = runRectangle $ \hw hh -> projectPoint $ P2 hw hh
-  southeast = runRectangle $ \hw hh -> projectPoint $ P2 hw (-hh)
-  southwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) (-hh)
-  northwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) hh
+instance (Real u, Floating u) => 
+    TopCornerAnchor (Rectangle u) where
+  topLeftCorner  = runDisplaceCenter $ \hw hh -> V2 (-hw) hh
+  topRightCorner = runDisplaceCenter $ \hw hh -> V2   hw  hh
 
+instance (Real u, Floating u) => 
+    BottomCornerAnchor (Rectangle u) where
+  bottomLeftCorner  = runDisplaceCenter $ \hw hh -> V2 (-hw) (-hh)
+  bottomRightCorner = runDisplaceCenter $ \hw hh -> V2   hw  (-hh)
 
-instance (Real u, Floating u) => RadialAnchor (Rectangle u) where
-  radialAnchor theta = runRectangle $ \hw hh -> 
-    projectPoint $ rectangleIntersect hw hh theta
+instance (Real u, Floating u) => 
+    SideMidpointAnchor (Rectangle u) where
+  sideMidpoint n a = step (n `mod` 4) 
+    where
+      step 1 = north a
+      step 2 = west a
+      step 3 = south a
+      step _ = east a
 
--- Note - the answer needs projecting with the CTM...
---
-rectangleIntersect :: (Real u, Floating u) 
-                   => u -> u -> Radian -> Point2 u
-rectangleIntersect hw hh theta = 
-    maybe zeroPt id $ findIntersect zeroPt theta $ rectangleLines zeroPt hw hh 
 
+instance (Real u, Floating u) => 
+    CardinalAnchor (Rectangle u) where
+  north = runDisplaceCenter $ \_  hh -> V2 0 hh
+  south = runDisplaceCenter $ \_  hh -> V2 0 (-hh)
+  east  = runDisplaceCenter $ \hw _  -> V2 hw 0
+  west  = runDisplaceCenter $ \hw _  -> V2 (-hw) 0
 
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor2 (Rectangle u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
 
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    RadialAnchor (Rectangle u) where
+  radialAnchor ang = runDisplaceCenter $ \hw hh -> 
+      maybe zeroVec id $ rectangleRadialIntersect (2*hw) (2*hh) ang
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+
 -- | 'rectangle'  : @ width * height -> shape @
 --
-rectangle :: (Real u, Floating u, FromPtSize u) 
-          => u -> u -> LocShape u (Rectangle u)
+rectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => u -> u -> Shape Rectangle u
 rectangle w h = 
-    intoLocShape (mkRectangle (0.5*w) (0.5*h))
-                 (mkRectPath  (0.5*w) (0.5*h))
+    makeShape (mkRectangle (0.5*w) (0.5*h)) (mkRectPath (0.5*w) (0.5*h))
 
 
-mkRectangle :: Num u => u -> u -> LocCF u (Rectangle u)
-mkRectangle hw hh = promoteR1 $ \ctr -> 
-    pure $ Rectangle { rect_ctm    = makeShapeCTM ctr
+mkRectangle :: InterpretUnit u => u -> u -> LocThetaQuery u (Rectangle u)
+mkRectangle hw hh = qpromoteLocTheta $ \ctr theta -> 
+    pure $ Rectangle { rect_ctm    = makeShapeCTM ctr theta
                      , rect_hw     = hw
                      , rect_hh     = hh
                      }
 
+mkRectPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+           => u -> u -> LocThetaQuery u (AbsPath u)
+mkRectPath hw hh = qpromoteLocTheta $ \ctr theta -> 
+    return $ anaTrailPath ctr $ rrectangle_trail (2*hw) (2*hh) theta
 
-mkRectPath :: (Real u, Floating u, FromPtSize u) 
-           => u -> u -> LocCF u (Path u)
-mkRectPath hw hh = promoteR1 $ \ctr -> 
-    let btm_left = displace (-hw) (-hh) ctr
-    in roundCornerShapePath $ rectangleCoordPath (2*hw) (2*hh) btm_left
-    
+
+  
 
 
diff --git a/src/Wumpus/Drawing/Shapes/Semicircle.hs b/src/Wumpus/Drawing/Shapes/Semicircle.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Shapes/Semicircle.hs
@@ -0,0 +1,193 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Semicircle
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Semicircle. 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Semicircle
+  ( 
+
+    Semicircle
+  , DSemicircle
+  , semicircle
+
+  ) where
+
+import Wumpus.Drawing.Basis.ShapeTrails
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Paths.Intersection
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Control.Applicative
+
+
+
+--------------------------------------------------------------------------------
+-- Datatype
+
+data Semicircle u = Semicircle 
+      { sc_ctm          :: ShapeCTM u
+      , sc_radius       :: !u 
+      }
+
+type instance DUnit (Semicircle u) = u
+
+  
+type DSemicircle = Semicircle Double
+
+
+instance Functor Semicircle where
+  fmap f (Semicircle ctm r) = Semicircle (fmap f ctm) (f r)
+
+
+
+-- | Use the formula:
+--
+-- >   4r
+-- >  ---
+-- >  3pi
+--
+-- to get the yminor.
+--
+
+
+hminor :: Floating u => u -> u
+hminor radius = (4 * radius) / (3 * pi)
+
+hmajor :: Floating u => u -> u
+hmajor radius = radius - hminor radius
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semicircle u -> Semicircle u
+mapCTM f = (\s i -> s { sc_ctm = f i }) <*> sc_ctm
+
+
+instance (Real u, Floating u) => Rotate (Semicircle u) where
+  rotate ang            = mapCTM (rotate ang)
+              
+instance (Real u, Floating u) => RotateAbout (Semicircle u) where
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
+
+instance Fractional u => Scale (Semicircle u) where
+  scale sx sy           = mapCTM (scale sx sy)
+
+instance InterpretUnit u => Translate (Semicircle u) where
+  translate dx dy       = mapCTM (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- | 'runDisplaceCenter' : @ ( radius
+--                           * height_minor 
+--                           * height_major -> Vec ) * semicircle -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> Vec2 u) -> Semicircle u -> Anchor u
+runDisplaceCenter fn (Semicircle { sc_ctm       = ctm
+                                 , sc_radius    = radius }) = 
+    projectFromCtr (fn radius) ctm
+
+
+instance (Real u, Floating u) => 
+    CenterAnchor (Semicircle u) where
+  center = runDisplaceCenter $ \_ -> V2 0 0
+
+instance (Real u, Floating u) => 
+    ApexAnchor (Semicircle u) where
+  apex = runDisplaceCenter $ \r -> V2 0 (hmajor r)
+
+instance (Real u, Floating u) => 
+    BottomCornerAnchor (Semicircle u) where
+  bottomLeftCorner  = runDisplaceCenter $ \r -> V2 (-r) (negate $ hminor r)
+  bottomRightCorner = runDisplaceCenter $ \r -> V2  r   (negate $ hminor r)
+
+instance (Real u, Floating u) => 
+    CardinalAnchor (Semicircle u) where
+  north = apex
+  south = runDisplaceCenter $ \r -> V2 0  (negate $ hminor r)
+  east  = runDisplaceCenter $ \r -> let x = pyth r (hminor r) in V2 x 0
+  west  = runDisplaceCenter $ \r -> let x = pyth r (hminor r) in V2 (-x) 0
+
+-- | Use Pythagoras formula for working out the /east/ and /west/
+-- distances. A right-triangle is formed below the centroid, 
+-- radius is the hypotenuese, hminor is the other side.
+--
+pyth :: Floating u => u -> u -> u
+pyth hyp s1 = sqrt $ pow2 hyp - pow2 s1
+  where
+    pow2 = (^ (2::Int))
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor2 (Semicircle u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    RadialAnchor (Semicircle u) where
+  radialAnchor ang = runDisplaceCenter $ \r ->
+      maybe zeroVec id $ semicircleRadialAnchor r ang
+
+
+
+semicircleRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                    => u -> Radian -> Maybe (Vec2 u) 
+semicircleRadialAnchor r ang = 
+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp 
+  where
+    rp = anaTrailPath zeroPt $ semicircle_trail r
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'semicircle'  : @ radius -> Shape @
+--
+semicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+           => u -> Shape Semicircle u
+semicircle radius = makeShape (mkSemicircle radius) (mkSemicirclePath radius)
+          
+
+
+mkSemicircle :: InterpretUnit u
+             => u -> LocThetaQuery u (Semicircle u)
+mkSemicircle radius = qpromoteLocTheta $ \ctr theta -> 
+    pure $ Semicircle { sc_ctm    = makeShapeCTM ctr theta
+                      , sc_radius = radius
+                      }
+
+
+
+-- TODO - need to check other shapes to see if the are deriving 
+-- the center properly...
+--
+mkSemicirclePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                 => u -> LocThetaQuery u (AbsPath u)
+mkSemicirclePath radius = qpromoteLocTheta $ \ctr theta ->
+    return $ anaTrailPath ctr $ rsemicircle_trail radius theta
+
diff --git a/src/Wumpus/Drawing/Shapes/Semiellipse.hs b/src/Wumpus/Drawing/Shapes/Semiellipse.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Shapes/Semiellipse.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Semiellipse
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Semiellipse.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Semiellipse
+  ( 
+
+    Semiellipse
+  , DSemiellipse
+  , semiellipse
+
+  ) where
+
+import Wumpus.Drawing.Basis.ShapeTrails
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Paths.Intersection
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+
+
+
+--------------------------------------------------------------------------------
+-- Datatype
+
+data Semiellipse u = Semiellipse 
+      { se_ctm          :: ShapeCTM u
+      , se_rx           :: !u 
+      , se_ry           :: !u
+      }
+
+type instance DUnit (Semiellipse u) = u
+
+
+  
+type DSemiellipse = Semiellipse Double
+
+instance Functor Semiellipse where
+  fmap f (Semiellipse ctm rx ry) = Semiellipse (fmap f ctm) (f rx) (f ry)
+
+
+
+ryminor :: Floating u => u -> u
+ryminor ry = (4 * ry) / (3 * pi)
+
+rymajor :: Floating u => u -> u
+rymajor ry = ry - ryminor ry
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semiellipse u -> Semiellipse u
+mapCTM f = (\s i -> s { se_ctm = f i }) <*> se_ctm
+
+
+instance (Real u, Floating u) => Rotate (Semiellipse u) where
+  rotate ang            = mapCTM (rotate ang)
+              
+instance (Real u, Floating u) => RotateAbout (Semiellipse u) where
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
+
+instance Fractional u => Scale (Semiellipse u) where
+  scale sx sy           = mapCTM (scale sx sy)
+
+instance InterpretUnit u => Translate (Semiellipse u) where
+  translate dx dy       = mapCTM (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+
+-- | 'runDisplaceCenter' : @ ( rx
+--                           * ry 
+--                           * ry_minor 
+--                           * ry_major -> Vec ) * semiellipse -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> u -> Vec2 u) -> Semiellipse u -> Anchor u
+runDisplaceCenter fn (Semiellipse { se_ctm       = ctm
+                                  , se_rx        = rx
+                                  , se_ry        = ry  }) = 
+    projectFromCtr (fn rx ry) ctm
+
+
+
+
+instance (Real u, Floating u) => 
+    CenterAnchor (Semiellipse u) where
+  center = runDisplaceCenter $ \_ _ -> V2 0 0
+
+instance (Real u, Floating u, Tolerance u) => 
+    ApexAnchor (Semiellipse u) where
+  apex = runDisplaceCenter $ \_ ry -> V2 0 (rymajor ry)
+
+instance (Real u, Floating u) => 
+    BottomCornerAnchor (Semiellipse u) where
+  bottomLeftCorner  = runDisplaceCenter $ \rx ry -> V2 (-rx) (negate $ ryminor ry)
+  bottomRightCorner = runDisplaceCenter $ \rx ry -> V2  rx   (negate $ ryminor ry)
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor (Semiellipse u) where
+  north = apex
+  south = runDisplaceCenter $ \_ ry -> V2 0 (negate $ ryminor ry)
+  east  = radialAnchor 0
+  west  = radialAnchor pi
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor2 (Semiellipse u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    RadialAnchor (Semiellipse u) where
+  radialAnchor ang = runDisplaceCenter $ \rx ry ->
+      maybe zeroVec id $ semiellipseRadialAnchor rx ry ang
+
+
+semiellipseRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                        => u -> u -> Radian -> Maybe (Vec2 u) 
+semiellipseRadialAnchor rx ry ang = 
+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp 
+  where
+    rp = anaTrailPath zeroPt $ semiellipse_trail rx ry
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+
+-- | 'semiellipse'  : @ x_radius * y_radius -> Shape @
+--
+semiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+            => u -> u -> Shape Semiellipse u
+semiellipse rx ry = makeShape (mkSemiellipse rx ry) (mkSemiellipsePath rx ry)
+          
+
+
+
+mkSemiellipse :: InterpretUnit u 
+              => u -> u -> LocThetaQuery u (Semiellipse u)
+mkSemiellipse rx ry = qpromoteLocTheta $ \ctr theta -> 
+    pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta
+                       , se_rx = rx
+                       , se_ry = ry
+                       }
+
+
+mkSemiellipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                  => u -> u -> LocThetaQuery u (AbsPath u)
+mkSemiellipsePath rx ry = qpromoteLocTheta $ \ctr theta ->
+    return $ anaTrailPath ctr $ rsemiellipse_trail rx ry theta
+
diff --git a/src/Wumpus/Drawing/Shapes/Trapezium.hs b/src/Wumpus/Drawing/Shapes/Trapezium.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Shapes/Trapezium.hs
@@ -0,0 +1,220 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Trapezium
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Isoceles Trapezium.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Trapezium
+  ( 
+
+    Trapezium
+  , DTrapezium
+  , trapezium
+
+
+  ) where
+
+import Wumpus.Drawing.Basis.ShapeTrails
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Paths.Intersection
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+
+import Control.Applicative
+
+
+
+
+--------------------------------------------------------------------------------
+-- Trapezium
+
+-- | A trapezium.
+--
+data Trapezium u = Trapezium 
+      { tz_ctm              :: ShapeCTM u
+      , tz_base_width       :: !u
+      , tz_top_width        :: !u
+      , tz_height           :: !u
+      , tz_bottom_left_ang  :: Radian 
+      }
+
+type instance DUnit (Trapezium u) = u
+
+type DTrapezium = Trapezium Double
+
+instance Functor Trapezium where
+  fmap f (Trapezium ctm bw tw h ang) = 
+    Trapezium (fmap f ctm) (f bw) (f tw) (f h) ang
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Trapezium u -> Trapezium u
+mapCTM f = (\s i -> s { tz_ctm = f i }) <*> tz_ctm
+
+
+instance (Real u, Floating u) => Rotate (Trapezium u) where
+  rotate ang            = mapCTM (rotate ang)
+              
+instance (Real u, Floating u) => RotateAbout (Trapezium u) where
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
+
+instance Fractional u => Scale (Trapezium u) where
+  scale sx sy           = mapCTM (scale sx sy)
+
+instance InterpretUnit u => Translate (Trapezium u) where
+  translate dx dy       = mapCTM (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+
+-- | 'runDisplaceCenter' : @ ( base_width 
+--                           * height
+--                           * bl_ang -> Vec ) * trapezium -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> u -> Radian -> Vec2 u) 
+                  -> Trapezium u -> Anchor u
+runDisplaceCenter fn (Trapezium { tz_ctm              = ctm
+                                , tz_base_width       = bw
+                                , tz_height           = h 
+                                , tz_bottom_left_ang  = bl_ang  }) =
+    projectFromCtr (fn bw h bl_ang) ctm
+
+
+-- | 'runDisplaceCenterHalves' : @ ( half_base_width 
+--                                 * half_top_width
+--                                 * half_height -> Vec ) * trapezium -> Point @
+--
+runDisplaceCenterHalves :: (Real u, Floating u)
+                        => (u -> u -> u -> Vec2 u) 
+                        -> Trapezium u -> Anchor u
+runDisplaceCenterHalves fn (Trapezium { tz_ctm          = ctm
+                                      , tz_base_width   = bw
+                                      , tz_top_width    = tw
+                                      , tz_height       = h   }) =
+    projectFromCtr (fn (0.5 * bw) (0.5 * tw) (0.5 * h)) ctm
+
+
+instance (Real u, Floating u) => 
+    CenterAnchor (Trapezium u) where
+  center = runDisplaceCenter $ \_ _ _ -> V2 0 0
+
+
+
+instance (Real u, Floating u) => 
+    BottomCornerAnchor (Trapezium u) where
+  bottomLeftCorner  = runDisplaceCenterHalves $ \hbw _ hh -> V2 (-hbw) (-hh)
+  bottomRightCorner = runDisplaceCenterHalves $ \hbw _ hh -> V2  hbw   (-hh)
+
+
+
+
+
+instance (Real u, Floating u) => 
+    TopCornerAnchor (Trapezium u) where
+  topLeftCorner  = runDisplaceCenterHalves $ \_ htw hh -> V2 (-htw) hh
+  topRightCorner = runDisplaceCenterHalves $ \_ htw hh -> V2   htw  hh
+
+
+instance (Real u, Floating u, Tolerance u) => 
+    SideMidpointAnchor (Trapezium u) where
+  sideMidpoint n a = step (n `mod` 4) 
+    where
+      step 1 = north a
+      step 2 = west a
+      step 3 = south a
+      step _ = east a
+
+
+
+instance (Real u, Floating u, Tolerance u) => 
+    CardinalAnchor (Trapezium u) where
+  north = radialAnchor half_pi
+  south = radialAnchor (1.5 * pi)
+  east  = radialAnchor 0
+  west  = radialAnchor pi
+
+
+instance (Real u, Floating u, Tolerance u) => 
+    CardinalAnchor2 (Trapezium u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+
+instance (Real u, Floating u, Tolerance u) => 
+    RadialAnchor (Trapezium u) where
+   radialAnchor ang = runDisplaceCenter $ \bw h bl_ang -> 
+      maybe zeroVec id $ trapeziumRadialAnchor bw h bl_ang ang
+
+
+-- 
+trapeziumRadialAnchor :: (Real u, Floating u, Tolerance u) 
+                      => u -> u -> Radian -> Radian -> Maybe (Vec2 u)
+trapeziumRadialAnchor bw h bl_ang ang =
+    fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp 
+  where
+    rp = anaTrailPath zeroPt $ trapezium_trail bw h bl_ang
+
+
+    
+--------------------------------------------------------------------------------
+-- Construction
+
+
+-- | 'trapezium'  : @ base_width * height * bottom_left_ang * 
+--     bottom_right_ang -> Shape @
+--
+--
+trapezium :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+          => u -> u -> Radian -> Shape Trapezium u
+trapezium bw h base_ang = 
+    makeShape (mkTrapezium bw h base_ang) (mkTrapeziumPath bw h base_ang)
+
+
+
+
+--------------------------------------------------------------------------------
+
+
+mkTrapezium :: (Real u, Fractional u, InterpretUnit u) 
+            => u -> u -> Radian -> LocThetaQuery u (Trapezium u)
+mkTrapezium bw h base_ang = qpromoteLocTheta $ \ctr theta -> 
+    pure $ Trapezium { tz_ctm             = makeShapeCTM ctr theta
+                     , tz_base_width      = bw
+                     , tz_top_width       = tw
+                     , tz_height          = h
+                     , tz_bottom_left_ang = base_ang
+                     }
+  where
+    base_minor = h / (fromRadian $ tan base_ang)
+    tw         = bw - (2 * base_minor)
+
+
+mkTrapeziumPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+                => u -> u -> Radian -> LocThetaQuery u (AbsPath u)
+mkTrapeziumPath bw h bl_ang = qpromoteLocTheta $ \ctr theta -> 
+    return $ anaTrailPath ctr $ rtrapezium_trail bw h bl_ang theta
+
+
diff --git a/src/Wumpus/Drawing/Shapes/Triangle.hs b/src/Wumpus/Drawing/Shapes/Triangle.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Shapes/Triangle.hs
@@ -0,0 +1,203 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Triangle
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Isosceles triangle.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Triangle
+  ( 
+
+    Triangle
+  , DTriangle
+  , triangle
+
+  ) where
+
+import Wumpus.Drawing.Basis.ShapeTrails
+import Wumpus.Drawing.Basis.Geometry
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Paths.Intersection
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Control.Applicative
+
+
+
+
+-- Datatype
+
+-- | An isosceles triangle, oriented /upwards/.
+--
+data Triangle u = Triangle 
+      { tri_ctm         :: ShapeCTM u
+      , tri_base_width  :: !u
+      , tri_height      :: !u
+      }
+
+type instance DUnit (Triangle u) = u
+
+type DTriangle = Triangle Double
+
+instance Functor Triangle where
+  fmap f (Triangle ctm bw h) = Triangle (fmap f ctm) (f bw) (f h)
+
+
+hminor :: Fractional u => u -> u 
+hminor h = h / 3
+
+hmajor :: Fractional u => u -> u 
+hmajor h = 2 * (h / 3)
+
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Triangle u -> Triangle u
+mapCTM f = (\s i -> s { tri_ctm = f i }) <*> tri_ctm
+
+
+instance (Real u, Floating u) => Rotate (Triangle u) where
+  rotate ang            = mapCTM (rotate ang)
+              
+instance (Real u, Floating u) => RotateAbout (Triangle u) where
+  rotateAbout ang pt    = mapCTM (rotateAbout ang pt)
+
+instance Fractional u => Scale (Triangle u) where
+  scale sx sy           = mapCTM (scale sx sy)
+
+instance InterpretUnit u => Translate (Triangle u) where
+  translate dx dy       = mapCTM (translate dx dy)
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- | 'runDisplaceCenter' : @ ( half_base_width 
+--                           * height_minor 
+--                           * height_major 
+--                           * base_ang -> Vec ) * traingle -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> u -> Vec2 u) -> Triangle u -> Anchor u
+runDisplaceCenter fn (Triangle { tri_ctm        = ctm
+                               , tri_base_width = bw 
+                               , tri_height     = h   }) =  
+    projectFromCtr (fn bw h) ctm
+
+
+instance (Real u, Floating u) => 
+    CenterAnchor (Triangle u) where
+  center = runDisplaceCenter $ \_ _ -> V2 0 0
+
+
+instance (Real u, Floating u) => 
+    ApexAnchor (Triangle u) where
+  apex = runDisplaceCenter $ \_ h -> V2 0 (hmajor h)
+
+
+instance (Real u, Floating u) => 
+    BottomCornerAnchor (Triangle u) where
+  bottomLeftCorner  = runDisplaceCenter $ \bw h -> 
+                        V2 (negate $ 0.5 * bw) (negate $ hminor h)
+  bottomRightCorner = runDisplaceCenter $ \bw h -> 
+                        V2 (0.5 * bw)          (negate $ hminor h)
+
+
+-- east and west should be parallel to the centroid.
+--
+
+instance (Real u, Floating u) => 
+    CardinalAnchor (Triangle u) where
+  north = runDisplaceCenter $ \_  h -> V2 0 (hmajor h)
+  south = runDisplaceCenter $ \_  h -> V2 0 (negate $ hminor h)
+  east  = runDisplaceCenter $ \bw h -> findEast bw h
+  west  = runDisplaceCenter $ \bw h -> findWest bw h
+
+
+instance (Real u, Floating u) => 
+    SideMidpointAnchor (Triangle u) where
+  sideMidpoint n a = step (n `mod` 3) 
+    where
+      step 1 = midpoint (apex a)              (bottomLeftCorner a)
+      step 2 = midpoint (bottomLeftCorner a)  (bottomRightCorner a)
+      step _ = midpoint (bottomRightCorner a) (apex a)
+
+
+findEast :: (Real u, Fractional u) => u -> u -> Vec2 u
+findEast bw h = V2 xdist 0
+  where
+    half_base   = 0.5 * bw 
+    base_ang    = atan $ toRadian (h / half_base)
+    b1          = (hminor h) / (fromRadian $ tan base_ang)
+    xdist       = (0.5 * bw) - b1
+
+findWest :: (Real u, Fractional u) => u -> u -> Vec2 u
+findWest bw h = let (V2 xdist 0) = findEast bw h in V2 (-xdist) 0 
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    CardinalAnchor2 (Triangle u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+
+instance (Real u, Floating u, InterpretUnit u, Tolerance u) => 
+    RadialAnchor (Triangle u) where
+  radialAnchor ang = runDisplaceCenter $ \bw h -> 
+      maybe zeroVec id $ isoscelesTriangleRadialIntersect bw h ang
+
+
+
+
+    
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'triangle'  : @ base_width * height -> Shape @
+--
+--
+triangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+         => u -> u -> Shape Triangle u
+triangle bw h = makeShape (mkTriangle bw h) (mkTrianglePath bw h)
+
+
+
+
+
+mkTriangle :: (Real u, Fractional u, InterpretUnit u) 
+           => u -> u -> LocThetaQuery u (Triangle u)
+mkTriangle bw h = qpromoteLocTheta $ \ctrd theta -> 
+    pure $ Triangle { tri_ctm        = makeShapeCTM ctrd theta
+                    , tri_base_width = bw
+                    , tri_height     = h 
+                    }
+
+
+
+
+
+mkTrianglePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
+               => u -> u -> LocThetaQuery u (AbsPath u)
+mkTrianglePath bw h = qpromoteLocTheta $ \ctr theta -> 
+    return $ anaTrailPath ctr $ risosceles_triangle_trail bw h theta
+
diff --git a/src/Wumpus/Drawing/Text/Base/DocTextZero.hs b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs
@@ -0,0 +1,314 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Text.Base.DocTextZero
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC
+--
+-- Flexible text type, composable with @pretty-print@ style 
+-- operators.
+-- 
+-- Direction zero (left-to-right) only.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Text.Base.DocTextZero
+  ( 
+
+    GenDoc
+  , Doc 
+  , GenDocGraphic
+  , DocGraphic
+  , runGenDoc
+
+  , (<+>)
+  , blank
+  , space
+  , string
+  , escaped
+  , embedPosObject
+  
+  , bold
+  , italic
+  , boldItalic
+
+  , monospace
+  , int 
+  , integer
+  , float
+  , ffloat
+
+  , strikethrough
+  , underline
+  , highlight
+
+  ) where
+
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+import Data.Monoid
+import Numeric
+
+--
+-- Design Issue:
+--
+-- Can user state be added to Doc?
+--
+-- Easy if PosObject had user state, difficult as it doesn\'t...
+--
+ 
+-- | Doc type.
+--
+newtype GenDoc st u a = GenDoc { getGenDoc :: DocEnv -> GenPosObject st u a } 
+
+type instance DUnit  (GenDoc st u a) = u
+type instance UState (GenDoc st u a) = st
+
+type GenDocGraphic st u = GenDoc st u (UNil u)
+
+type Doc u a = GenDoc () u a
+
+type DocGraphic u = Doc u (UNil u)
+
+
+data DocEnv = DocEnv 
+      { doc_alignment   :: VAlign
+      , doc_font_family :: FontFamily
+      }
+
+instance Functor (GenDoc st u) where
+  fmap f ma = GenDoc $ \env -> fmap f $ getGenDoc ma env
+
+instance Applicative (GenDoc st u) where
+  pure a    = GenDoc $ \_   -> pure a
+  mf <*> ma = GenDoc $ \env -> getGenDoc mf env <*> getGenDoc ma env
+
+
+instance Monad (GenDoc st u) where
+  return a  = GenDoc $ \_   -> return a
+  ma >>= k  = GenDoc $ \env -> getGenDoc ma env >>= \a -> getGenDoc (k a) env
+
+instance (Monoid a, InterpretUnit u) => Monoid (GenDoc st u a) where
+  mempty          = GenDoc $ \_   -> mempty
+  ma `mappend` mb = GenDoc $ \env -> getGenDoc ma env `hconcat` getGenDoc mb env
+
+
+instance DrawingCtxM (GenDoc st u) where
+  askDC           = GenDoc $ \_   -> askDC 
+  asksDC fn       = GenDoc $ \_   -> asksDC fn
+  localize upd ma = GenDoc $ \env -> localize upd (getGenDoc ma env)
+
+
+instance UserStateM (GenDoc st u) where
+  getState        = GenDoc $ \_ -> getState
+  setState s      = GenDoc $ \_ -> setState s
+  updateState upd = GenDoc $ \_ -> updateState upd
+
+
+runGenDoc :: VAlign -> FontFamily -> GenDoc st u a -> GenPosObject st u a
+runGenDoc va ff ma = getGenDoc ma env1 
+  where
+    env1 = DocEnv { doc_alignment = va, doc_font_family = ff }
+
+
+
+--------------------------------------------------------------------------------
+-- Get vcat vconcat... from the Concat class
+
+instance (Monoid a, Fractional u, InterpretUnit u) => 
+    Concat (GenDoc st u a) where
+  hconcat = mappend
+  vconcat = vcatImpl
+
+vcatImpl        :: (Monoid a, Fractional u, InterpretUnit u) 
+                => GenDoc st u a -> GenDoc st u a -> GenDoc st u a
+vcatImpl ma mb  = GenDoc $ \env -> 
+    let va = doc_alignment env 
+    in textlineSpace >>= \sep -> 
+       valignSpace va sep (getGenDoc ma env) (getGenDoc mb env)
+
+--------------------------------------------------------------------------------
+-- Primitives
+
+infixr 6 <+>
+
+-- | Concatenate two Docs separated with a space.
+--
+-- (infixr 6)
+--
+(<+>) :: InterpretUnit u 
+      => GenDocGraphic st u -> GenDocGraphic st u -> GenDocGraphic st u
+a <+> b = a `mappend` space `mappend` b 
+
+
+
+blank     :: InterpretUnit u => GenDocGraphic st u
+blank     = GenDoc $ \_ -> posTextPrim (Left "")
+
+space     :: InterpretUnit u => GenDocGraphic st u
+space     = GenDoc $ \_ -> posCharPrim (Left ' ')
+
+
+string    :: InterpretUnit u => String -> GenDocGraphic st u
+string ss = GenDoc $ \_ -> posTextPrim (Left ss)
+
+
+
+escaped     :: InterpretUnit u => EscapedText -> GenDocGraphic st u
+escaped esc = GenDoc $ \_ -> posTextPrim (Right esc)
+
+embedPosObject :: GenPosObject st u a -> GenDoc st u a
+embedPosObject ma = GenDoc $ \_ -> ma
+
+
+
+--------------------------------------------------------------------------------
+-- Change font weight
+
+bold :: GenDoc st u a -> GenDoc st u a 
+bold ma = GenDoc $ \env -> 
+    localize (set_font $ boldWeight $ doc_font_family env)
+             (getGenDoc ma env)
+
+
+italic :: GenDoc st u a -> GenDoc st u a 
+italic ma = GenDoc $ \env -> 
+    localize (set_font $ italicWeight $ doc_font_family env)
+             (getGenDoc ma env)
+
+
+boldItalic :: GenDoc st u a -> GenDoc st u a 
+boldItalic ma = GenDoc $ \env -> 
+    localize (set_font $ boldItalicWeight $ doc_font_family env)
+             (getGenDoc ma env)
+
+
+--------------------------------------------------------------------------------
+-- Monospace
+
+monospace :: InterpretUnit u 
+          => EscapedChar -> EscapedText -> GenDocGraphic st u
+monospace ref_ch esc = GenDoc $ \_ -> 
+    monospaceEscText (vector_x <$> escCharVector ref_ch) esc
+
+
+
+
+int :: InterpretUnit u => Int -> GenDocGraphic st u
+int i = integer $ fromIntegral i
+
+
+integer :: InterpretUnit u => Integer -> GenDocGraphic st u
+integer i = monospace (CharLiteral '0') (escapeString $ show i)
+
+
+
+--------------------------------------------------------------------------------
+
+
+-- | Specialized version of 'ffloat' - the answer is always 
+-- rendered at \"full precision\".
+--
+float :: (RealFloat a, InterpretUnit u) => a -> GenDocGraphic st u
+float = ffloat Nothing
+
+
+-- | This is equivalent to 'showFFloat' in the Numeric module.
+-- 
+-- Like 'showFFloat', the answer is rendered to supplied 
+-- precision. @Nothing@ indicated full precision.
+--
+ffloat :: (RealFloat a, InterpretUnit u) 
+       => (Maybe Int) -> a -> GenDocGraphic st u
+ffloat mb d = 
+    monospace (CharLiteral '0') $ escapeString  $ ($ "") $ showFFloat mb d
+
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- Decorate
+
+strikethrough :: (Fractional u, InterpretUnit u) 
+              => GenDoc st u a -> GenDoc st u a
+strikethrough = decorateDoc ZABOVE drawStrikethrough 
+
+underline :: (Fractional u, InterpretUnit u) 
+          => GenDoc st u a -> GenDoc st u a
+underline = decorateDoc ZABOVE drawUnderline
+
+highlight :: (Fractional u, InterpretUnit u) 
+          => RGBi -> GenDoc st u a -> GenDoc st u a
+highlight rgb = decorateDoc ZBELOW (drawBackfill rgb) 
+ 
+
+
+decorateDoc :: InterpretUnit u 
+            => ZOrder -> (Orientation u -> LocGraphic u) -> GenDoc st u a 
+            -> GenDoc st u a
+decorateDoc zdec fn ma = GenDoc $ \env -> 
+    decoratePosObject zdec fn $ getGenDoc ma env
+
+
+           
+
+-- API might be simple if we conditionally apply strikethrough on 
+-- interpText (possibly including spaces), but never on interpSpace.
+--
+-- Might want to derive stroke_colour from text_colour and linewidth
+-- fromf font size as well...
+--
+drawStrikethrough :: (Fractional u, InterpretUnit u) 
+                  => Orientation u -> LocGraphic u
+drawStrikethrough (Orientation xmin xmaj _ ymaj) = 
+    linestyle $ moveStart (vec (-xmin) vpos) ln
+  where
+    vpos  = 0.45 * ymaj
+    ln    = locStraightLine (hvec $ xmin + xmaj)
+
+
+
+drawUnderline :: (Fractional u, InterpretUnit u) 
+              => Orientation u -> LocGraphic u
+drawUnderline (Orientation xmin xmaj _ _) = 
+    underlinePosition >>= \vpos ->
+    linestyle $ moveStart (vec (-xmin) vpos) ln
+  where
+    ln    = locStraightLine (hvec $ xmin + xmaj)
+
+
+-- | This uses underline_thickness ...
+--
+linestyle :: LocGraphic u -> LocGraphic u
+linestyle mf = 
+    underlineThickness >>= \sz -> 
+    localize (stroke_use_text_colour . set_line_width sz) mf
+
+
+-- | Note - quarter margin looks good.
+--
+drawBackfill :: (Fractional u, InterpretUnit u) 
+             => RGBi -> Orientation u -> LocGraphic u
+drawBackfill rgb (Orientation xmin xmaj ymin ymaj) = 
+    textMargin >>= \(dx,dy) -> 
+    let hdx = 0.25 * dx
+        hdy = 0.25 * dy 
+    in localize (fill_colour rgb) $ moveStart (mkVec hdx hdy) (mkRect hdx hdy)
+  where
+    mkVec  dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy)
+    mkRect dx dy = let w = dx + xmin + xmaj + dx
+                       h = dy + ymin + ymaj + dy
+                   in dcRectangle DRAW_FILL w h
+
diff --git a/src/Wumpus/Drawing/Text/Base/Label.hs b/src/Wumpus/Drawing/Text/Base/Label.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Text/Base/Label.hs
@@ -0,0 +1,217 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Text.Base.Label
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC
+--
+-- Annotation labels.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Text.Base.Label
+  ( 
+
+    locImageLabel
+
+  , label_center_of
+  , label_left_of
+  , label_right_of
+  , label_above
+  , label_below
+
+  , connectorPathLabel
+  , label_midway_of
+  , label_atstart_of
+  , label_atend_of
+
+  , centerRelative
+  , right_of
+  , left_of
+  , above_right_of
+  , below_right_of
+  , above_left_of
+  , below_left_of
+
+  ) where
+
+
+import Wumpus.Drawing.Paths
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+type BoundedLocRectGraphic u = RectAddress -> LocImage u (BoundingBox u)
+
+
+locImageLabel :: InterpretUnit u 
+              => (a -> Anchor u) 
+              -> RectAddress 
+              -> (RectAddress -> LocImage u (BoundingBox u)) 
+              -> LocImage u a 
+              -> LocImage u a
+locImageLabel fn rpos mklabel obj = promoteLoc $ \pt -> 
+    elaborateAbove (obj `at` pt)  (\a -> ignoreAns $ mklabel rpos `at` fn a)
+
+
+
+label_center_of :: (InterpretUnit u, CenterAnchor a, u ~ DUnit a) 
+                => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a
+label_center_of = locImageLabel center CENTER
+
+
+label_left_of :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) 
+              => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a
+label_left_of = locImageLabel west EE
+
+label_right_of :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) 
+               => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a
+label_right_of = locImageLabel east WW
+
+
+label_above :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) 
+            => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a
+label_above = locImageLabel north SS
+
+
+label_below :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) 
+            => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a
+label_below = locImageLabel south NN
+
+
+
+
+connectorPathLabel :: InterpretUnit u 
+                   => (AbsPath u -> Point2 u) 
+                   -> RectAddress
+                   -> BoundedLocRectGraphic u
+                   -> Image u (AbsPath u) 
+                   -> Image u (AbsPath u)
+connectorPathLabel fn rpos lbl img =  
+    elaborateAbove img  (\a -> ignoreAns $ lbl rpos `at` (fn a))
+
+
+label_midway_of :: (Real u, Floating u, InterpretUnit u) 
+                => RectAddress 
+                -> BoundedLocRectGraphic u 
+                -> Image u (AbsPath u) -> Image u (AbsPath u)
+label_midway_of = connectorPathLabel midway_
+
+
+label_atstart_of :: (Real u, Floating u, InterpretUnit u) 
+                 => RectAddress 
+                 -> BoundedLocRectGraphic u 
+                 -> Image u (AbsPath u) -> Image u (AbsPath u)
+label_atstart_of = connectorPathLabel atstart_
+
+
+label_atend_of :: (Real u, Floating u, InterpretUnit u) 
+               => RectAddress 
+               -> BoundedLocRectGraphic u
+               -> Image u (AbsPath u) -> Image u (AbsPath u)
+label_atend_of = connectorPathLabel atend_
+
+
+
+
+-- | Absolute units.
+-- 
+centerRelative :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) 
+               => (Int,Int) -> a -> Query u (Anchor u)
+centerRelative coord a = 
+    snapmove coord >>= \v -> return $ displace v (center a)
+
+-- TODO - These are really for Anchors.
+--
+-- Should the have a separate module or be rolled into the same
+-- module as the classes?
+--
+
+-- | Value is 1 snap unit right.
+--
+-- This function should be considered obsolete, pending a 
+-- re-think.
+-- 
+right_of        :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) 
+                => a -> Query u (Anchor u)
+right_of        = centerRelative (1,0)
+
+-- | Value is 1 snap move left.
+--
+-- This function should be considered obsolete, pending a 
+-- re-think.
+-- 
+left_of         :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) 
+                => a -> Query u (Anchor u)
+left_of         = centerRelative ((-1),0)
+
+-- | Value is 1 snap move up, 1 snap move right.
+--
+-- This function should be considered obsolete, pending a 
+-- re-think.
+-- 
+above_right_of  :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) 
+                => a -> Query u (Anchor u)
+above_right_of  = centerRelative (1,1)
+
+-- | Value is 1 snap move below, 1 snap move right.
+--
+-- This function should be considered obsolete, pending a 
+-- re-think.
+-- 
+below_right_of  :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) 
+                => a -> Query u (Anchor u)
+below_right_of  = centerRelative (1, (-1))
+
+-- | Value is 1 snap move up, 1 snap move left.
+--
+-- This function should be considered obsolete, pending a 
+-- re-think.
+-- 
+above_left_of   :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) 
+                => a -> Query u (Anchor u)
+above_left_of   = centerRelative ((-1),1)
+
+-- | Value is 1 snap move down, 1 snap move left.
+--
+-- This function should be considered obsolete, pending a 
+-- re-think.
+-- 
+below_left_of   :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) 
+                => a -> Query u (Anchor u)
+below_left_of   = centerRelative ((-1),(-1))
+ 
+
+
+
+-- TikZ has label=below etc.
+-- 
+-- This would probably translate to a functions:
+-- @labelBelow@
+--
+
+
+-- Design note - there aren\'t many Images that support anchors,
+-- except for LocImages that have been /saturated/ (i.e. applied 
+-- to a point with @at@).
+-- 
+-- For a saturated Image, getting at the anchors via bind does 
+-- not seem so bad (indeed, this was the original point of 
+-- anchors). Obviously it is important to add labels to LocImages
+-- (the original point of the label functions) but what about 
+-- LocThetaImages and LocRectImages. Is it acceptable to /saturate/
+-- them to LocImages before labelling them?
+-- 
+-- Connectors support different /anchor-like/ positions so they 
+-- will different labelling functions.
+-- 
+  
+
diff --git a/src/Wumpus/Drawing/Text/DirectionZero.hs b/src/Wumpus/Drawing/Text/DirectionZero.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Text/DirectionZero.hs
@@ -0,0 +1,53 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.DirectionZero
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC
+--
+-- Common import module for the Writing Direction 0 modules
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Text.DirectionZero
+  ( 
+    module Wumpus.Drawing.Text.Base.DocTextZero
+
+  , textline
+  , rtextline
+  , multilineText
+
+  ) where
+
+import Wumpus.Drawing.Text.Base.DocTextZero
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+-- | Note - this is likely to be moved...
+-- 
+-- Also, reversed argument order would be more convenient as 
+-- RectAddress always short but String could be long. 
+--
+textline :: InterpretUnit u => RectAddress -> String -> BoundedLocGraphic u
+textline addr ss = runPosObjectBBox addr (posText ss)
+
+
+-- | Note - this is likely to be moved too...
+--
+rtextline :: (Real u, Floating u, InterpretUnit u)
+          => Radian -> RectAddress -> String -> BoundedLocGraphic u
+rtextline ang addr ss = runPosObjectBBox addr (rposText ang ss)
+
+
+multilineText :: (Fractional u, InterpretUnit u)
+              => VAlign -> RectAddress -> String -> BoundedLocGraphic u
+multilineText va addr ss = runPosObjectBBox addr (multilinePosText va ss)
+
+
diff --git a/src/Wumpus/Drawing/Text/DocSymbols.hs b/src/Wumpus/Drawing/Text/DocSymbols.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Text/DocSymbols.hs
@@ -0,0 +1,78 @@
+{-# OPTIONS -Wall #-}
+
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Text.DocSymbols
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Symbols - redefined Basis.Symbols.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Text.DocSymbols
+  (
+
+    ocircle
+  , small_ocircle
+
+  , empty_box
+
+  , left_slice
+  , right_slice
+
+  )
+  where
+
+import qualified Wumpus.Drawing.Basis.Symbols as S
+import Wumpus.Drawing.Text.Base.DocTextZero
+
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+-- import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+
+
+ocircle :: (Fractional u, InterpretUnit u) => GenDocGraphic st u
+ocircle = embedPosObject $ makePosObject qy gf
+  where
+    qy = (\h -> let hh = 0.5 * h in Orientation hh hh 0 h) <$> capHeight
+    gf = capHeight >>= \h -> moveStart (go_up $ 0.5 * h) (S.scircle $ 0.5 * h)
+
+
+
+small_ocircle :: (Fractional u, InterpretUnit u) => GenDocGraphic st u
+small_ocircle = embedPosObject $ makePosObject qy gf
+  where
+    qy = (\h -> let hw = 0.33 * h in Orientation hw hw 0 h) <$> capHeight
+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.scircle $ 0.25 * h)
+
+empty_box :: (Fractional u, InterpretUnit u) => GenDocGraphic st u
+empty_box = embedPosObject $ makePosObject qy gf
+  where
+    qy = (\h -> let hw = 0.5 * h in Orientation hw hw 0 h) <$> capHeight
+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.empty_box $ 0.66 * h)
+
+
+
+left_slice :: (Real u, Floating u, InterpretUnit u) => GenDocGraphic st u
+left_slice = embedPosObject $ makePosObject qy gf
+  where
+    qy = (\h -> let hw = 0.66 * h in Orientation hw hw 0 h) <$> capHeight
+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.sleft_slice h)
+
+right_slice :: (Real u, Floating u, InterpretUnit u) => GenDocGraphic st u
+right_slice = embedPosObject $ makePosObject qy gf
+  where
+    qy = (\h -> let hw = 0.66 * h in Orientation hw hw 0 h) <$> capHeight
+    gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.sright_slice h)
+
+-- More to follow...
+
diff --git a/src/Wumpus/Drawing/Text/LRText.hs b/src/Wumpus/Drawing/Text/LRText.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Text/LRText.hs
+++ /dev/null
@@ -1,409 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Text.LRText
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC
---
--- Left-to-right measured text. The text uses glyph metrics so it 
--- can be positioned accurately.
--- 
--- \*\* WARNING \*\* - the API for this module needs work. The 
--- current API is not satisfactory for drawing according to a 
--- start position (there are other reasonable start positions than 
--- the ones currently supported - adding them would explode the 
--- number of definitions).
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Text.LRText
-  ( 
-
-    baseCenterLine
-  , baseLeftLine
-  , baseRightLine
-
-  , rbaseCenterLine
-  , rbaseLeftLine
-  , rbaseRightLine
-
-  , ctrCenterLine
-  , baseCenterEscChar
-
-  , multiAlignLeft
-  , multiAlignCenter
-  , multiAlignRight
-
-  , rmultiAlignLeft
-  , rmultiAlignCenter
-  , rmultiAlignRight
- 
-
-  ) where
-
-
-import Wumpus.Basic.Kernel
-
-import Wumpus.Core                              -- package: wumpus-core
-import Wumpus.Core.Text.GlyphIndices
-
-import Data.AffineSpace                         -- package: vector-space
-import Data.VectorSpace
-
-import Control.Applicative
-import Data.Char
-import qualified Data.Map               as Map
-import Data.Maybe 
-
-
--- Note - BoundedLocThetaGraphic is probably an adequate type
--- even though the same text will have a different bounding box
--- if it is rotated (the sides of the BBox are always parallel to 
--- the x and y axes even if the text is not parrale to the 
--- x-axis). 
--- 
--- I cannot think of any compelling graphics that need a more 
--- accurate type. The execption is text cannot have exact anchors 
--- however this is a moot /if/ text is considered as a labelling 
--- of an existing rectangle (which may or may not have been 
--- rotated).
---
-
-
-
--- One line of multiline text
---
-data OnelineText u = OnelineText EscapedText (AdvanceVec u)
-
-
--- | max_width * oneline_text -> LocThetaGraphic
---
-type LocThetaDrawOneline u = u -> OnelineText u -> LocThetaGraphic u
-
-
--- | max_width * oneline_text -> LocThetaGraphic
---
-type BoundedLocThetaOneline u = u -> OnelineText u -> BoundedLocThetaGraphic u
-
-
--- | Draw one line of left-aligned text, knowing the max_width 
--- of all the lines of text.
---
--- All left-aligned text is moved left by half the max_width.
---
--- Note - implicit point is baseline-center, this is perhaps 
--- unintituitive given the functions name but it is an 
--- advantage for drawing multi-line text.
--- 
-drawLeftAligned :: Floating u => LocThetaDrawOneline u
-drawLeftAligned max_width (OnelineText esc _) = 
-    promoteR2 $ \baseline_ctr theta -> 
-       let mv = displaceParallel ((-0.5) * max_width) theta
-       in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
-       
-
-
--- | Draw one line of center-aligned text. Center aligned text is 
--- oblivious to the max_width of all the lines of text.
---
--- Each line of center-aligned text is moved left by half its 
--- advance vector.
---
--- Implicit point is baseline-center.
---
-drawCenterAligned :: Floating u => LocThetaDrawOneline u
-drawCenterAligned _ (OnelineText esc av) = 
-    promoteR2 $ \baseline_ctr theta -> 
-       let mv = displaceParallel (negate $ 0.5 * advanceH av) theta
-       in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
-       
-
--- | Draw one line of right-aligned text, knowing the max_width 
--- of all the lines of text.
---
--- Each right-aligned text line is moved by the width component 
--- of the advance vector minus half the max width.
---
--- Note - implicit point is baseline-center, this is perhaps 
--- unintituitive given the functions name but it is an 
--- advantage for drawing multi-line text.
--- 
-drawRightAligned :: Floating u => LocThetaDrawOneline u
-drawRightAligned max_width (OnelineText esc av) = 
-    promoteR2 $ \baseline_ctr theta -> 
-      let mv = displaceParallel ((0.5 * max_width) - advanceH av) theta
-      in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
-
-
-
-
--- Impilict point is baseline-center.
---
-onelineBBox :: (Real u, Floating u, FromPtSize u) 
-            => OnelineText u -> LocThetaDrawingInfo u (BoundingBox u)
-onelineBBox (OnelineText _ av) = 
-    promoteR2 $ \baseline_ctr theta -> 
-      glyphHeightRange >>= \(ymin, ymax) ->
-      getTextMargin    >>= \(xsep, ysep) -> 
-        let hw        = 0.5 * advanceH av 
-            btm_left  = baseline_ctr .+^ vec (-hw) ymin
-            top_right = baseline_ctr .+^ vec hw    ymax
-            bbox      = expandBB xsep ysep (BBox btm_left top_right)
-        in pure $ centerOrthoBBox theta bbox
-  where
-    expandBB xsep ysep (BBox (P2 x0 y0) (P2 x1 y1)) = 
-        BBox (P2 (x0-xsep) (y0-ysep)) (P2 (x1+xsep) (y1+ysep))
-    
-
-
-
-
-
-
--- This should have max_width as a param...
---
-makeMoveableLine :: (Real u, Floating u, FromPtSize u) 
-                 => LocThetaDrawOneline u 
-                 -> BoundedLocThetaOneline u
-makeMoveableLine drawF max_width oline =
-      intoLocThetaImage (onelineBBox oline) (drawF max_width oline)
-
-onelineAlg :: (Real u, Floating u, FromPtSize u) 
-           => DisplaceFun u 
-           -> LocThetaDrawOneline u 
-           -> EscapedText
-           -> BoundedLocThetaGraphic u
-onelineAlg ptMoveF drawF esc = 
-   promoteR2 $ \pt theta -> 
-     onelineEscText esc >>= \ans@(OnelineText _ av) ->
-       let max_width = advanceH av
-           move      = ptMoveF max_width ans theta 
-       in apply2R2 (makeMoveableLine drawF max_width ans) (move pt) theta
-
-
-
-
-
--- | Draw 1 line...
---
--- Impilict point is baseline-left.
---
-
-baseLeftLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocGraphic u
-baseLeftLine ss = rbaseLeftLine ss `rot` 0
-
-
-
--- | Draw 1 line...
---
--- Impilict point is baseline-center.
---
-baseCenterLine :: (Real u, Floating u, FromPtSize u) 
-               => String -> BoundedLocGraphic u
-baseCenterLine ss = rbaseCenterLine ss `rot` 0
-
-
-
-
--- | Draw 1 line...
---
--- Impilict point is baseline-right.
---
-baseRightLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocGraphic u
-baseRightLine ss = rbaseRightLine ss `rot` 0
-
-
-
-rbaseLeftLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocThetaGraphic u
-rbaseLeftLine ss = 
-    onelineAlg leftToCenter drawLeftAligned (escapeString ss)
-
-
-rbaseCenterLine :: (Real u, Floating u, FromPtSize u) 
-                => String -> BoundedLocThetaGraphic u
-rbaseCenterLine ss = 
-    onelineAlg centerToCenter drawCenterAligned (escapeString ss)
-
-
-rbaseRightLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocThetaGraphic u
-rbaseRightLine ss = 
-    onelineAlg rightToCenter drawRightAligned (escapeString ss)
-
-
--- Note - assumes the ymin of the font is 0 or less.
---
-ctrCenterLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocGraphic u
-ctrCenterLine ss =
-    glyphHeightRange >>= \(ymin, ymax) -> 
-      let hh = 0.5 * ymax - ymin in 
-        moveStartPoint (displaceV $ negate $ hh - abs ymin) $ baseCenterLine ss
-
-
-
-baseCenterEscChar :: (Real u, Floating u, FromPtSize u) 
-                  => EscapedChar -> BoundedLocGraphic u
-baseCenterEscChar esc = body `rot` 0
-  where
-    body = onelineAlg centerToCenter drawCenterAligned (wrapEscChar esc)
-
-
-
-
-
-
--- | max_width * interim_text * theta -> (Point -> Point)
---
-type DisplaceFun u = u -> OnelineText u -> Radian -> PointDisplace u
-
-centerToCenter :: DisplaceFun u
-centerToCenter _ _ _ = id
-
-leftToCenter :: Floating u => DisplaceFun u
-leftToCenter max_width _ theta =
-    displaceParallel (0.5 * max_width) theta
-
-rightToCenter :: Floating u => DisplaceFun u
-rightToCenter max_width (OnelineText _ av) theta =
-    displaceParallel ((0.5 * max_width) - advanceH av) theta
-
-
-
-
-multiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u)
-               => String
-               -> BoundedLocGraphic u
-multiAlignLeft ss = rmultiAlignLeft ss `rot` 0
-
-
-multiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u)
-                 => String
-                 -> BoundedLocGraphic u
-multiAlignCenter ss = rmultiAlignCenter ss `rot` 0
-
-
-
-
-multiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u)
-                => String
-                -> BoundedLocGraphic u
-multiAlignRight ss = rmultiAlignRight ss `rot` 0
-
-
-rmultiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u)
-               => String
-               -> BoundedLocThetaGraphic u
-rmultiAlignLeft = multilineTEXT (makeMoveableLine drawLeftAligned)
-
-
-rmultiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u)
-                  => String
-                  -> BoundedLocThetaGraphic u
-rmultiAlignCenter = multilineTEXT (makeMoveableLine drawCenterAligned)
-
-
-rmultiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u)
-                 => String
-                 -> BoundedLocThetaGraphic u
-rmultiAlignRight = multilineTEXT (makeMoveableLine drawRightAligned)
-
-
-
-multilineTEXT :: (Floating u, Ord u, FromPtSize u)
-              => BoundedLocThetaOneline u
-              -> String
-              -> BoundedLocThetaGraphic u
-multilineTEXT _  [] = lift1R2 emptyBoundedLocGraphic
-multilineTEXT mf ss = 
-    lift0R2 (linesToInterims ss) >>= \(max_av, itexts) -> 
-      centralPoints (length itexts) >>= \pts -> 
-        zipMultis (advanceH max_av) mf itexts pts
-
-
-      
-
-zipMultis :: (Ord u, FromPtSize u)
-          => u
-          -> BoundedLocThetaOneline u
-          -> [OnelineText u] -> [Point2 u]
-          -> BoundedLocThetaGraphic u
-zipMultis _     _  []     _       = lift1R2 $ emptyBoundedLocGraphic
-zipMultis _     _  _      []      = lift1R2 $ emptyBoundedLocGraphic
-zipMultis max_w mf (a:as) (b:bs) = step a b as bs
-  where
-    mkGraphic itext pt        = promoteR2 $ \_ theta -> 
-                                  apply2R2 (mf max_w itext) pt theta
-    step r s (r2:rs) (s2:ss)  = liftA2 oplus (mkGraphic r s) (step r2 s2 rs ss)
-    step r s _       _        = mkGraphic r s
-
-
-
-
--- | @ana@ is an /anacrusis/ factor - if there are even points
--- half the baseline_spacing is added to get the top point
---
-centralPoints :: Floating u => Int -> LocThetaDrawingInfo u [Point2 u]
-centralPoints n | n < 2     = promoteR2 $ \ctr _  -> return [ctr]
-                | even n    = body (n `div` 2) (0.5*)
-                | otherwise = body (n `div` 2) (0 *) 
-  where
-    body halfn ana  = promoteR2 $ \ctr theta -> 
-                        baselineSpacing >>= \h ->
-                          let y0  = (h * fromIntegral halfn) + ana h
-                              top = displacePerpendicular y0 theta ctr
-                          in pure $ trailPoints n h theta top
-        
-
-
-trailPoints :: Floating u => Int -> u -> Radian -> Point2 u -> [Point2 u]
-trailPoints n height theta top = take n $ iterate fn top
-  where
-    fn pt = displacePerpendicular (-height) theta pt
-
-
-
---------------------------------------------------------------------------------
-
--- This isn't worth the complexity to get down to one traversal...
-
-linesToInterims :: (FromPtSize u, Ord u) 
-                => String -> DrawingInfo (AdvanceVec u, [OnelineText u])
-linesToInterims = fmap post . mapM (onelineEscText . escapeString) . lines
-  where
-    post xs                    = let vmax = foldr fn (hvec 0) xs in (vmax,xs)
-    fn (OnelineText _ av) vmax = avMaxWidth av vmax
-
-avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u
-avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a
-
-onelineEscText :: FromPtSize u => EscapedText -> DrawingInfo (OnelineText u)
-onelineEscText esc = fmap (OnelineText esc) $ textVector esc
-
-
-
-textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u)
-textVector esc = 
-    cwLookupTable >>= \table -> 
-       let cs = destrEscapedText id esc 
-       in pure $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs
-     
-   
-
-
-charWidth :: FromPtSize u 
-          => CharWidthTable u -> EscapedChar -> AdvanceVec u
-charWidth fn (CharLiteral c) = fn $ ord c
-charWidth fn (CharEscInt i)  = fn i
-charWidth fn (CharEscName s) = fn ix
-  where
-    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices
diff --git a/src/Wumpus/Drawing/Text/SafeFonts.hs b/src/Wumpus/Drawing/Text/SafeFonts.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Text/SafeFonts.hs
+++ /dev/null
@@ -1,167 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Text.SafeFonts
--- Copyright   :  (c) Stephen Tetley 2009-2010
--- License     :  BSD3
---
--- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
--- Stability   :  highly unstable
--- Portability :  GHC
---
--- Safe to use \"Core 13\" fonts that are expected to be present
--- for any PostScript interpreter.
---
--- Note - regrettably Symbol is not safe to use for SVG.
---
--- \*\* WARNING \*\* - this module is in flux due to changes to 
--- Text encoding in Wumpus-Core and adding font metrics to 
--- Wumpus-Basic. The code here is likely to be revised.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Text.SafeFonts
-  ( 
-  -- * Times Roman
-    times_roman
-  , times_italic
-  , times_bold
-  , times_bold_italic
-
-  -- * Helvetica
-  , helvetica
-  , helvetica_oblique
-  , helvetica_bold
-  , helvetica_bold_oblique
-
-  -- * Courier
-  , courier
-  , courier_oblique
-  , courier_bold
-  , courier_bold_oblique
-
-  -- * Symbol
-  , symbol
-
-  ) where
-
-
-
-import Wumpus.Core
-import Wumpus.Core.Text.StandardEncoding
-import Wumpus.Core.Text.Symbol
-
--- Supported fonts are:
---
--- Times-Roman  Times-Italic       Times-Bold      Times-BoldItalic
--- Helvetica    Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique
--- Courier      Courier-Oblique    Courier-Bold    Courier-Bold-Oblique
--- Symbol
-
---------------------------------------------------------------------------------
--- 
-
--- | Times-Roman
--- 
-times_roman :: FontFace
-times_roman = 
-    FontFace "Times-Roman" "Times New Roman" SVG_REGULAR standard_encoding
-
--- | Times Italic
---
-times_italic :: FontFace
-times_italic = 
-    FontFace "Times-Italic" "Times New Roman" SVG_ITALIC standard_encoding
-                       
--- | Times Bold
---
-times_bold :: FontFace
-times_bold = 
-    FontFace "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding
-
--- | Times Bold Italic
---
-times_bold_italic :: FontFace
-times_bold_italic = FontFace "Times-BoldItalic" 
-                             "Times New Roman" 
-                             SVG_BOLD_ITALIC 
-                             standard_encoding
-
-
---------------------------------------------------------------------------------
--- Helvetica
-
--- | Helvetica 
---
-helvetica :: FontFace
-helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding
-
-
--- | Helvetica Oblique
---
-helvetica_oblique :: FontFace
-helvetica_oblique = 
-    FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding
-
--- | Helvetica Bold
--- 
-helvetica_bold :: FontFace
-helvetica_bold = 
-    FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding
-
-
--- | Helvetica Bold Oblique
---
-helvetica_bold_oblique :: FontFace
-helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" 
-                                  "Helvetica" 
-                                  SVG_BOLD_OBLIQUE 
-                                  standard_encoding
-
-
-
---------------------------------------------------------------------------------
-
--- | Courier
--- 
-courier :: FontFace
-courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding
-
--- | Courier Oblique
--- 
-courier_oblique :: FontFace
-courier_oblique = 
-    FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding
-
--- | Courier Bold
--- 
-courier_bold :: FontFace
-courier_bold = 
-    FontFace "Courier-Bold" "Courier New" SVG_BOLD standard_encoding
-
-
--- | Courier Bold Oblique
--- 
-courier_bold_oblique :: FontFace
-courier_bold_oblique = FontFace "Courier-Bold-Oblique" 
-                                "Courier New" 
-                                SVG_BOLD_OBLIQUE 
-                                standard_encoding
-
---------------------------------------------------------------------------------
--- Symbol
-
--- | Symbol
---
--- Note - Symbol is intentionally not supported for SVG by some 
--- renderers (Firefox). Chrome is fine, but the use of symbol 
--- should be still be avoided for web graphics.
--- 
-symbol :: FontFace
-symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_encoding
-
-
-
-
-
diff --git a/src/Wumpus/Drawing/Text/StandardFontDefs.hs b/src/Wumpus/Drawing/Text/StandardFontDefs.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Text/StandardFontDefs.hs
@@ -0,0 +1,323 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Text.StandardFontDefs
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Safe to use \"Core 13\" fonts that are expected to be present
+-- for any PostScript interpreter.
+--
+-- Note - regrettably Symbol is not safe to use for SVG.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Text.StandardFontDefs
+  ( 
+  -- * Times Roman
+    times_roman_family
+  
+  , times_roman
+  , times_italic
+  , times_bold
+  , times_bold_italic
+
+  -- * Helvetica
+  , helvetica_family
+
+  , helvetica
+  , helvetica_oblique
+  , helvetica_bold
+  , helvetica_bold_oblique
+
+  -- * Courier
+  , courier_family
+
+  , courier
+  , courier_oblique
+  , courier_bold
+  , courier_bold_oblique
+
+  -- * Symbol
+  , symbol
+
+  ) where
+
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Text.StandardEncoding
+import Wumpus.Core.Text.Symbol
+
+-- Supported fonts are:
+--
+-- Times-Roman  Times-Italic       Times-Bold      Times-BoldItalic
+-- Helvetica    Helvetica-Oblique  Helvetica-Bold  Helvetica-Bold-Oblique
+-- Courier      Courier-Oblique    Courier-Bold    Courier-Bold-Oblique
+-- Symbol
+
+--------------------------------------------------------------------------------
+-- 
+
+-- | 'FontFamily' definition for Times-Roman.
+--
+times_roman_family :: FontFamily
+times_roman_family = 
+    FontFamily { ff_regular     = times_roman
+               , ff_bold        = Just times_bold
+               , ff_italic      = Just times_italic
+               , ff_bold_italic = Just times_bold_italic
+               }
+
+
+-- | Times-Roman
+-- 
+times_roman :: FontDef
+times_roman = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n021003l.afm"          -- NimbusRomNo9L-Regu
+            , afm_file_name   = "Times-Roman.afm"
+            }
+  where
+    face = FontFace { ps_font_name      = "Times-Roman" 
+                    , svg_font_family   = "Times New Roman" 
+                    , svg_font_style    = SVG_REGULAR 
+                    , font_enc_vector   = standard_encoding
+                    }
+
+
+-- | Times Italic
+--
+times_italic :: FontDef
+times_italic =
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n021023l.afm"        -- NimbusRomNo9L-ReguItal
+            , afm_file_name   = "Times-Italic.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Times-Italic"
+                     , svg_font_family  = "Times New Roman"
+                     , svg_font_style   = SVG_ITALIC
+                     , font_enc_vector  = standard_encoding
+                     }
+
+
+-- | Times Bold
+--
+times_bold :: FontDef
+times_bold = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n021004l.afm"          -- NimbusRomNo9L-Medi
+            , afm_file_name   = "Times-Bold.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Times-Bold"
+                     , svg_font_family  = "Times New Roman"
+                     , svg_font_style   = SVG_BOLD
+                     , font_enc_vector  = standard_encoding
+                     }
+
+
+-- | Times Bold Italic
+--
+times_bold_italic :: FontDef
+times_bold_italic = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n021024l.afm"          -- NimbusRomNo9L-MediItal
+            , afm_file_name   = "Times-BoldItalic.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Times-BoldItalic"
+                     , svg_font_family  = "Times New Roman"
+                     , svg_font_style   = SVG_BOLD_ITALIC
+                     , font_enc_vector  = standard_encoding
+                     }
+
+
+--------------------------------------------------------------------------------
+-- Helvetica
+
+-- | 'FontFamily' definition for Helvetica.
+--
+helvetica_family :: FontFamily
+helvetica_family = 
+    FontFamily { ff_regular     = helvetica
+               , ff_bold        = Just helvetica_bold
+               , ff_italic      = Just helvetica_oblique
+               , ff_bold_italic = Just helvetica_bold_oblique
+               }
+
+
+
+-- | Helvetica regular weight.
+--
+helvetica :: FontDef
+helvetica =
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n019003l.afm"          -- NimbusSanL-Regu
+            , afm_file_name   = "Helvetica.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Helvetica"
+                     , svg_font_family  = "Helvetica"
+                     , svg_font_style   = SVG_REGULAR
+                     , font_enc_vector  = standard_encoding
+                     }
+
+
+-- | Helvetica Oblique
+--
+helvetica_oblique :: FontDef
+helvetica_oblique = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n019023l.afm"          -- NimbusSanL-ReguItal
+            , afm_file_name   = "Helvetica-Oblique.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Helvetica-Oblique"
+                     , svg_font_family  = "Helvetica"
+                     , svg_font_style   = SVG_OBLIQUE
+                     , font_enc_vector  = standard_encoding
+                     }
+
+-- | Helvetica Bold
+-- 
+helvetica_bold :: FontDef
+helvetica_bold = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n019004l.afm"          -- NimbusSanL-Bold
+            , afm_file_name   = "Helvetica-Bold.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Helvetica-Bold"
+                     , svg_font_family  = "Helvetica"
+                     , svg_font_style   = SVG_BOLD
+                     , font_enc_vector  = standard_encoding
+                     }
+
+
+-- | Helvetica Bold Oblique
+--
+helvetica_bold_oblique :: FontDef
+helvetica_bold_oblique = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n019024l.afm"          -- NimbusSanL-BoldItal
+            , afm_file_name   = "Helvetica-BoldOblique.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Helvetica-Bold-Oblique"
+                     , svg_font_family  = "Helvetica"
+                     , svg_font_style   = SVG_BOLD_OBLIQUE
+                     , font_enc_vector  = standard_encoding
+                     }
+
+
+
+--------------------------------------------------------------------------------
+
+-- | 'FontFamily' definition for Courier.
+--
+courier_family :: FontFamily
+courier_family = 
+    FontFamily { ff_regular     = courier
+               , ff_bold        = Just courier_bold
+               , ff_italic      = Just courier_oblique
+               , ff_bold_italic = Just courier_bold_oblique
+               }
+
+
+
+-- | Courier
+-- 
+courier :: FontDef
+courier = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n022003l.afm"          -- NimbusMonL-Regu
+            , afm_file_name   = "Courier.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Courier"
+                     , svg_font_family  = "Courier New"
+                     , svg_font_style   = SVG_REGULAR
+                     , font_enc_vector  = standard_encoding
+                     }
+
+-- | Courier Oblique
+-- 
+courier_oblique :: FontDef
+courier_oblique = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n022023l.afm"          -- NimbusMonL-ReguObli
+            , afm_file_name   = "Courier-Oblique.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Courier-Oblique"
+                     , svg_font_family  = "Courier New"
+                     , svg_font_style   = SVG_OBLIQUE
+                     , font_enc_vector  = standard_encoding
+                     }
+
+
+-- | Courier Bold
+-- 
+courier_bold :: FontDef
+courier_bold =
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n022004l.afm"          -- NimbusMonL-Bold
+            , afm_file_name   = "Courier-Bold.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Courier-Bold"
+                     , svg_font_family  = "Courier New"
+                     , svg_font_style   = SVG_BOLD
+                     , font_enc_vector  = standard_encoding
+                     }
+
+
+-- | Courier Bold Oblique
+-- 
+courier_bold_oblique :: FontDef
+courier_bold_oblique = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "n022024l.afm"          -- NimbusMonL-BoldObli
+            , afm_file_name   = "Courier-BoldOblique.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Courier-Bold-Oblique"
+                     , svg_font_family  = "Courier New"
+                     , svg_font_style   = SVG_BOLD_OBLIQUE
+                     , font_enc_vector  = standard_encoding
+                     }
+
+--------------------------------------------------------------------------------
+-- Symbol
+
+-- | Symbol
+--
+-- Note - Symbol is intentionally not supported for SVG by some 
+-- renderers (Firefox). Chrome is fine, but the use of symbol 
+-- should be still be avoided for web graphics.
+-- 
+symbol :: FontDef
+symbol = 
+    FontDef { font_def_face   = face
+            , gs_file_name    = "s050000l.afm"          -- StandardSymL
+            , afm_file_name   = "Symbol.afm"
+            }
+  where
+    face =  FontFace { ps_font_name     = "Symbol"
+                     , svg_font_family  = "Symbol"
+                     , svg_font_style   = SVG_REGULAR
+                     , font_enc_vector  = symbol_encoding
+                     }
+
+
+
+
+
diff --git a/src/Wumpus/Drawing/Turtle/TurtleClass.hs b/src/Wumpus/Drawing/Turtle/TurtleClass.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Turtle/TurtleClass.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Turtle.TurtleClass
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- Turtle monad and monad transformer.
---
--- The Turtle monad embodies the LOGO style of imperative 
--- drawing - sending commands to update the a cursor.
---
--- While Wumpus generally aims for a more compositional,
--- \"coordinate-free\" style of drawing, some types of diagram 
--- are more easily expressed in the LOGO style.
---
--- Note - as turtle drawing with Wumpus is a /local effect/, 
--- there is only one instance of TurtleM. Potentially TurtleM 
--- will be removed and the functions implemented directly. 
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Turtle.TurtleClass
-  (
-
-    Coord
-
-  , TurtleM(..)
-
-  , setsLoc
-  , setsLoc_
-
-  -- * movement
-  , resetLoc
-  , moveLeft
-  , moveRight
-  , moveUp
-  , moveDown
-  , nextLine
- 
-
-  ) where
-
-
-
-type Coord = (Int,Int)
-
-
-class Monad m => TurtleM m where
-  getLoc     :: m (Int,Int)
-  setLoc     :: (Int,Int) -> m ()
-  getOrigin  :: m (Int,Int)
-  setOrigin  :: (Int,Int) -> m ()
-
-
-
-setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a
-setsLoc f = getLoc      >>= \coord -> 
-            let (a,coord') = f coord in setLoc coord' >> return a
-
-setsLoc_ :: TurtleM m => (Coord -> Coord) -> m ()
-setsLoc_ f = getLoc     >>= \coord ->  setLoc (f coord)
-
-
-resetLoc    :: TurtleM m => m ()
-resetLoc    = getOrigin >>= setLoc
-
-
-moveRight   :: TurtleM m => m ()
-moveRight   = setsLoc_ $ \(x,y)-> (x+1, y)
-
-
-moveLeft    :: TurtleM m => m ()
-moveLeft    = setsLoc_ $ \(x,y) -> (x-1,y)
-
-moveUp      :: TurtleM m => m ()
-moveUp      = setsLoc_ $ \(x,y) -> (x,y+1)
-
-moveDown    :: TurtleM m => m ()
-moveDown    = setsLoc_ $ \(x,y) -> (x ,y-1)
-
-
-nextLine    :: TurtleM m => m ()
-nextLine    = getOrigin >>= \(ox,_) ->
-              setsLoc_ $ \(_,y) -> (ox,y-1)
-
diff --git a/src/Wumpus/Drawing/Turtle/TurtleMonad.hs b/src/Wumpus/Drawing/Turtle/TurtleMonad.hs
deleted file mode 100644
--- a/src/Wumpus/Drawing/Turtle/TurtleMonad.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE UndecidableInstances       #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Drawing.Turtle.TurtleMonad
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- Turtle monad transformer.
---
--- The Turtle monad embodies the LOGO style of imperative 
--- drawing - sending commands to update the a cursor.
---
--- While Wumpus generally aims for a more compositional,
--- \"coordinate-free\" style of drawing, some types of 
--- diagram are more easily expressed in the LOGO style.
---
--- Turtle is only a transformer - it is intended to be run within
--- a 'Drawing'.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Drawing.Turtle.TurtleMonad
-  (
-    -- * Re-exports
-    module Wumpus.Drawing.Turtle.TurtleClass
-
-  -- * Turtle transformer
-  , TurtleT
-  , runTurtleT
-
-   
-  ) where
-
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Turtle.TurtleClass
-
-
-
-import Control.Applicative
-import Control.Monad
-
-
--- Note - if Turtle is now just a /local effect/ monad is the 
--- Turtle class still needed? Afterall, there is (probably)
--- only ever going to be one instance.
---
-
--- Turtle is a Reader / State monad
--- 
--- The env is the horizontal and vertical move distances.
--- 
--- The state is the current coordinate and the origin.
---
-
-data TurtleState = TurtleState 
-      { _turtle_origin   :: (Int,Int)
-      , _current_coord   :: (Int,Int)
-      }
-
-newtype TurtleT u m a = TurtleT { 
-          getTurtleT :: ScalingContext Int Int u 
-                     -> TurtleState 
-                     -> m (a, TurtleState) }
-
-type instance MonUnit (TurtleT u m) = u
-    
-
-
--- Functor
-
-
-
-instance Monad m => Functor (TurtleT u m) where
-  fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->
-                               return (f a, s')
-
-
--- Applicative 
-
-instance Monad m => Applicative (TurtleT u m) where
-  pure a    = TurtleT $ \_ s -> return (a,s)
-  mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s  >>= \(f,s')  ->
-                                getTurtleT ma r s' >>= \(a,s'') ->
-                                return (f a,s'') 
-
-
--- Monad 
-
-instance Monad m => Monad (TurtleT u m) where
-  return a = TurtleT $ \_ s -> return (a,s)
-  m >>= k  = TurtleT $ \r s -> getTurtleT m r s        >>= \(a,s')  ->
-                               (getTurtleT . k) a r s' >>= \(b,s'') ->
-                               return (b,s'')
-
-
-
-
-instance Monad m => TurtleM (TurtleT u m) where
-  getLoc      = TurtleT $ \_ s@(TurtleState _ c) -> return (c,s)
-  setLoc c    = TurtleT $ \_ (TurtleState o _)   -> return ((),TurtleState o c)
-  getOrigin   = TurtleT $ \_ s@(TurtleState o _) -> return (o,s)
-  setOrigin o = TurtleT $ \_ (TurtleState _ c)   -> return ((),TurtleState o c)
-
-
-runTurtleT :: (Monad m, Num u) 
-           => (Int,Int) -> ScalingContext Int Int u -> TurtleT u m a -> m a
-runTurtleT ogin cfg mf = getTurtleT mf cfg st0 >>= \(a,_) -> return a
-  where 
-    st0 = TurtleState ogin ogin 
-
-
-
-----------------------------------------------------------------------------------
--- Cross instances
-
-instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where
-  askDC           = TurtleT $ \_ s -> askDC >>= \ ctx -> return (ctx,s)
-  localize upd mf = TurtleT $ \r s -> localize upd (getTurtleT mf r s)
-
-
--- This needs undecidable instances...
-
-instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where
-  trace a  = TurtleT $ \_ s -> trace a >> return ((),s)
-
-
-instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where
-  position = TurtleT $ \r s@(TurtleState _ (x,y)) -> return (scalePt r x y,s)
-
diff --git a/src/Wumpus/Drawing/VersionNumber.hs b/src/Wumpus/Drawing/VersionNumber.hs
--- a/src/Wumpus/Drawing/VersionNumber.hs
+++ b/src/Wumpus/Drawing/VersionNumber.hs
@@ -3,7 +3,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Drawing.VersionNumber
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2012
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
@@ -23,7 +23,7 @@
 
 -- | Version number
 --
--- > (0,1,0)
+-- > (0,9,0)
 --
 wumpus_drawing_version :: (Int,Int,Int)
-wumpus_drawing_version = (0,1,0)
+wumpus_drawing_version = (0,9,0)
diff --git a/wumpus-drawing.cabal b/wumpus-drawing.cabal
--- a/wumpus-drawing.cabal
+++ b/wumpus-drawing.cabal
@@ -1,5 +1,5 @@
 name:             wumpus-drawing
-version:          0.1.0
+version:          0.9.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -12,7 +12,7 @@
   \*\* WARNING \*\* - this package is sub-alpha. Although many of 
   the drawing objects have been improved since the code was split 
   from Wumpus-Basic, the code is still prototypical. Essentially
-  this package is a /technology preview/ and not a re-usable 
+  this package is a /technology preview/ and not yet a re-usable 
   library.
   .
   NOTE - many of the demos use font metrics. Font metrics for
@@ -24,7 +24,7 @@
   links below. To run the demos properly you will need one of 
   these sets of metrics.
   .
-  Adobe Font techinal notes:
+  Adobe Font technical notes:
   <https://www.adobe.com/devnet/font.html>
   .
   Core 14 AFM metrics:
@@ -38,22 +38,44 @@
   .
   Changelog:
   .
-  v0.1.0:
+  v0.8.0 to v0.9.0:
+  . 
+  * Updated to work with wumpus-basic-0.24.0. 
   .
-  * Initial release - this is a split from @Wumpus-Basic@ making 
-    the (very prototypical - read sub-alpha, unstable...) modules 
-    in the @Drawing@ hierarchy a separate package.
+  * Removed monoid mappend alias @(<>)@ as it is now defined by
+    Data.Monoid. 
   .
-  * Simplified Chains - chains are now regular lists (though often
-    infinite). Drawings are made with chains using new zip-like
-    functions.
+  v0.7.0 to v0.8.0:
   .
-  * Re-worked Shapes.
+  * Changed API to make Connectors.
   .
-  * Re-worked Arrow and Arrow Tip types.
+  * Added InclineTrails to Drawing.Basis.
+  . 
+  * Reworked @Extras.Loop@.
   .
-  * Re-worked ConnectorPaths.
+  v0.6.0 to v0.7.0:
   .
+  * Changed paths - @RelPath@ has been removed and there are now 
+    only absolute paths. @PathBuilder@ builds absolute paths.
+    Pen updating in @PathBuilder@ now works like a State monad 
+    rather than @local@ in a Reader monad.
+  .
+  * Changed argument order of the run functions to @monadLib@ 
+    style (params * monadic action) rather than @MTL@ style 
+    (monadic action * params).
+  .
+  * Added Symbols to Drawing.Basis.
+  .
+  * Added a tube box connector.
+  .
+  v0.5.0 to v0.6.0:
+  .
+  * Removed @LocTrace@ and @RefTrace@ from @Wumpus.Drawing.Basis@,
+    they are superseded by @LocDrawing@ in Wumpus-Basic.
+  . 
+  * Remaned path building operations in @RelPathBuilder@.
+  .
+  .
 build-type:         Simple
 stability:          highly unstable
 cabal-version:      >= 1.2
@@ -63,59 +85,76 @@
   LICENSE,
   demo/ArrowCircuit.hs,
   demo/Arrowheads.hs,
+  demo/Automata.hs,
   demo/ClipPic.hs,
   demo/ColourCharts.hs,
   demo/ColourChartUtils.hs,
   demo/Connectors.hs
   demo/DotPic.hs,
   demo/FeatureModel.hs,
-  demo/FontLoaderUtils.hs,
   demo/FontPic.hs,
   demo/LeftRightText.hs,
   demo/PetriNet.hs,
-  demo/PictureCompo.hs,
-  demo/Symbols.hs,
-  demo/TableChains.hs
+  demo/SingleChar.hs,
+  demo/SingleLine.hs,
+  demo/SampleShapes.hs,
+  demo/Symbols.hs
 
 library
   hs-source-dirs:     src
   build-depends:      base            <  5, 
                       containers      >= 0.3     && <= 0.6,
-                      directory       >= 1.0     && <  2.0, 
-                      filepath        >= 1.1     && <  2.0,
                       vector-space    >= 0.6     && <  1.0,
-                      wumpus-core     >= 0.42.0  && <  0.43.0,
-                      wumpus-basic    == 0.15.0
+                      wumpus-core     >= 0.52.0  && <  0.53.0,
+                      wumpus-basic    == 0.24.0
 
   
   exposed-modules:
-    Wumpus.Drawing.Arrows,
-    Wumpus.Drawing.Arrows.Connectors,
-    Wumpus.Drawing.Arrows.Tips,
-    Wumpus.Drawing.Chains,
-    Wumpus.Drawing.Chains.Base,
-    Wumpus.Drawing.Chains.Derived,
+    Wumpus.Drawing.Basis.BezierCurve,
+    Wumpus.Drawing.Basis.DrawingPrimitives,
+    Wumpus.Drawing.Basis.Geometry,
+    Wumpus.Drawing.Basis.InclineTrails,
+    Wumpus.Drawing.Basis.ShapeTrails,
+    Wumpus.Drawing.Basis.Symbols,
     Wumpus.Drawing.Colour.SVGColours,
     Wumpus.Drawing.Colour.X11Colours,
+    Wumpus.Drawing.Connectors,
+    Wumpus.Drawing.Connectors.Arrowheads,
+    Wumpus.Drawing.Connectors.Base,
+    Wumpus.Drawing.Connectors.BoxConnectors,
+    Wumpus.Drawing.Connectors.ConnectorPaths,
+    Wumpus.Drawing.Connectors.ConnectorProps,
     Wumpus.Drawing.Dots.AnchorDots,
-    Wumpus.Drawing.Dots.Marks,
-    Wumpus.Drawing.Geometry.Intersection,
-    Wumpus.Drawing.Geometry.Paths,
+    Wumpus.Drawing.Dots.SimpleDots,
+    Wumpus.Drawing.Extras.Axes,
+    Wumpus.Drawing.Extras.Clip,
+    Wumpus.Drawing.Extras.Grids,
+    Wumpus.Drawing.Extras.Loop,
     Wumpus.Drawing.Paths,
     Wumpus.Drawing.Paths.Base,
-    Wumpus.Drawing.Paths.Connectors,
-    Wumpus.Drawing.Paths.MonadicConstruction,
-    Wumpus.Drawing.Paths.ControlPoints,
+    Wumpus.Drawing.Paths.Illustrate,
+    Wumpus.Drawing.Paths.Intersection,
+    Wumpus.Drawing.Paths.PathBuilder,
+    Wumpus.Drawing.Paths.Vamps,
     Wumpus.Drawing.Shapes,
     Wumpus.Drawing.Shapes.Base,
     Wumpus.Drawing.Shapes.Circle,
     Wumpus.Drawing.Shapes.Diamond,
     Wumpus.Drawing.Shapes.Ellipse,
+    Wumpus.Drawing.Shapes.InvSemicircle,
+    Wumpus.Drawing.Shapes.InvSemiellipse,
+    Wumpus.Drawing.Shapes.InvTriangle,
+    Wumpus.Drawing.Shapes.Parallelogram,
     Wumpus.Drawing.Shapes.Rectangle,
-    Wumpus.Drawing.Text.LRText,
-    Wumpus.Drawing.Text.SafeFonts,
-    Wumpus.Drawing.Turtle.TurtleClass,
-    Wumpus.Drawing.Turtle.TurtleMonad,
+    Wumpus.Drawing.Shapes.Trapezium,
+    Wumpus.Drawing.Shapes.Semicircle,
+    Wumpus.Drawing.Shapes.Semiellipse,
+    Wumpus.Drawing.Shapes.Triangle,
+    Wumpus.Drawing.Text.Base.DocTextZero,
+    Wumpus.Drawing.Text.Base.Label,
+    Wumpus.Drawing.Text.DirectionZero,
+    Wumpus.Drawing.Text.DocSymbols,
+    Wumpus.Drawing.Text.StandardFontDefs,
     Wumpus.Drawing.VersionNumber
 
   other-modules: