diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,4 +1,16 @@
 
 0.1.0:
 
-  * Initial split from Wumpus-Basic.
+  * Initial release - this is a split from @Wumpus-Basic@ making 
+    the (very prototypical - read sub-alpha, unstable...) modules 
+    in the @Drawing@ hierarchy a separate package.
+
+  * Simplified Chains - chains are now regular lists (though often
+    infinite). Drawings are made with chains using new zip-like
+    functions.
+
+  * Re-worked Shapes.
+
+  * Re-worked Arrow and Arrow Tip types.
+
+  * Re-worked ConnectorPaths.
diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs
--- a/demo/ArrowCircuit.hs
+++ b/demo/ArrowCircuit.hs
@@ -8,17 +8,18 @@
 
 module ArrowCircuit where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
 import Wumpus.Drawing.Arrows
 import Wumpus.Drawing.Paths 
 import Wumpus.Drawing.Shapes
 import Wumpus.Drawing.Text.LRText
 import Wumpus.Drawing.Text.SafeFonts
 
-import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader.Afm
+import Wumpus.Basic.System.FontLoader.GhostScript
 
+import Wumpus.Core                              -- package: wumpus-core
+
 import FontLoaderUtils
 
 
@@ -70,7 +71,7 @@
          
 circuit_pic :: CtxPicture Double 
 circuit_pic = drawTracing $ do
-    a1 <- drawi $ (strokedShape $ rrectangle 12 66 30) `at` P2 0 72
+    a1 <- drawi $ rrectangle 12 66 30 `at` P2 0 72
     atext a1 "CONST 0"
     a2 <- drawi $ (strokedShape $ circle 16) `at` P2 120 60
     atext a2 "IF"
@@ -103,16 +104,19 @@
          , TraceM m, DrawingCtxM m, u ~ MonUnit m )
       => t -> String -> m ()
 atext ancr ss = let pt = center ancr in
-   drawi_ $ ctrCenterLine ss `at` pt
+   drawi_ $ textAlignCenter ss `at` pt
 
 
 ptext :: ( Real u, Floating u, FromPtSize u
          , TraceM m, DrawingCtxM m, u ~ MonUnit m )
       => Point2 u -> String -> m ()
 ptext pt ss = localize (fontAttr times_italic 14) $ 
-    drawi_ $ ctrCenterLine ss `at` pt
+    drawi_ $ textAlignCenter ss `at` pt
 
 
+-- Note - return type is a LocImage not a shape...
+--
 rrectangle :: (Real u, Floating u, FromPtSize u) 
-           => u -> u -> u -> LocShape u (Rectangle u)
-rrectangle r w h = localize (roundCornerFactor $ realToFrac r) (rectangle w h)
+           => u -> u -> u -> LocImage u (Rectangle u)
+rrectangle r w h = 
+    localize (roundCornerFactor $ realToFrac r) $ strokedShape (rectangle w h)
diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs
--- a/demo/Arrowheads.hs
+++ b/demo/Arrowheads.hs
@@ -3,12 +3,13 @@
 module Arrowheads where
 
 
-import Wumpus.Basic.Kernel
 import Wumpus.Drawing.Arrows
 import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
 import Wumpus.Drawing.Paths hiding ( length )
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
 
 import Data.AffineSpace                         -- package: vector-space
@@ -60,10 +61,11 @@
 
 tableGraphic :: (Real u, Floating u, FromPtSize u) 
              => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u ()
-tableGraphic tips = zipchainWith makeArrowDrawing tips ps
+tableGraphic tips = 
+    draw $ unchainZipWith emptyLocGraphic makeArrowDrawing tips chn `at` start
   where
-    ps = tableDown 20 (120,24) (P2 0 480)
-
+    chn   = tableDown 20 (120,24)
+    start = P2 0 480
 
  
 std_ctx :: DrawingContext
diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs
--- a/demo/ClipPic.hs
+++ b/demo/ClipPic.hs
@@ -12,12 +12,14 @@
 
 module ClipPic where
 
-import Wumpus.Basic.Kernel
 import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
 import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Paths.MonadicConstruction
 import Wumpus.Drawing.Text.SafeFonts
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
 
 import Data.AffineSpace                         -- package: vector-space
@@ -38,25 +40,24 @@
 
 
 big_pic :: DCtxPicture
-big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4]
+big_pic = pic1 `cxpDown` oconcat cpic1 [cpic2, cpic3, cpic4]
 
 fillPath :: Num u => Path u -> Graphic u
 fillPath = filledPath . toPrimPath
 
 pic1 :: DCtxPicture
-pic1 = drawTracing $
-         localize (fillColour medium_slate_blue) $ do
-            draw $ fillPath path01
-            localize (fillColour powder_blue) $ 
-                     draw $ fillPath path02
-            draw $ fillPath path03
-            draw $ fillPath path04
+pic1 = drawTracing $ localize (fillColour medium_slate_blue) $ do
+    draw $ fillPath path01
+    draw $ localize (fillColour powder_blue) $ fillPath path02
+    draw $ fillPath path03
+    draw $ fillPath path04
 
 
 background :: RGBi -> DCtxPicture
 background rgb = drawTracing $ 
-    localize (strokeColour rgb) $ 
-        unchain 112 iheartHaskell $ tableDown 18 (86,16) (P2 0 288)
+    draw $ localize (strokeColour rgb) $ ihh `at` P2 0 288
+  where
+    ihh = unchain 112 emptyLocGraphic iheartHaskell $ tableDown 18 (86,16)
 
 cpic1 :: DCtxPicture 
 cpic1 = clipCtxPicture (toPrimPath path01) (background black)
diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs
--- a/demo/ColourCharts.hs
+++ b/demo/ColourCharts.hs
@@ -4,9 +4,10 @@
 
 import ColourChartUtils
 
-import Wumpus.Basic.Kernel
 import Wumpus.Drawing.Chains
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
 
 import System.Directory
@@ -42,11 +43,12 @@
 
 tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double ()
 tableGraphic row_count xs = 
-    zipchainWith (\(name,rgb) -> colourSample name rgb) xs ps
+    draw $ unchainZip emptyLocGraphic gs chn `at` pt
   where
-    ps = tableDown row_count (152,11) pt
-    pt = displaceV (fromIntegral $ 11 * row_count) zeroPt 
-
+    chn  = tableDown row_count (152,11)
+    pt   = displaceV (fromIntegral $ 11 * row_count) zeroPt 
+    gs   = map (uncurry colourSample) xs
+   
 
 colourSample :: String -> RGBi -> LocGraphic Double
 colourSample name rgb = localize (fillColour rgb) $ 
diff --git a/demo/Connectors.hs b/demo/Connectors.hs
--- a/demo/Connectors.hs
+++ b/demo/Connectors.hs
@@ -3,12 +3,13 @@
 module Connectors where
 
 
-import Wumpus.Basic.Kernel
 import Wumpus.Drawing.Arrows
 import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
 import Wumpus.Drawing.Paths hiding ( length )
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
 
 import System.Directory
@@ -50,10 +51,11 @@
 
 tableGraphic :: (Real u, Floating u, FromPtSize u) 
              => [ConnectorPath u] -> TraceDrawing u ()
-tableGraphic conns = zipchainWith makeConnDrawing conns ps
+tableGraphic conns = 
+    draw $ unchainZipWith emptyLocGraphic makeConnDrawing conns chn `at` start
   where
-    ps = tableDown 10 (120,52) (displaceV 520 zeroPt)
-
+    chn   = tableDown 10 (120,52) 
+    start = P2 0 520 
 
  
 std_ctx :: DrawingContext
diff --git a/demo/DotPic.hs b/demo/DotPic.hs
--- a/demo/DotPic.hs
+++ b/demo/DotPic.hs
@@ -3,9 +3,7 @@
 module DotPic where
 
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
+
 import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
 import Wumpus.Drawing.Dots.AnchorDots
@@ -13,6 +11,10 @@
 
 import FontLoaderUtils
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader.Afm
+import Wumpus.Basic.System.FontLoader.GhostScript
+
 import Wumpus.Core                              -- package: wumpus-core
 
 import Data.AffineSpace                         -- package: vector-space
@@ -82,10 +84,11 @@
 
 tableGraphic :: (Real u, Floating u, FromPtSize u) 
              => [DotLocImage u] -> TraceDrawing u ()
-tableGraphic imgs = zipchainWith makeDotDrawing imgs ps
+tableGraphic imgs = 
+    draw $ unchainZipWith emptyLocGraphic makeDotDrawing imgs chn `at` pt
   where
     row_count   = length imgs
-    ps          = tableDown row_count (1,36) pt
+    chn         = tableDown row_count (1,36)
     pt          = displaceV (fromIntegral $ 36 * row_count) zeroPt 
 
 
diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs
--- a/demo/FeatureModel.hs
+++ b/demo/FeatureModel.hs
@@ -5,17 +5,18 @@
 
 module FeatureModel where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
 import Wumpus.Drawing.Arrows
 import Wumpus.Drawing.Paths 
 import Wumpus.Drawing.Shapes
 import Wumpus.Drawing.Text.LRText
 import Wumpus.Drawing.Text.SafeFonts
 
-import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader.Afm
+import Wumpus.Basic.System.FontLoader.GhostScript
 
+import Wumpus.Core                              -- package: wumpus-core
+
 import FontLoaderUtils
 
 
@@ -26,7 +27,6 @@
 main = do 
     (mb_gs, mb_afm) <- processCmdLine default_font_loader_help
     createDirectoryIfMissing True "./out/"
-    putStrLn "Note - text centering does not seem to be working well at present..."
     maybe gs_failk  makeGSPicture  $ mb_gs
     maybe afm_failk makeAfmPicture $ mb_afm
   where
@@ -95,7 +95,7 @@
         => u -> String -> Point2 u -> TraceDrawing u (Box u)
 makeBox w ss pt = do 
     a <- drawi $ (strokedShape $ rectangle w 20) `at` pt
-    drawi_ $ ctrCenterLine ss `at` center a
+    drawi_ $ textAlignCenter ss `at` center a
     -- draw  $ filledDisk 2 `at` center a
     return a
 
@@ -113,7 +113,7 @@
 connWith arrh b0 b1 = do
    lw <- getLineWidth
    let p0 = south b0
-   let p1 = northwards (realToFrac lw) b1
+   let p1 = projectAnchor north (realToFrac lw) b1
    drawi $ apply2R2 (rightArrow arrh connLine) p0 p1
 
 infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_`
diff --git a/demo/FontPic.hs b/demo/FontPic.hs
--- a/demo/FontPic.hs
+++ b/demo/FontPic.hs
@@ -2,12 +2,13 @@
 
 module FontPic where
 
-import Wumpus.Basic.Kernel
 import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours ( steel_blue )
 import Wumpus.Drawing.Colour.X11Colours ( indian_red1 )
 import Wumpus.Drawing.Text.SafeFonts
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
 import Wumpus.Core                              -- package: wumpus-core
 
 
@@ -56,23 +57,26 @@
 
 
 pointChain :: LocChain Double
-pointChain = verticals $ map (fromIntegral . (+2)) point_sizes
+pointChain = verticalSteps $ map (fromIntegral . (+2)) point_sizes
 
-fontGraphic :: RGBi -> FontFace -> DPoint2 -> TraceDrawing Double ()
-fontGraphic rgb ff pt = 
-    let ps = pointChain pt in 
-      zipchainWith (\sz -> makeLabel rgb ff sz) point_sizes ps
 
+fontGraphic :: RGBi -> FontFace -> DLocGraphic 
+fontGraphic rgb ff = 
+    unchainZipWith emptyLocGraphic mkGF point_sizes pointChain 
+  where
+    mkGF sz = makeLabel rgb ff sz
 
+
 std_ctx :: DrawingContext
 std_ctx = standardContext 10
 
 
 fontDrawing :: [(RGBi,FontFace)] -> DCtxPicture
 fontDrawing xs = drawTracing $  
-    zipchainWithTD (\(rgb,ff) -> fontGraphic rgb ff) xs ps
+    draw $ unchainZipWith emptyLocGraphic (uncurry fontGraphic) xs chn `at` start
   where
-    ps = tableDown 4 (1,180) (P2 0 (4*180))
+    chn   = tableDown 4 (1,180)
+    start = P2 0 (4*180)
 
 
 
diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs
--- a/demo/LeftRightText.hs
+++ b/demo/LeftRightText.hs
@@ -15,19 +15,19 @@
 
 module LeftRightText where
 
+import FontLoaderUtils
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
 import Wumpus.Drawing.Colour.SVGColours
 import Wumpus.Drawing.Dots.Marks
 import Wumpus.Drawing.Text.LRText
 import Wumpus.Drawing.Text.SafeFonts
 
-import FontLoaderUtils
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader.Afm
+import Wumpus.Basic.System.FontLoader.GhostScript
 
-import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Core                              -- package: wumpus-core
 
 import System.Directory
 
@@ -66,43 +66,44 @@
 
 
 makeCtx :: GlyphMetrics -> DrawingContext
-makeCtx = fontFace helvetica . metricsContext 18
+makeCtx = fontFace helvetica . metricsContext 14
 
 
 text_pic :: CtxPicture Double
 text_pic = drawTracing $ do 
     drawi_ $ (fn left_text)       `at` P2   0 400
-    drawi_ $ (fn center_text)     `at` P2 200 400
-    drawi_ $ (fn right_text)      `at` P2 400 400
+    drawi_ $ (fn center_text)     `at` P2 150 400
+    drawi_ $ (fn right_text)      `at` P2 300 400
     drawi_ $ (fn blank_text)      `at` P2   0 300
-    drawi_ $ (fn bl_oneline)      `at` P2 200 300
-    drawi_ $ (fn cc_oneline)      `at` P2 400 300
-    drawi_ $ (fn newblr)          `at` P2   0 200
-    drawi_ $ (fn newblc)          `at` P2 200 200
-    drawi_ $ (fn newbll)          `at` P2 400 200
-    drawi_ $ (fn rnewblr)         `at` P2   0 100
-    drawi_ $ (fn rnewblc)         `at` P2 200 100
-    drawi_ $ (fn rnewbll)         `at` P2 400 100
+    drawi_ $ (fn ne_oneline)      `at` P2 150 300 
+    drawi_ $ (fn cc_oneline)      `at` P2 300 300
+
+
+    drawi_ $ (fn sw_oneline)      `at` P2   0 200
+    drawi_ $ (fn ss_oneline)      `at` P2 150 200
+    drawi_ $ (fn se_oneline)      `at` P2 300 200
+    drawi_ $ (fn swr_multi)       `at` P2   0 100
+    drawi_ $ (fn ssr_multi)       `at` P2 150 100
+    drawi_ $ (fn ner_multi)       `at` P2 300 100
     drawi_ $ (fn rleft_text)      `at` P2   0 (-75)
-    drawi_ $ (fn rcenter_text)    `at` P2 200 (-75)
-    drawi_ $ (fn rright_text)     `at` P2 400 (-75)
-      
- 
+    drawi_ $ (fn rcenter_text)    `at` P2 150 (-75)
+    drawi_ $ (fn rright_text)     `at` P2 300 (-75)
+
     draw $ redPlus            `at` P2   0 400
-    draw $ redPlus            `at` P2 200 400
-    draw $ redPlus            `at` P2 400 400
+    draw $ redPlus            `at` P2 150 400
+    draw $ redPlus            `at` P2 300 400
     draw $ redPlus            `at` P2   0 300  
-    draw $ redPlus            `at` P2 200 300 
-    draw $ redPlus            `at` P2 400 300 
+    draw $ redPlus            `at` P2 150 300 
+    draw $ redPlus            `at` P2 300 300 
     draw $ redPlus            `at` P2   0 200  
-    draw $ redPlus            `at` P2 200 200 
-    draw $ redPlus            `at` P2 400 200  
+    draw $ redPlus            `at` P2 150 200 
+    draw $ redPlus            `at` P2 300 200  
     draw $ redPlus            `at` P2   0 100  
-    draw $ redPlus            `at` P2 200 100 
-    draw $ redPlus            `at` P2 400 100 
+    draw $ redPlus            `at` P2 150 100 
+    draw $ redPlus            `at` P2 300 100 
     draw $ redPlus            `at` P2   0 (-75)
-    draw $ redPlus            `at` P2 200 (-75)
-    draw $ redPlus            `at` P2 400 (-75)
+    draw $ redPlus            `at` P2 150 (-75)
+    draw $ redPlus            `at` P2 300 (-75)
       
   where
     fn = illustrateBoundedLocGraphic
@@ -111,81 +112,73 @@
 redPlus = localize (strokeColour red) markPlus
 
 
-newblc :: BoundedLocGraphic Double
-newblc = 
-    localize (strokeColour dark_slate_gray) $ 
-        baseCenterLine "new baseline center"
 
-newbll :: BoundedLocGraphic Double
-newbll = 
-    localize (strokeColour dark_slate_gray) $ 
-        baseLeftLine "new baseline left"
+-- single line
+--
+ne_oneline :: BoundedLocGraphic Double
+ne_oneline = singleLine "north east" `startPos` NE
 
-newblr :: BoundedLocGraphic Double
-newblr = 
-    localize (strokeColour dark_slate_gray) $ 
-        baseRightLine "new baseline right"
 
+-- single line
+--
+se_oneline :: BoundedLocGraphic Double
+se_oneline = singleLine "south east" `startPos` SE
 
-rnewblc :: BoundedLocGraphic Double
-rnewblc = 
-    localize (strokeColour dark_slate_gray) $ 
-        rbaseCenterLine "baseline center" `rot` (0.25*pi)
+-- single line
+--
+ss_oneline :: BoundedLocGraphic Double
+ss_oneline = singleLine "south" `startPos` SS
 
-rnewbll :: BoundedLocGraphic Double
-rnewbll = 
-    localize (strokeColour dark_slate_gray) $ 
-        rbaseLeftLine "baseline left" `rot` (0.25*pi)
+-- single line
+--
+sw_oneline :: BoundedLocGraphic Double
+sw_oneline = singleLine "south west" `startPos` SW
 
-rnewblr :: BoundedLocGraphic Double
-rnewblr = 
-    localize (strokeColour dark_slate_gray) $ 
-        rbaseRightLine "baseline right" `rot` (0.25 * pi)
 
+-- multi line
+--
+ssr_multi :: BoundedLocGraphic Double
+ssr_multi = multiAlignCenter (0.25*pi) "south rot45" `startPos` SS
 
-bl_oneline :: BoundedLocGraphic Double
-bl_oneline = 
-    localize (strokeColour dark_slate_gray) $ baseLeftLine "Baseline-left..."
+-- multi line
+--
+swr_multi :: BoundedLocGraphic Double
+swr_multi = multiAlignCenter (0.25*pi) "south west rot45" `startPos` SW
 
+-- multi line
+--
+ner_multi :: BoundedLocGraphic Double
+ner_multi = multiAlignCenter (0.25*pi) "north east rot45" `startPos` NE
 
+
 cc_oneline :: BoundedLocGraphic Double
-cc_oneline = 
-    localize (strokeColour dark_slate_gray) $ ctrCenterLine "Center-center..."
+cc_oneline = rsingleLine 0 "Center-center..."  `startPos` CENTER
 
+
 blank_text :: BoundedLocGraphic Double
-blank_text = 
-    localize (strokeColour dark_slate_gray) $ multiAlignCenter ""
+blank_text = multiAlignCenter 0 "" `startPos` CENTER
 
 
 left_text :: BoundedLocGraphic Double
-left_text = 
-    localize (strokeColour dark_slate_gray) $ multiAlignLeft dummy_text
+left_text = multiAlignLeft 0 dummy_text `startPos` CENTER
 
 
 right_text :: BoundedLocGraphic Double
-right_text = 
-    localize (strokeColour dark_slate_gray) $ multiAlignRight dummy_text
+right_text = multiAlignRight 0 dummy_text `startPos` CENTER
 
 center_text :: BoundedLocGraphic Double
-center_text = 
-    localize (strokeColour dark_slate_gray) $ multiAlignCenter dummy_text
+center_text = multiAlignCenter 0 dummy_text `startPos` CENTER
 
 
 rleft_text :: BoundedLocGraphic Double
-rleft_text = 
-    localize (strokeColour dark_slate_gray) $ 
-        rmultiAlignLeft dummy_text `rot`   (0.25*pi)
+rleft_text = multiAlignLeft (0.25*pi)  dummy_text `startPos` CENTER
 
 
 rright_text :: BoundedLocGraphic Double
-rright_text = 
-    localize (strokeColour dark_slate_gray) $ 
-        rmultiAlignRight dummy_text `rot`  (0.25*pi)
+rright_text = multiAlignRight (0.25*pi) dummy_text `startPos` CENTER
 
 rcenter_text :: BoundedLocGraphic Double
-rcenter_text = 
-    localize (strokeColour dark_slate_gray) $ 
-        rmultiAlignCenter dummy_text `rot` (0.25*pi)
+rcenter_text = multiAlignCenter (0.25*pi) dummy_text `startPos` CENTER
 
 
 dummy_text :: String 
diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs
--- a/demo/PetriNet.hs
+++ b/demo/PetriNet.hs
@@ -7,9 +7,6 @@
 
 module PetriNet where
 
-import Wumpus.Basic.Kernel
-import Wumpus.Basic.System.FontLoader.Afm
-import Wumpus.Basic.System.FontLoader.GhostScript
 import Wumpus.Drawing.Arrows
 import Wumpus.Drawing.Colour.SVGColours
 import Wumpus.Drawing.Paths
@@ -19,6 +16,10 @@
 
 import FontLoaderUtils
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader.Afm
+import Wumpus.Basic.System.FontLoader.GhostScript
+
 import Wumpus.Core                              -- package: wumpus-core
 
 
@@ -96,19 +97,20 @@
     draw $ lblParensParens `at` (P2 (-36) 150)
     draw $ lblParensParens `at` (P2 300 60)
     draw $ lblParensParensParens `at` (P2 (-52) (-14))
-    draw $ lblBold "processing_w"   `at` (southwards 12 pw)
-    draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)
-    draw $ lblBold "writing"        `at` (southwards 12 w)
+    draw $ lblBold "processing_w"   `at` (projectAnchor south 12 pw)
+    draw $ lblBold "ready_to_write" `at` (projectAnchor south 12 rtw)
+    draw $ lblBold "writing"        `at` (projectAnchor south 12 w)
     draw $ lblBold' "resource"      `at` (P2 300 72)
-    draw $ lblBold "processing_r"   `at` (northwards 12 pr)
-    draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)
-    draw $ lblBold "reading"        `at` (northwards 12 r)
+    draw $ lblBold "processing_r"   `at` (projectAnchor north 12 pr)
+    draw $ lblBold "ready_to_read"  `at` (projectAnchor north 12 rtr)
+    draw $ lblBold "reading"        `at` (projectAnchor north 12 r)
     return ()
 
 greenFill :: DrawingCtxM m => m a -> m a
 greenFill = localize (fillColour lime_green)
 
-place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) 
+place :: ( Real u, Floating u, FromPtSize u
+         , DrawingCtxM m, TraceM m, u ~ MonUnit m ) 
       => u -> u -> m (Circle u)
 place x y = greenFill $ drawi $ (borderedShape $ circle 14) `at` P2 x y
 
@@ -153,6 +155,6 @@
 
 
 lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u
-lblBold ss = localize (fontFace helvetica_bold) $ post $ ctrCenterLine ss
-  where
-    post = fmap (replaceL uNil)
+lblBold ss = localize (fontFace helvetica_bold) $ 
+                ignoreAns $ textAlignCenter ss
+
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,206 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+
+module SampleShapes where
+
+
+import FontLoaderUtils
+
+import Wumpus.Drawing.Colour.SVGColours
+import Wumpus.Drawing.Dots.Marks
+import Wumpus.Drawing.Shapes
+import Wumpus.Drawing.Text.LRText
+import Wumpus.Drawing.Text.SafeFonts
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader.Afm
+import Wumpus.Basic.System.FontLoader.GhostScript
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Monad
+import System.Directory
+
+
+main :: IO ()
+main = do 
+    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help
+    createDirectoryIfMissing True "./out/shapes/"
+    maybe gs_failk  (makeGSPicture shape_list)  $ mb_gs
+    maybe afm_failk (makeAfmPicture shape_list) $ mb_afm
+  where
+    gs_failk  = putStrLn "No GhostScript font path supplied..."
+    afm_failk = putStrLn "No AFM v4.1 font path supplied..."
+
+
+makeGSPicture :: ShapeList -> FilePath -> IO ()
+makeGSPicture shapes font_dir = do
+    putStrLn "Using GhostScript metrics..."
+    (gs_metrics, msgs) <- loadGSMetrics font_dir ["Courier"]
+    mapM_ putStrLn msgs
+    mapM_ (out1 gs_metrics) shapes 
+  where
+    out1 gs_metrics (name, shape_pic) = do 
+       let pic1 = runCtxPictureU (makeCtx gs_metrics) $ shape_pic name
+       writeEPS ("./out/shapes/" ++ name ++ "01.eps") pic1
+       writeSVG ("./out/shapes/" ++ name ++ "01.svg") pic1
+
+
+makeAfmPicture :: ShapeList -> FilePath -> IO ()
+makeAfmPicture shapes font_dir = do
+    putStrLn "Using AFM 4.1 metrics..."
+    (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Courier"]
+    mapM_ putStrLn msgs
+    mapM_ (out1 afm_metrics) shapes 
+  where
+    out1 afm_metrics (name, shape_pic) = do 
+        let pic1 = runCtxPictureU (makeCtx afm_metrics) $ shape_pic name
+        writeEPS ("./out/shapes/" ++ name ++ "02.eps") pic1
+        writeSVG ("./out/shapes/" ++ name ++ "02.svg") pic1
+
+type ShapeList = [(String, (String -> DCtxPicture))]
+
+
+shape_list :: ShapeList
+shape_list = 
+    [ ( "circle"
+      , shapePic voidExtra $ circle 150)
+    , ( "diamond"
+      ,  shapePic (apexAnchor >=> midPoints 4) $ diamond 150 100)
+    , ( "ellipse"
+      , shapePic voidExtra $ ellipse 150 100)
+    , ( "invsemicircle"
+      , shapePic (apexAnchor >=> topCorners) $ invsemicircle 150)
+    , ( "invsemiellipse"
+      , shapePic (apexAnchor >=> topCorners) $ invsemiellipse 100 150)
+    , ( "invtriangle"
+      , shapePic (apexAnchor >=> topCorners >=> midPoints 3) $ 
+          invtriangle 300 150)
+    , ( "parallelogram"
+      , shapePic (topCorners >=> bottomCorners >=> midPoints 4) $ 
+          zparallelogram 250 200)
+    , ( "rectangle"
+      , shapePic (topCorners >=> bottomCorners >=> midPoints 4) $ 
+          rectangle 300 175)
+    , ( "semicircle"
+      , shapePic (apexAnchor >=> bottomCorners) $ semicircle 150) 
+    , ( "semiellipse"
+      , shapePic (apexAnchor >=> bottomCorners) $ semiellipse 100 150) 
+    , ( "trapezium"
+      ,  shapePic (bottomCorners >=> topCorners >=> midPoints 4) $ 
+          ztrapezium 300 150)
+    , ( "triangle"
+      , shapePic (apexAnchor >=> bottomCorners >=> midPoints 3) $ 
+          triangle 300 150 )
+    ]
+
+makeCtx :: GlyphMetrics -> DrawingContext
+makeCtx = fontFace courier . metricsContext 16
+
+rotate05 :: Rotate a => a -> a
+rotate05 = rotate (d2r (5::Double))
+
+-- Extra elaboration...
+
+voidExtra :: a -> TraceDrawing u ()
+voidExtra _ = return ()
+
+apexAnchor :: ( Real u, Floating u, FromPtSize u
+            , ApexAnchor a
+            , u ~ DUnit a )
+            => a -> TraceDrawing u a
+apexAnchor a = do
+    draw $ label EAST   "(apex)"    `at` apex  a
+    return a
+
+bottomCorners :: ( Real u, Floating u, FromPtSize u
+               , BottomCornerAnchor a
+               , u ~ DUnit a )
+            => a -> TraceDrawing u a
+bottomCorners a = do
+    draw $ label SOUTH_WEST   "(bottom left)"    `at` bottomLeftCorner  a
+    draw $ label SOUTH_EAST   "(bottom right)"   `at` bottomRightCorner a
+    return a
+
+topCorners :: ( Real u, Floating u, FromPtSize u
+              , TopCornerAnchor a
+              , u ~ DUnit a )
+           => a -> TraceDrawing u a
+topCorners a = do
+    draw $ label NORTH_WEST   "(top left)"    `at` topLeftCorner  a
+    draw $ label NORTH_EAST   "(top right)"   `at` topRightCorner a
+    return a
+
+
+midPoints :: ( Real u, Floating u, FromPtSize u
+             , SideMidpointAnchor a
+             , u ~ DUnit a )
+          => Int -> a -> TraceDrawing u a
+midPoints n a = mapM_ mf [1..n] >> return a
+  where
+    mf i = let msg = "(side midpt " ++ show i ++ ")"
+           in draw $ label EAST  msg    `at` sideMidpoint i  a
+
+
+
+
+shapePic :: ( CenterAnchor a, CardinalAnchor a, CardinalAnchor2 a
+            , RadialAnchor a
+            , Scale a, Rotate a
+            , DUnit a ~ Double) 
+         => (a -> DTraceDrawing b) -> DShape a -> String -> DCtxPicture
+shapePic mf sh name = drawTracing $ do
+    a1  <- localize shapeSty $ drawi $ 
+              uniformScale 2 $ rotate05 $ shape `at` (P2 100 0)
+    draw $ label NORTH        "(center)"      `at` center a1
+    draw $ label NORTH        "(north)"       `at` north a1
+    draw $ label SOUTH        "(south)"       `at` south a1
+    draw $ label EAST         "(east)"        `at` east a1
+    draw $ label WEST         "(west)"        `at` west a1
+    draw $ label NORTH_EAST   "(northeast)"   `at` northeast a1
+    draw $ label NORTH_WEST   "(northwest)"   `at` northwest a1
+    draw $ label SOUTH_EAST   "(southeast)"   `at` southeast a1
+    draw $ label SOUTH_WEST   "(southwest)"   `at` southwest a1
+    draw $ label EAST         "(10 deg)"      `at` radialAnchor deg10 a1
+    draw $ label NORTH_WEST   "(110 deg)"     `at` radialAnchor deg110 a1
+    draw $ label WEST         "(190 deg)"     `at` radialAnchor deg190 a1
+    draw $ label NORTH        "(250 deg)"     `at` radialAnchor deg250 a1
+    _ <- mf a1
+    return ()    
+  where
+    shape   = strokedShape $ setDecoration textF sh
+    textF   = lift1R2 $ ignoreAns (multiAlignCenter 0 name `startPos` CENTER)
+
+    deg10   = d2r (10::Double)
+    deg110  = d2r (110::Double)
+    deg190  = d2r (190::Double)
+    deg250  = d2r (250::Double)
+
+
+
+
+
+
+shapeSty :: DrawingContextF
+shapeSty = strokeColour light_steel_blue . ultrathick
+
+label :: (Real u, Floating u, FromPtSize u) 
+           => Cardinal -> String -> LocGraphic u
+label cpos ss = markX `oplus` msg
+  where
+    (rpos,fn)     = go cpos
+    msg           = ignoreAns $ moveStart (fn 10) $ 
+                       multiAlignCenter 0 ss `startPos` rpos
+
+    go NORTH      = (SS, northwards)
+    go NORTH_EAST = (SW, northeastwards)
+    go EAST       = (WW, eastwards) 
+    go SOUTH_EAST = (NW, southeastwards)
+    go SOUTH      = (NN, southwards)
+    go SOUTH_WEST = (NE, southwestwards)
+    go WEST       = (EE, westwards)
+    go NORTH_WEST = (SE, northwestwards)
+  
+
diff --git a/demo/SingleLine.hs b/demo/SingleLine.hs
new file mode 100644
--- /dev/null
+++ b/demo/SingleLine.hs
@@ -0,0 +1,80 @@
+{-# OPTIONS -Wall #-}
+
+
+module SingleLine where
+
+import FontLoaderUtils
+
+import Wumpus.Drawing.Colour.SVGColours
+import Wumpus.Drawing.Text.LRText
+import Wumpus.Drawing.Text.SafeFonts
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.System.FontLoader.Afm
+import Wumpus.Basic.System.FontLoader.GhostScript
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import System.Directory
+
+
+main :: IO ()
+main = do 
+    (mb_gs, mb_afm) <- processCmdLine default_font_loader_help
+    createDirectoryIfMissing True "./out/"
+    maybe gs_failk  makeGSPicture  $ mb_gs
+    maybe afm_failk makeAfmPicture $ mb_afm
+  where
+    gs_failk  = putStrLn "No GhostScript font path supplied..."
+    afm_failk = putStrLn "No AFM v4.1 font path supplied..."
+
+
+makeGSPicture :: FilePath -> IO ()
+makeGSPicture font_dir = do
+    putStrLn "Using GhostScript metrics..."
+    (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"]
+    mapM_ putStrLn msgs
+    let pic1 = runCtxPictureU (makeCtx gs_metrics) drawing01
+    writeEPS "./out/single_line01.eps" pic1
+    writeSVG "./out/single_line01.svg" pic1
+
+makeAfmPicture :: FilePath -> IO ()
+makeAfmPicture font_dir = do
+    putStrLn "Using AFM 4.1 metrics..."
+    (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"]
+    mapM_ putStrLn msgs
+    let pic2 = runCtxPictureU (makeCtx afm_metrics) drawing01
+    writeEPS "./out/single_line02.eps" pic2
+    writeSVG "./out/single_line02.svg" pic2
+
+
+
+makeCtx :: GlyphMetrics -> DrawingContext
+makeCtx = fontFace helvetica . metricsContext 12
+
+
+
+drawing01 :: DCtxPicture
+drawing01 = drawTracing $ localize (fillColour red) $ mf 
+
+
+mf :: (Real u, Floating u, FromPtSize u) => TraceDrawing u ()
+mf = do
+    draw $ testDraw NN `at` (P2   0 200)
+    draw $ testDraw SS `at` (P2  75 200)
+    draw $ testDraw EE `at` (P2 150 200)
+    draw $ testDraw WW `at` (P2 225 200)
+    draw $ testDraw NE `at` (P2   0 100)
+    draw $ testDraw SE `at` (P2  75 100)
+    draw $ testDraw SW `at` (P2 150 100)
+    draw $ testDraw NW `at` (P2 225 100)
+    draw $ testDraw CENTER    `at` (P2   0 0)
+    
+
+testDraw :: (Real u, Floating u, FromPtSize u) => RectPosition -> LocGraphic u
+testDraw rpos = filledDisk 2 `oplus` (ignoreAns ans)
+  where
+    ans = singleLine "Qwerty" `startPos` rpos
+
+
+
diff --git a/demo/Symbols.hs b/demo/Symbols.hs
--- a/demo/Symbols.hs
+++ b/demo/Symbols.hs
@@ -2,11 +2,10 @@
 
 module Symbols where
 
-import Wumpus.Basic.Kernel
 import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Text.SafeFonts
 
-
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
 import Wumpus.Core                              -- package: wumpus-core
 
 import Prelude hiding ( pi, product )
@@ -32,12 +31,14 @@
 --
 symbols :: DCtxPicture
 symbols = drawTracing $ do
-    localize (fontFace symbol) $ zipchainWith sdraw all_letters ps
-    zipchainWith ldraw all_letters ps
+    draw $ localize (fontFace symbol) $ 
+            unchainZipWith emptyLocGraphic sdraw all_letters chn `at` start
+    draw $ unchainZipWith emptyLocGraphic ldraw all_letters chn `at` start
   where
-    ps              = tableDown 30 (100,20) (P2 0 (30*20))
+    chn             = tableDown 30 (100,20) 
+    start           = P2 0 (30*20)
     sdraw (s,_)     = textline s
-    ldraw (_,name)  = moveStartPoint (displaceH 16) (textline name)
+    ldraw (_,name)  = moveStart (displaceH 16) (textline name)
 
 
 all_letters :: [(String, String)]
diff --git a/demo/TableChains.hs b/demo/TableChains.hs
--- a/demo/TableChains.hs
+++ b/demo/TableChains.hs
@@ -3,15 +3,14 @@
 module TableChains where
 
 
-import Wumpus.Basic.Kernel
-import Wumpus.Drawing.Chains
 import Wumpus.Drawing.Colour.SVGColours
+import Wumpus.Drawing.Grids
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
 import Wumpus.Core                              -- package: wumpus-core
 
 import System.Directory
 
-
 main :: IO ()
 main = do 
     createDirectoryIfMissing True "./out/"
@@ -19,10 +18,16 @@
     writeEPS "./out/table_chains01.eps" pic1
     writeSVG "./out/table_chains01.svg" pic1
 
-table_drawing :: CtxPicture Double
-table_drawing = drawTracing $ tableGraphic
+std_ctx :: DrawingContext
+std_ctx = fillColour peru $ standardContext 18
 
+table_drawing :: CtxPicture Double
+table_drawing = drawTracing $ do 
+--    tableGraphic
+    draw $ connect (interiorGrid 10) (P2 (-20) (-20)) (P2 150 80)
+    draw $ grid (3,2) 20 `at` (P2 300 60)
 
+{-
 tableGraphic :: (Real u, Floating u, FromPtSize u) 
              => TraceDrawing u ()
 tableGraphic = do 
@@ -34,11 +39,12 @@
     downs   = tableDown  4 (36,24) dstart
     rights  = tableRight 5 (36,24) rstart
 
-    dstart  = P2 0   480
-    rstart  = P2 240 480
-
+    dstart  = P2 0   200   -- note grows down...
+    rstart  = P2 240 200   -- ditto
+-}
  
-std_ctx :: DrawingContext
-std_ctx = fillColour peru $ standardContext 18
+
+
+
 
 
diff --git a/src/Wumpus/Drawing/Chains/Base.hs b/src/Wumpus/Drawing/Chains/Base.hs
--- a/src/Wumpus/Drawing/Chains/Base.hs
+++ b/src/Wumpus/Drawing/Chains/Base.hs
@@ -3,7 +3,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Drawing.Chains.Base
--- Copyright   :  (c) Stephen Tetley 2010-2011
+-- Copyright   :  (c) Stephen Tetley 2011
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
@@ -12,25 +12,24 @@
 --
 -- Generate points in an iterated chain.
 --
--- \*\* WARNING \*\* - unstable. Names are not so good, also 
--- Wumpus-Basic has a @chain1@ operator...
---
 --------------------------------------------------------------------------------
 
 module Wumpus.Drawing.Chains.Base
   (
 
-    Chain
+    PointChain
   , LocChain
-  , unchain
-  , zipchain
-  , zipchainWith
-
-  , unchainTD
-  , zipchainTD
-  , zipchainWithTD
+  , ConnectorChain
 
+  -- * Unrolling chains
+  , unchain
+  , unchainU
+  , unchainZip
+  , unchainZipWith
+  , unconnectorChain
 
+  -- * Building chains
+  , liftChainF
 
   ) where
 
@@ -40,78 +39,221 @@
 
 
 
--- | A 'Chain' is a list of points. The list is often expected to 
--- be inifinte, but if it was a Stream  it would loose the ability
--- to use list comprehensions.
+-- | A 'PointChain' is a list of points. 
 -- 
-type Chain u = [Point2 u]
+-- The list is typically inifinte so some attention must be given 
+-- to choosing a chain drawing function and using it appropriately.
+-- 
+type PointChain u = [Point2 u]
 
 
--- | A LocChain is a function from a starting point to a 'Chain'.
+-- | A LocChain is a function from a starting point to a 
+-- 'PointChain'.
+--
+-- The list is often expected to be inifinte, but if it was a 
+-- Stream it would loose the ability to use list comprehensions.
 -- 
-type LocChain u = Point2 u -> Chain u
+type LocChain u = LocDrawingInfo u (PointChain u)
 
 
--- | Note - commonly a 'Chain' may be infinite, so it is only 
--- unrolled a finite number of times.
---
-unchain :: Int -> LocGraphic u -> Chain u -> TraceDrawing u ()
-unchain i op chn = go i chn
-  where
-    go n _      | n <= 0 = return ()
-    go _ []              = return () 
-    go n (x:xs)          = draw (op `at` x) >> go (n-1) xs
+-- | A ConnectorChain is a function from a start- and end-point 
+-- to a 'Chain'.
+-- 
+type ConnectorChain u = ConnectorCF u (PointChain u)
 
 
 
 
+-- | 'unchain' : @ unroll_count * alt_fun * draw_fun * chain -> LocCF @
+-- 
+-- Unroll the chain, applying the @draw_fun@ to each point 
+-- producing a LocCF (usually a 'LocGraphic'). If the chain does 
+-- not produce any points the @alt_fun@ is applied to the start 
+-- point.
+--
+-- Note - commonly a 'Chain' may be infinite, so it is only 
+-- unrolled a finite number of times - the @unrool_count@.
+--
+-- This function has a very general type signature commonly it 
+-- will be used at these types:
+--
+-- > unchain :: (Num u, OPlus a) => 
+-- >     Int -> LocImage u a -> LocImage u a -> LocChain u -> LocImage u a
+-- >
+-- > unchain :: Num u => 
+-- >     Int -> LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u
+--
+unchain :: (Num u, OPlus a) 
+        => Int 
+        -> LocCF u (ImageAns u a) 
+        -> LocCF u (ImageAns u a) 
+        -> LocChain u 
+        -> LocCF u (ImageAns u a)
+unchain i alt _  _   | i <= 0 = alt
+unchain i alt gf chn          = promoteR1 $ \p0 -> 
+    (chn `at` p0) >>= \pts -> case pts of 
+      []     -> alt `at` p0
+      [x]    -> gf  `at` x
+      (x:xs) -> go x (take (i-1) xs)
+  where
+    go x []     = gf `at` x
+    go x (y:ys) = (gf `at` x) `oplus` go y ys
 
 
-zipchain :: [LocGraphic u] -> Chain u -> TraceDrawing u ()
-zipchain (g:gs) (p:ps)   = draw (g `at` p) >> zipchain gs ps
-zipchain _      _        = return ()
 
 
-zipchainWith :: (a -> LocGraphic u) -> [a] -> Chain u -> TraceDrawing u ()
-zipchainWith op xs chn = go xs chn 
+-- | 'unchain' : @ alt_fun * draw_fun * chain -> LocCF @
+-- 
+-- /Unsafe/ version of 'unchain' - this function assumes the chain
+-- is finite which is not usually the case.
+--
+-- This function has a very general type signature commonly it 
+-- will be used at these type:
+--
+-- > unchainU :: (Num u, OPlus a) => 
+-- >     LocImage u a -> LocImage u a -> LocChain u -> LocImage u a
+-- >
+-- > unchainU :: Num u => 
+-- >     LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u
+--
+-- \*\* WARNING \*\* - if the chain is infinite this function will 
+-- not terminate.
+--
+unchainU :: (Num u, OPlus a)
+         => LocCF u (ImageAns u a) 
+         -> LocCF u (ImageAns u a) 
+         -> LocChain u 
+         -> LocCF u (ImageAns u a)
+unchainU alt gf chn = promoteR1 $ \p0 -> 
+    (chn `at` p0) >>= \pts -> case pts of 
+      []     -> alt `at` p0
+      [x]    -> gf  `at` x
+      (x:xs) -> go x xs
   where
-    go (a:as) (p:ps)   = draw (op a `at` p) >> go as ps
-    go _      _        = return ()
-
+    go x []     = gf `at` x
+    go x (y:ys) = (gf `at` x) `oplus` go y ys
 
 
--- | Variant of 'unchain' where the drawing argument is a 
--- @TraceDrawing@ not a @LocGraphic@. 
+-- | 'unchainZip' : @ alt_fun * [draw_fun] * chain -> LocCF @
+-- 
+-- Unroll the chain, zipping the list of @draw_funs@ to the list
+-- of points producing a LocCF (usually a 'LocGraphic'). If the 
+-- chain does not produce any points the @alt_fun@ is applied to 
+-- the start point.
 --
-unchainTD :: Int -> (Point2 u -> TraceDrawing u ()) -> Chain u -> TraceDrawing u ()
-unchainTD i op chn = go i chn
+-- This function has a very general type signature commonly it 
+-- will be used at these types:
+--
+-- > unchainZip :: (Num u, OPlus a) => 
+-- >     LocImage u a -> [LocImage u a] -> LocChain u -> LocImage u a
+-- >
+-- > unchainZip :: Num u => 
+-- >     LocGraphic u -> [LocGraphic u] -> LocChain u -> LocGraphic u
+--
+-- \*\* WARNING \*\* - the list of drawing functions should be 
+-- finite. If both the list of drawing functions and the chain are 
+-- infinite this function will not terminate.
+-- 
+unchainZip :: (Num u, OPlus a) 
+           => LocCF u (ImageAns u a) 
+           -> [LocCF u (ImageAns u a)] 
+           -> LocChain u 
+           -> LocCF u (ImageAns u a)
+unchainZip alt []     _   = promoteR1 $ \p0 -> alt `at` p0
+unchainZip alt  (g:gs) chn = promoteR1 $ \p0 -> 
+    (chn `at` p0) >>= \pts -> case pts of 
+      []     -> alt `at` p0
+      [x]    -> g `at` x
+      (x:xs) -> go (g `at` x) gs xs
   where
-    go n _      | n <= 0 = return ()
-    go _ []              = return () 
-    go n (x:xs)          = (op x) >> go (n-1) xs
+    go acc _      []     = acc
+    go acc []     _      = acc
+    go acc (f:fs) (p:ps) = go (acc `oplus` (f `at` p)) fs ps
 
 
-zipchainTD :: [Point2 u -> TraceDrawing u ()] -> Chain u -> TraceDrawing u ()
-zipchainTD (g:gs) (p:ps)   = g p >> zipchainTD gs ps
-zipchainTD _      _        = return ()
 
+-- | 'unchainZipWith' : @ alt_fun * (a -> draw_fun) * [a] * chain -> LocCF @
+-- 
+-- Version of 'unchainZip' where the list is some data rather 
+-- than a drawing function and the @(a -> draw_fun)@ builder is 
+-- applied to each element as part of the unrolling.
+-- 
+-- Approximately this function is a @zipWith@ to the @zip@ of 
+-- @unchainZip@.
+--
+-- This function has a very general type signature commonly it 
+-- will be used at these type:
+--
+-- > unchainZipWith :: (Num u, OPlus a) => 
+-- >     LocImage u a -> (s -> LocImage u a) -> [s] -> LocChain u -> LocImage u a
+-- >
+-- > unchainZipWith :: Num u => 
+-- >     LocGraphic u -> (s -> LocGraphic u) -> [s] -> LocChain u -> LocGraphic u
+--
+-- \*\* WARNING \*\* - if the chain and list are infinite this 
+-- function will not terminate.
+--
+unchainZipWith :: (Num u, OPlus a)
+                => LocCF u (ImageAns u a) 
+                -> (s -> LocCF u (ImageAns u a))
+                -> [s]
+                -> LocChain u 
+                -> LocCF u (ImageAns u a)
+unchainZipWith alt _    []     _   = promoteR1 $ \p0 -> alt `at` p0
+unchainZipWith alt mkGF (s:ss) chn = promoteR1 $ \p0 -> 
+    (chn `at` p0) >>= \pts -> case pts of 
+      []     -> alt `at` p0
+      [x]    -> mkGF s `at` x
+      (x:xs) -> go (mkGF s `at` x) ss xs
+  where
+    go acc _      []     = acc
+    go acc []     _      = acc
+    go acc (t:ts) (p:ps) = go (acc `oplus` (mkGF t `at` p)) ts ps
 
 
-zipchainWithTD :: (a -> Point2 u -> TraceDrawing u ()) -> [a] -> Chain u -> TraceDrawing u ()
-zipchainWithTD op xs chn = go xs chn 
+
+
+-- | 'unconnectorChain' : @ alt_fun * draw_fun * conn_chain -> ConnectorCF @
+--
+-- Unroll the chain produced between the implicit start and end 
+-- points. Apply the @draw_fun@ to each point producing a 
+-- ConnectorCF (usually a 'ConnectorGraphic'). If the chain does 
+-- not produce any points, the @alt_fun@ is applied to the start 
+-- and end points.
+--
+-- This function has a very general type signature commonly it 
+-- will be used at these types:
+--
+-- > unconnectorChain :: (Num u, OPlus a) => 
+-- >     ConnectorImage u a -> LocImage u a -> ConnectorChain u -> ConnectorImage u a
+-- >
+-- > unconnectorChain :: Num u => 
+-- >     ConnectorGraphic u -> LocGraphic u -> ConnectorChain u -> ConnectorGraphic u
+--
+--
+unconnectorChain :: (Num u, OPlus a) 
+                 => ConnectorCF u (ImageAns u a) 
+                 -> LocCF u (ImageAns u a) 
+                 -> ConnectorChain u 
+                 -> ConnectorCF u (ImageAns u a)
+unconnectorChain alt gf cchn = promoteR2 $ \p0 p1 -> 
+    (connect cchn p0 p1) >>= \pts -> case pts of
+      []     -> connect alt p0 p1
+      [x]    -> gf `at` x
+      (x:xs) -> go (gf `at` x) xs
   where
-    go (a:as) (p:ps)   = op a p >> go as ps
-    go _      _        = return ()
+    go acc []     = acc
+    go acc (p:ps) = go (acc `oplus` (gf `at` p)) ps
 
 
 
--- Notes - something like TikZ\'s chains could possibly be 
--- achieved with a Reader monad (@local@ initially seems better 
--- for \"state change\" than @set@ as local models a stack). 
+
+--------------------------------------------------------------------------------
+
+-- | 'liftChainF' : @ (point -> [point]) -> LocChain @
 --
--- It\'s almost tempting to put point-supply directly in the
--- Trace monad so that TikZ style chaining is transparent.
--- (The argument against is: how compatible this would be with
--- the Turtle monad for example?).
+-- Lift a pure chain generating function inot a 'LocChain'.
 --
+liftChainF :: (Point2 u -> PointChain u) -> LocChain u
+liftChainF fn = promoteR1 $ \pt -> return $ fn pt
 
diff --git a/src/Wumpus/Drawing/Chains/Derived.hs b/src/Wumpus/Drawing/Chains/Derived.hs
--- a/src/Wumpus/Drawing/Chains/Derived.hs
+++ b/src/Wumpus/Drawing/Chains/Derived.hs
@@ -22,18 +22,25 @@
     tableDown
   , tableRight
 
-  , horizontal
-  , vertical
+  , horizontalPoints
+  , verticalPoints
 
-  , horizontals
-  , verticals
+  , horizontalSteps
+  , verticalSteps
 
+  , innerHorizontals
+  , innerVerticals
+
   ) where
 
 import Wumpus.Drawing.Chains.Base
 
 import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Core                              -- package: wumpus-core
 
+
+import Data.List 
+
 --------------------------------------------------------------------------------
 -- Tables
 
@@ -47,11 +54,11 @@
 -- @top-left@.
 --
 tableDown :: Num u => Int -> (u,u) -> LocChain u
-tableDown n (rw,rh) pt = map fn ints
+tableDown n (rw,rh) = liftChainF $ \pt -> map (fn pt) ints
   where
-    ints = iterate (+1) 0
-    fn i = let (x,y) = i `divMod` n 
-           in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt
+    ints    = iterate (+1) 0
+    fn pt i = let (x,y) = i `divMod` n 
+              in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt
 
 
 -- | 'tableRight' : @ num_cols * row_width * row_height -> LocChain @
@@ -62,56 +69,45 @@
 -- This chain is infinite.
 --
 tableRight :: Num u => Int -> (u,u) -> LocChain u
-tableRight n (rw,rh) pt = map fn ints
+tableRight n (rw,rh) = liftChainF $ \pt -> map (fn pt) ints
   where
-    ints = iterate (+1) 0
-    fn i = let (y,x) = i `divMod` n 
-           in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt
-
-
+    ints    = iterate (+1) 0
+    fn pt i = let (y,x) = i `divMod` n 
+              in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt
 
 
 
--- | 'horizontal' : @ horizontal_dist -> LocChain @
+-- | 'horizontalPoints' : @ horizontal_dist -> LocChain @
 --
 -- The chain grows right by the supplied increment.
 --
 -- This chain is infinite.
 --
--- \*\* WARNING \*\* - name due to be changed. Current name is 
--- too general for this function. 
---
-horizontal :: Num u => u -> LocChain u
-horizontal dx = iterate (displaceH dx)
+horizontalPoints :: Num u => u -> LocChain u
+horizontalPoints dx = liftChainF $ iterate (displaceH dx)
 
 
--- | 'vertical' : @ vertical_dist -> LocChain @
+-- | 'verticalPoints' : @ vertical_dist -> LocChain @
 --
 -- The chain grows up by the supplied increment.
 --
 -- This chain is infinite.
 --
--- \*\* WARNING \*\* - name due to be changed. Current name is 
--- too general for this function. 
---
-vertical :: Num u => u -> LocChain u
-vertical dy = iterate (displaceV dy) 
+verticalPoints :: Num u => u -> LocChain u
+verticalPoints dy = liftChainF $ iterate (displaceV dy)
 
 
--- | 'horizontals' : @ [horizontal_dist] -> LocChain @
+-- | 'horizontalSteps' : @ [horizontal_dist] -> LocChain @
 --
 -- This is a @scanl@ successive displacing the start point.
 --
 -- This chain is finite (for finite input list).
 --
--- \*\* WARNING \*\* - name due to be changed. Current name is 
--- too general for this function. 
---
-horizontals :: Num u => [u] -> LocChain u
-horizontals xs = \pt -> scanl (flip displaceH) pt xs 
+horizontalSteps :: Num u => [u] -> LocChain u
+horizontalSteps xs = liftChainF $ \pt -> scanl (flip displaceH) pt xs 
 
 
--- | 'verticals' : @ [vertical_dist] -> LocChain @
+-- | 'verticalSteps' : @ [vertical_dist] -> LocChain @
 --
 -- This is a @scanl@ successive displacing the start point.
 --
@@ -120,7 +116,40 @@
 -- \*\* WARNING \*\* - name due to be changed. Current name is 
 -- too general for this function. 
 --
-verticals :: Num u => [u] -> LocChain u
-verticals ys = \pt -> scanl (flip displaceV) pt ys
+verticalSteps :: Num u => [u] -> LocChain u
+verticalSteps ys = liftChainF $ \pt -> scanl (flip displaceV) pt ys
 
+
+{-# INLINE [0] ceilingi #-}
+ceilingi :: RealFrac a => a -> Int
+ceilingi = ceiling
+
+
+-- | Note - horizontals are projected from the start point. The 
+-- horizontal component of the second point is ignored.
+-- 
+-- This chain is finite for well formed input.
+--
+innerHorizontals :: RealFrac u => u -> ConnectorChain u
+innerHorizontals n = promoteR2 $ \a b -> return $ body a b
+  where
+    body (P2 x0 y0) (P2 x1 _) = unfoldr phi (n * fromIntegral z) 
+      where z                 = ceilingi $ x0 / n
+            phi x | x < x1    = Just (P2 x y0, x+n)
+                  | otherwise = Nothing
+
+      
+
+-- | Note - verticals are projected from the start point. The 
+-- vertical component of the second point is ignored.
+-- 
+-- This chain is finite for well formed input.
+--
+innerVerticals :: RealFrac u => u -> ConnectorChain u
+innerVerticals n = promoteR2 $ \a b -> return $ body a b
+  where
+    body (P2 x0 y0) (P2 _ y1) = unfoldr phi (n * fromIntegral z)
+      where z                 = ceilingi $ y0 / n
+            phi y | y < y1    = Just (P2 x0 y, y+n)
+                  | otherwise = Nothing
 
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
@@ -57,12 +57,13 @@
   ) where
 
 
-import Wumpus.Drawing.Geometry.Intersection
-import Wumpus.Drawing.Geometry.Paths
 import Wumpus.Drawing.Dots.Marks
 import Wumpus.Drawing.Text.LRText
 
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Intersection       -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Paths
+import Wumpus.Basic.Geometry.Quadrant
+import Wumpus.Basic.Kernel               
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -83,8 +84,6 @@
                               , radial_anchor   :: Radian   -> Point2 u
                               , cardinal_anchor :: Cardinal -> Point2 u }
 
-data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW
-  deriving (Eq,Show) 
 
 type instance DUnit (DotAnchor u) = u
 
@@ -95,53 +94,53 @@
    radialAnchor theta (DotAnchor _ ra _) = ra theta
 
 instance CardinalAnchor (DotAnchor u) where
-   north (DotAnchor _ _ c1) = c1 NN
-   south (DotAnchor _ _ c1) = c1 SS
-   east  (DotAnchor _ _ c1) = c1 EE
-   west  (DotAnchor _ _ c1) = c1 WW
+   north (DotAnchor _ _ c1) = c1 NORTH
+   south (DotAnchor _ _ c1) = c1 SOUTH
+   east  (DotAnchor _ _ c1) = c1 EAST
+   west  (DotAnchor _ _ c1) = c1 WEST
 
 
 
 instance CardinalAnchor2 (DotAnchor u) where
-   northeast (DotAnchor _ _ c1) = c1 NE
-   southeast (DotAnchor _ _ c1) = c1 SE
-   southwest (DotAnchor _ _ c1) = c1 SW
-   northwest (DotAnchor _ _ c1) = c1 NW
+   northeast (DotAnchor _ _ c1) = c1 NORTH_EAST
+   southeast (DotAnchor _ _ c1) = c1 SOUTH_EAST
+   southwest (DotAnchor _ _ c1) = c1 SOUTH_WEST
+   northwest (DotAnchor _ _ c1) = c1 NORTH_WEST
 
 
 radialCardinal :: Floating u => u -> Point2 u -> Cardinal -> Point2 u
-radialCardinal rad ctr NN = ctr .+^ (avec (pi/2)     rad) 
-radialCardinal rad ctr NE = ctr .+^ (avec (pi/4)     rad) 
-radialCardinal rad ctr EE = ctr .+^ (avec  0         rad) 
-radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) 
-radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) 
-radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) 
-radialCardinal rad ctr WW = ctr .+^ (avec  pi        rad) 
-radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad) 
+radialCardinal rad ctr NORTH        = ctr .+^ (avec (pi/2)     rad) 
+radialCardinal rad ctr NORTH_EAST   = ctr .+^ (avec (pi/4)     rad) 
+radialCardinal rad ctr EAST         = ctr .+^ (avec  0         rad) 
+radialCardinal rad ctr SOUTH_EAST   = ctr .+^ (avec (7/4 * pi) rad) 
+radialCardinal rad ctr SOUTH        = ctr .+^ (avec (6/4 * pi) rad) 
+radialCardinal rad ctr SOUTH_WEST   = ctr .+^ (avec (5/4 * pi) rad) 
+radialCardinal rad ctr WEST         = ctr .+^ (avec  pi        rad) 
+radialCardinal rad ctr NORTH_WEST   = ctr .+^ (avec (3/4 * pi) rad) 
 
 
 -- Rectangle cardinal points are at \"middles and corners\".
 --
 
 rectCardinal :: Floating u => u ->  u -> Point2 u -> Cardinal -> Point2 u
-rectCardinal _  hh ctr NN = ctr .+^ (vvec hh) 
-rectCardinal hw hh ctr NE = ctr .+^ (vec  hw     hh) 
-rectCardinal hw _  ctr EE = ctr .+^ (hvec hw) 
-rectCardinal hw hh ctr SE = ctr .+^ (vec  hw    (-hh)) 
-rectCardinal _  hh ctr SS = ctr .+^ (vvec (-hh)) 
-rectCardinal hw hh ctr SW = ctr .+^ (vec  (-hw) (-hh) )
-rectCardinal hw _  ctr WW = ctr .+^ (hvec (-hw)) 
-rectCardinal hw hh ctr NW = ctr .+^ (vec  (-hw)  hh) 
+rectCardinal _  hh ctr NORTH        = ctr .+^ (vvec hh) 
+rectCardinal hw hh ctr NORTH_EAST   = ctr .+^ (vec  hw     hh) 
+rectCardinal hw _  ctr EAST         = ctr .+^ (hvec hw) 
+rectCardinal hw hh ctr SOUTH_EAST   = ctr .+^ (vec  hw    (-hh)) 
+rectCardinal _  hh ctr SOUTH        = ctr .+^ (vvec (-hh)) 
+rectCardinal hw hh ctr SOUTH_WEST   = ctr .+^ (vec  (-hw) (-hh) )
+rectCardinal hw _  ctr WEST         = ctr .+^ (hvec (-hw)) 
+rectCardinal hw hh ctr NORTH_WEST   = ctr .+^ (vec  (-hw)  hh) 
 
 polyCardinal :: Floating u => (Radian -> Point2 u) -> Cardinal -> Point2 u
-polyCardinal f NN = f (0.5  * pi)
-polyCardinal f NE = f (0.25 * pi) 
-polyCardinal f EE = f 0 
-polyCardinal f SE = f (1.75 * pi) 
-polyCardinal f SS = f (1.5  * pi) 
-polyCardinal f SW = f (1.25 * pi)
-polyCardinal f WW = f pi 
-polyCardinal f NW = f (0.75 * pi) 
+polyCardinal f NORTH                = f (0.5  * pi)
+polyCardinal f NORTH_EAST           = f (0.25 * pi) 
+polyCardinal f EAST                 = f 0 
+polyCardinal f SOUTH_EAST           = f (1.75 * pi) 
+polyCardinal f SOUTH                = f (1.5  * pi) 
+polyCardinal f SOUTH_WEST           = f (1.25 * pi)
+polyCardinal f WEST                 = f pi 
+polyCardinal f NORTH_WEST           = f (0.75 * pi) 
 
 
 
@@ -151,17 +150,18 @@
               , radial_anchor   = fn  
               , cardinal_anchor = rectCardinal hw hh ctr }
   where
-    fn theta =  maybe ctr id $ findIntersect ctr theta 
-                             $ rectangleLines ctr hw hh
+    fn theta =  displaceVec (rectRadialVector hw hh theta) ctr
 
 
-polygonAnchor :: (Real u, Floating u) => [Point2 u] -> Point2 u -> DotAnchor u
+polygonAnchor :: (Real u, Floating u, FromPtSize u) 
+              => [Point2 u] -> Point2 u -> DotAnchor u
 polygonAnchor ps ctr = 
     DotAnchor { center_anchor   = ctr
               , radial_anchor   = fn  
               , cardinal_anchor = polyCardinal fn }
   where
-    fn theta =  maybe ctr id $ findIntersect ctr theta $ polygonLines ps
+    fn theta =  maybe ctr id $ findIntersect ctr theta 
+                             $ polygonLineSegments ps
 
 
 
@@ -217,7 +217,9 @@
 
 
 dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u 
-dotText ss = fmap (bimapL bboxRectAnchor) (ctrCenterLine ss)
+dotText ss = fmap (bimapL bboxRectAnchor) (textAlignCenter ss)
+
+-- Note - maybe Wumpus-Basic should have a @swapAns@ function?
 
 
 dotHLine :: (Floating u, FromPtSize u) => DotLocImage u
diff --git a/src/Wumpus/Drawing/Dots/Marks.hs b/src/Wumpus/Drawing/Dots/Marks.hs
--- a/src/Wumpus/Drawing/Dots/Marks.hs
+++ b/src/Wumpus/Drawing/Dots/Marks.hs
@@ -50,10 +50,10 @@
   ) where
 
 
-import Wumpus.Drawing.Geometry.Paths
 import Wumpus.Drawing.Text.LRText
 
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Paths              -- package: wumpus-basic
+import Wumpus.Basic.Kernel        
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -89,7 +89,7 @@
 
 
 markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u
-markText ss = fmap (replaceL uNil) $ ctrCenterLine ss
+markText ss = fmap (replaceL uNil) $ textAlignCenter ss
 
 
 
@@ -97,7 +97,7 @@
 -- | Supplied point is the center.
 --
 axialLine :: Fractional u => Vec2 u -> LocGraphic u
-axialLine v = moveStartPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)
+axialLine v = moveStart (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)
 
 
 markHLine :: (Fractional u, FromPtSize u) => LocGraphic u 
@@ -169,7 +169,7 @@
 markSquare :: (Fractional u, FromPtSize u) => LocGraphic u
 markSquare = 
     lift0R1 markHeight >>= \h -> 
-    let d = 0.5*(-h) in moveStartPoint (displace d d) $ strokedRectangle h h
+    let d = 0.5*(-h) in moveStart (displace d d) $ strokedRectangle h h
     
 
 
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/Grids.hs b/src/Wumpus/Drawing/Grids.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Grids.hs
@@ -0,0 +1,67 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Grids
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Drawing grids
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Grids
+  ( 
+    grid
+  , interiorGrid
+
+  ) where
+
+import Wumpus.Drawing.Chains
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Core                              -- package: wumpus-core
+
+
+
+grid :: Fractional u => (Int,Int) -> u -> LocGraphic u
+grid (nx,ny) incr    
+    | nx < 1 || ny < 1 = emptyLocGraphic
+    | otherwise        = promoteR1 $ \sw -> 
+        let rw      = incr * fromIntegral nx
+            rh      = incr * fromIntegral ny
+            xchn    = horizontalPoints incr
+            ychn    = verticalPoints incr
+            vline1  = straightLine (vvec rh)
+            hline1  = straightLine (hvec rw)
+            vlines  = unchain nx emptyLocGraphic vline1 xchn
+            hlines  = unchain ny emptyLocGraphic hline1  ychn
+        in (hlines `oplus` vlines `oplus` strokedRectangle rw rh) `at` sw
+
+
+
+-- | 'interiorGrid' : @ increment -> ConnectorGraphic @
+--
+-- Draw the interior lines of a grid between the /connector/ 
+-- points - start point is interpreted as bottom-left, end-point
+-- is interpreted as top right.
+--
+-- The interior lines are calculated with repsect to the 0 and the 
+-- increment, for instance with an increment of 10 but a start 
+-- point @(15,0)@ lines are drawn from @(20,0), (30,0)@ etc.
+--
+interiorGrid :: RealFrac u => u -> ConnectorGraphic u
+interiorGrid incr = promoteR2 $ \sw ne ->
+    let xcc         = innerHorizontals incr
+        ycc         = innerVerticals   incr
+        (V2 vx vy)  = pvec sw ne
+        hline1      = straightLine (hvec vx)
+        vline1      = straightLine (vvec vy)
+        vlines      = unconnectorChain emptyConnectorGraphic vline1 xcc
+        hlines      = unconnectorChain emptyConnectorGraphic hline1 ycc
+    in connect (hlines `oplus` vlines) sw ne
+
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,7 +3,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Drawing.Paths
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
@@ -11,6 +11,9 @@
 -- Portability :  GHC
 --
 -- Shim import module for Paths.
+--
+-- Note MonadicConstruction is not exported, this module is 
+-- somewhat out-of-date and needs a re-think.
 -- 
 --------------------------------------------------------------------------------
 
@@ -20,12 +23,10 @@
     module Wumpus.Drawing.Paths.Base
   , module Wumpus.Drawing.Paths.Connectors
   , module Wumpus.Drawing.Paths.ControlPoints
-  , module Wumpus.Drawing.Paths.MonadicConstruction
 
   ) where
 
 import Wumpus.Drawing.Paths.Base
 import Wumpus.Drawing.Paths.Connectors
 import Wumpus.Drawing.Paths.ControlPoints
-import Wumpus.Drawing.Paths.MonadicConstruction
 
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
@@ -69,9 +69,8 @@
   ) where
 
 
-import Wumpus.Drawing.Geometry.Intersection ( langle )
 
--- package: wumpus-basic
+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic
 import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl
                                    , ViewR(..), viewr, cons, snoc, join )
 import qualified Wumpus.Basic.Utils.JoinList as JL
@@ -79,7 +78,6 @@
 import Wumpus.Core                              -- package: wumpus-core
 
 import Data.AffineSpace
-import Data.VectorSpace
 
 import Data.List ( foldl' ) 
 
@@ -175,9 +173,9 @@
              in Path v p0 (JL.one $ LineSeg v p0 p1) p1
    
 
-curve :: (Floating u, Ord u)
+curve :: (Floating u, Ord u, FromPtSize u)
       => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u 
-curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3
+curve p0 p1 p2 p3 = let v = bezierLength (BezierCurve p0 p1 p2 p3)
                     in Path v p0 (JL.one $ CurveSeg v p0 p1 p2 p3) p3
 
 -- | A draw a /straight line/ of length 0 at the supplied point. 
@@ -209,7 +207,8 @@
 -- 'traceCurvePoints' throws a runtime error if the supplied list
 -- is has less than 4 elements (start, control1, control2, end). 
 --
-traceCurvePoints :: (Floating u, Ord u) => [Point2 u] -> Path u
+traceCurvePoints :: (Floating u, Ord u, FromPtSize u) 
+                 => [Point2 u] -> Path u
 traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs
   where
     step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs
@@ -218,7 +217,7 @@
 traceCurvePoints _            = error "tracePointsCurve - less than 4 elems."
 
 
-curveByAngles :: (Floating u, Ord u) 
+curveByAngles :: (Floating u, Ord u, FromPtSize u) 
               => Point2 u -> Radian -> Radian -> Point2 u -> Path u
 curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end
   where
@@ -252,75 +251,7 @@
 
 
 
---------------------------------------------------------------------------------
--- Curve length
 
-data StrictCurve u = Curve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)
-
-curveLength :: (Floating u, Ord u)      
-            => Point2 u -> Point2 u -> Point2 u -> Point2 u -> u
-curveLength p0 p1 p2 p3 = gravesenLength 0.1 $ Curve p0 p1 p2 p3
-
-
--- | Jens Gravesen\'s bezier arc-length approximation. 
---
--- Note this implementation is parametrized on error tolerance.
---
-gravesenLength :: (Floating u, Ord u) => u -> StrictCurve u -> u
-gravesenLength err_tol crv = step crv where
-  step c = let l1 = ctrlPolyLength c
-               l0 = cordLength c
-           in if   l1-l0 > err_tol
-              then let (a,b) = subdivide c in step a + step b
-              else 0.5*l0 + 0.5*l1
-
-
-ctrlPolyLength :: Floating u => StrictCurve u -> u
-ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3
-  where
-    len pa pb = vlength $ pvec pa pb
-
-cordLength :: Floating u => StrictCurve u -> u
-cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3
-
-
--- | mid-point between two points
---
-pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
-pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0
-
-
--- | Curve subdivision via de Casteljau\'s algorithm.
---
-subdivide :: Fractional u 
-          => StrictCurve u -> (StrictCurve u, StrictCurve u)
-subdivide (Curve p0 p1 p2 p3) =
-    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)
-  where
-    p01   = pointMidpoint p0    p1
-    p12   = pointMidpoint p1    p2
-    p23   = pointMidpoint p2    p3
-    p012  = pointMidpoint p01   p12
-    p123  = pointMidpoint p12   p23
-    p0123 = pointMidpoint p012  p123
-
--- | subdivide with an affine weight along the line...
---
-subdividet :: Real u
-           => u -> StrictCurve u -> (StrictCurve u, StrictCurve u)
-subdividet t (Curve p0 p1 p2 p3) = 
-    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)
-  where
-    p01   = affineCombination t p0    p1
-    p12   = affineCombination t p1    p2
-    p23   = affineCombination t p2    p3
-    p012  = affineCombination t p01   p12
-    p123  = affineCombination t p12   p23
-    p0123 = affineCombination t p012  p123
-
-affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u
-affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1)
-
 --------------------------------------------------------------------------------
 -- tips 
 
@@ -372,9 +303,11 @@
 shortenSegL n (LineSeg  u p0 p1)        = 
     LineSeg  (u-n) (shortenLineL n p0 p1) p1
 
-shortenSegL n (CurveSeg u p0 p1 p2 p3)  = 
-    let (Curve p0' p1' p2' p3') = snd $ subdividet (n/u) (Curve p0 p1 p2 p3)
-    in CurveSeg (u-n) p0' p1' p2' p3'
+shortenSegL n (CurveSeg u p0 p1 p2 p3)  = CurveSeg (u-n) q0 q1 q2 q3
+  where
+    (BezierCurve q0 q1 q2 q3) = snd $ subdividet (n/u) 
+                                                 (BezierCurve p0 p1 p2 p3)
+     
 
 
 shortenLineL :: (Real u, Floating u) 
@@ -419,9 +352,11 @@
 shortenSegR n (LineSeg  u p0 p1)        = 
     LineSeg  (u-n) p0 (shortenLineR n p0 p1) 
 
-shortenSegR n (CurveSeg u p0 p1 p2 p3)  = 
-    let (Curve p0' p1' p2' p3') = fst $ subdividet ((u-n)/u) (Curve p0 p1 p2 p3)
-    in CurveSeg (u-n) p0' p1' p2' p3'
+shortenSegR n (CurveSeg u p0 p1 p2 p3)  = CurveSeg (u-n) q0 q1 q2 q3
+  where
+    (BezierCurve q0 q1 q2 q3) = fst $ subdividet ((u-n)/u) 
+                                                 (BezierCurve p0 p1 p2 p3)
+     
 
 
 shortenLineR :: (Real u, Floating u) 
@@ -555,14 +490,14 @@
 -- longer than half of /d/ (d - being the distance between the 
 -- /truncated/ points and the corner).
 --
-cornerCurve :: (Real u, Floating u) 
+cornerCurve :: (Real u, Floating u, FromPtSize u) 
             => Point2 u -> Point2 u -> Point2 u -> Path u
 cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3
   where
     len1 = 0.6 *  (vlength $ pvec p1 p2)
     len2 = 0.6 *  (vlength $ pvec p3 p2)
-    cp1  = p1 .+^ (avec (langle p1 p2) len1)
-    cp2  = p3 .+^ (avec (langle p3 p2) len2)
+    cp1  = p1 .+^ (avec (lineAngle p1 p2) len1)
+    cp2  = p3 .+^ (avec (lineAngle p3 p2) len2)
 
 
 -- | 'roundTrail' : @ rounding_distance * [point] -> Path @
@@ -580,7 +515,7 @@
 -- If the list has one element /the null path/ is built, if the 
 -- list has two elements a straight line is built.
 --
-roundTrail :: (Real u, Floating u) 
+roundTrail :: (Real u, Floating u, FromPtSize u) 
            => u -> [Point2 u] -> Path u 
 roundTrail _ []             = error "roundTrail - empty list."
 roundTrail _ [a]            = pathZero a
@@ -599,7 +534,7 @@
 -- Note - the starting point is moved, this function is for 
 -- closed, rounded paths.
 --
-lineCurveTrail :: (Real u, Floating u) 
+lineCurveTrail :: (Real u, Floating u, FromPtSize u) 
                => u -> Point2 u -> Point2 u -> Point2 u -> Path u
 lineCurveTrail u a b c = line p1 p2 `append` cornerCurve p2 b p3
   where
@@ -620,8 +555,8 @@
 -- empty. If the list has one element /the null path/ is built, 
 -- if the list has two elements a straight line is built.
 --
-roundInterior :: (Real u, Floating u) 
-           => u -> [Point2 u] -> Path u 
+roundInterior :: (Real u, Floating u, FromPtSize u) 
+              => u -> [Point2 u] -> Path u 
 roundInterior _ []             = error "roundEveryInterior - empty list."
 roundInterior _ [a]            = pathZero a
 roundInterior _ [a,b]          = line a b
@@ -640,7 +575,7 @@
 -- Note - draws a straight line from the starting point - this is 
 -- the first step of an interior (non-closed) rounded path
 --
-lineCurveInter1 :: (Real u, Floating u) 
+lineCurveInter1 :: (Real u, Floating u, FromPtSize u) 
                 => u -> Point2 u -> Point2 u -> Point2 u -> (Path u, Point2 u)
 lineCurveInter1 u a b c = 
     (line a p2 `append` cornerCurve p2 b p3, p3)
diff --git a/src/Wumpus/Drawing/Paths/Connectors.hs b/src/Wumpus/Drawing/Paths/Connectors.hs
--- a/src/Wumpus/Drawing/Paths/Connectors.hs
+++ b/src/Wumpus/Drawing/Paths/Connectors.hs
@@ -184,7 +184,8 @@
 --
 -- @u@ is the altitude of the triangle.
 --
-connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u 
+connIsoscelesCurve :: (Real u, Floating u, FromPtSize u) 
+                   => u -> ConnectorPath u 
 connIsoscelesCurve u = promoteR2 $ \ p0 p1 ->
     let control_pt  = midpointIsosceles u p0 p1
     in pure $ traceCurvePoints [p0, control_pt, control_pt, p1]
@@ -196,7 +197,8 @@
 -- The two Bezier control points take the /top/ corners. The
 -- curve tends to be very deep.
 -- 
-connSquareCurve :: (Real u, Floating u) => ConnectorPath u 
+connSquareCurve :: (Real u, Floating u, FromPtSize u) 
+                => ConnectorPath u 
 connSquareCurve = promoteR2 $ \ p0 p1 ->
     let (cp0,cp1) = squareFromBasePoints p0 p1
     in pure $ traceCurvePoints [p0, cp0, cp1, p1]
@@ -210,7 +212,8 @@
 -- 
 -- (Underneath is modulo the direction, of course).
 -- 
-connUSquareCurve :: (Real u, Floating u) => ConnectorPath u 
+connUSquareCurve :: (Real u, Floating u, FromPtSize u) 
+                 => ConnectorPath u 
 connUSquareCurve = promoteR2 $ \ p0 p1 -> 
     let (cp0,cp1) = usquareFromBasePoints p0 p1
     in pure $ traceCurvePoints [p0, cp0, cp1, p1]
@@ -220,7 +223,8 @@
 --
 -- Form a curve inside a trapeziod.
 -- 
-connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u 
+connTrapezoidCurve :: (Real u, Floating u, FromPtSize u) 
+                   => u -> u -> ConnectorPath u 
 connTrapezoidCurve u ratio_to_base = promoteR2 $ \p0 p1 -> 
     let (cp0,cp1)  = trapezoidFromBasePoints u ratio_to_base p0 p1
     in pure $ traceCurvePoints [p0, cp0, cp1, p1]
@@ -229,7 +233,8 @@
 -- | Make a curve within a square, following the corner points as
 -- a Z.
 --
-connZSquareCurve :: (Real u, Floating u) => ConnectorPath u 
+connZSquareCurve :: (Real u, Floating u, FromPtSize u) 
+                 => ConnectorPath u 
 connZSquareCurve = promoteR2 $ \p0 p1 -> 
     let (cp0,cp1)  = squareFromCornerPoints p0 p1
     in pure $ traceCurvePoints [p0,cp0,cp1,p1]
@@ -240,7 +245,8 @@
 -- The order of tracing flips the control points, so this is an
 -- /underneath/ version of 'connZSquareCurve'.
 -- 
-connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u 
+connUZSquareCurve :: (Real u, Floating u, FromPtSize u) 
+                  => ConnectorPath u 
 connUZSquareCurve = promoteR2 $ \ p0 p1 ->  
    let (cp0,cp1)  = squareFromCornerPoints p0 p1 
    in pure $ traceCurvePoints [p0,cp1,cp0,p1]
diff --git a/src/Wumpus/Drawing/Paths/MonadicConstruction.hs b/src/Wumpus/Drawing/Paths/MonadicConstruction.hs
--- a/src/Wumpus/Drawing/Paths/MonadicConstruction.hs
+++ b/src/Wumpus/Drawing/Paths/MonadicConstruction.hs
@@ -127,7 +127,7 @@
 
 
 
-bezierto :: (Floating u, Ord u) 
+bezierto :: (Floating u, Ord u, FromPtSize u) 
          => Point2 u -> Point2 u -> Point2 u -> PathM u ()
 bezierto c1 c2 ep = PathM $ \(St p0 ac) -> 
     ((), St ep (ac `snocH` curve p0 c1 c2 ep))
@@ -139,7 +139,7 @@
 --
 
 
-curveto :: (Floating u, Ord u) 
+curveto :: (Floating u, Ord u, FromPtSize u) 
         => Radian -> Radian -> Point2 u -> PathM u ()
 curveto cin cout end = PathM $ \(St p0 ac) -> 
     let seg  = curveByAngles p0 cin cout end 
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
@@ -4,7 +4,7 @@
 
 --------------------------------------------------------------------------------
 -- |
--- Module      :  Wumpus.Drawing.Shapes.Base2
+-- Module      :  Wumpus.Drawing.Shapes.Base
 -- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
@@ -21,59 +21,144 @@
   ( 
 
 
-    LocShape
-  , intoLocShape
+    Shape
+  , DShape
+
+  , makeShape
   , strokedShape
   , filledShape
   , borderedShape
+  , rstrokedShape
+  , rfilledShape
+  , rborderedShape
 
   , roundCornerShapePath
 
+  , updatePathAngle
+  , setDecoration
+
   , ShapeCTM
   , makeShapeCTM
   , ctmCenter
   , ctmAngle
-  , projectPoint
-
+  , displaceCenter
  
 
   ) where
 
-import Wumpus.Basic.Kernel
 import Wumpus.Drawing.Paths
 
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
 import Wumpus.Core                              -- package: wumpus-core
 
 
+import Data.AffineSpace                         -- package: vector-space
+
 import Control.Applicative
 
 
-type LocShape u a = LocCF u (a, Path u)
+-- | Shape is a record of three /LocTheta/ functions - 
+-- functions /from Point and Angle to answer/. 
+--
+-- The @shape_path_fun@ returns a path. When the Shape is drawn, 
+-- the rendering function (@strokedShape@, etc.) uses the path for 
+-- drawing and returns the polymorphic answer @a@ of the 
+-- @shape_ans_fun@. Lastly the @shape_decoration@ function can 
+-- instantiated to add decoration (e.g. text) to the Shape as it 
+-- is rendered.
+--
+-- The @a@ of the @shape_ans_fun@ represents some concrete shape 
+-- object (e.g. a Rectangle, Triangle etc.). Crucial for shape 
+-- objects is that they support Anchors - this allows connectors 
+-- to address specific locations on the Shape border so 
+-- \"node and link\" diagrams can be made easily.
+--
+data Shape u a = Shape 
+      { shape_ans_fun     :: LocThetaCF u a
+      , shape_path_fun    :: LocThetaCF u (Path u) 
+      , shape_decoration  :: LocThetaGraphic u
+      }
 
 
-intoLocShape :: LocCF u a -> LocCF u (Path u) -> LocCF u (a,Path u)
-intoLocShape = liftA2 (,)
+type DShape a = Shape Double a
 
-strokedShape :: Num u => LocShape u a -> LocImage u a
-strokedShape mf = 
-   promoteR1 $ \pt -> 
-     (mf `at` pt) >>= \(a,spath) -> 
-     intoImage (pure a) (closedStroke $ toPrimPath spath)
+type instance DUnit (Shape u a) = u
 
 
-filledShape :: Num u => LocShape u a -> LocImage u a
-filledShape mf = 
-   promoteR1 $ \pt -> 
-     (mf `at` pt) >>= \(a,spath) -> 
-     intoImage (pure a) (filledPath $ toPrimPath spath)
+--------------------------------------------------------------------------------
 
+instance Functor (Shape u) where
+  fmap f = (\s i -> s { shape_ans_fun = fmap f i }) 
+             <*> shape_ans_fun
 
-borderedShape :: Num u => LocShape u a -> LocImage u a
-borderedShape mf = 
-   promoteR1 $ \pt -> 
-     (mf `at` pt) >>= \(a,spath) -> 
-     intoImage (pure a) (borderedPath $ toPrimPath spath)
 
+-- Note - there are no instances of Applicative, Monad, 
+-- DrawingCtxM... so Shapes cannot have localized drawing props.
+--
+-- @localize@ must be performed in the context of @strokeShape@, 
+-- @fillShape@ etc.
+--
+
+
+
+--------------------------------------------------------------------------------
+
+
+makeShape :: Num u => LocThetaCF u a -> LocThetaCF u (Path u) -> Shape u a
+makeShape f g = Shape { shape_ans_fun    = f
+                      , shape_path_fun   = g
+                      , shape_decoration = emptyLocThetaGraphic
+                      }
+
+
+
+
+strokedShape :: Num u => Shape u a -> LocImage u a
+strokedShape = shapeToLoc closedStroke
+
+
+filledShape :: Num u => Shape u a -> LocImage u a
+filledShape = shapeToLoc filledPath
+
+
+borderedShape :: Num u => Shape u a -> LocImage u a
+borderedShape = shapeToLoc borderedPath
+
+
+shapeToLoc :: Num u 
+           => (PrimPath u -> Graphic u) -> Shape u a -> LocImage u a
+shapeToLoc pathF sh = promoteR1 $ \pt -> 
+    atRot (shape_ans_fun sh)  pt 0 >>= \a -> 
+    atRot (shape_path_fun sh) pt 0 >>= \spath -> 
+    let g1 = pathF $ toPrimPath spath 
+        g2 = atRot (shape_decoration sh) pt 0 
+    in intoImage (pure a) (g1 `oplus` g2)
+
+
+
+rstrokedShape :: Num u => Shape u a -> LocThetaImage u a
+rstrokedShape = shapeToLocTheta closedStroke
+
+
+rfilledShape :: Num u => Shape u a -> LocThetaImage u a
+rfilledShape = shapeToLocTheta filledPath
+
+
+rborderedShape :: Num u => Shape u a -> LocThetaImage u a
+rborderedShape = shapeToLocTheta borderedPath
+
+
+shapeToLocTheta :: Num u 
+                => (PrimPath u -> Graphic u) -> Shape u a -> LocThetaImage u a
+shapeToLocTheta pathF sh = promoteR2 $ \pt theta -> 
+    atRot (shape_ans_fun sh)  pt theta >>= \a -> 
+    atRot (shape_path_fun sh) pt theta >>= \spath -> 
+    let g1 = pathF $ toPrimPath spath 
+        g2 = atRot (shape_decoration sh) pt theta
+    in intoImage (pure a) (g1 `oplus` g2)
+
+
+
 -- | Draw the shape path with round corners.
 -- 
 roundCornerShapePath :: (Real u, Floating u, FromPtSize u) 
@@ -82,8 +167,35 @@
     if sz == 0 then return (traceLinePoints xs) 
                else return (roundTrail  sz xs)
 
+-- | The path angle can be modified. This allows /inverse/ 
+-- versions of shapes (e.g. InvTriangle) to be made by
+-- wrapping a base Shape but rotating the path prior to drawing 
+-- it.
+-- 
+-- Only the Path needs rotating, the decoration takes the original 
+-- angle. The anchors are typically implemented by rotating the 
+-- correspoding anchor of the wrapped Shape about its center.
+-- 
+updatePathAngle :: (Radian -> Radian) -> Shape u a -> Shape u a
+updatePathAngle f = 
+    (\s i -> s { shape_path_fun = moveTheta (circularModulo . f) i})
+      <*> shape_path_fun
 
+setDecoration :: LocThetaGraphic u -> Shape u a -> Shape u a
+setDecoration gf = (\s -> s { shape_decoration = gf })
 
+
+
+
+-- For Wumpus-Basic...
+-- | Move the /rotation/ of a LocThetaImage with the supplied 
+-- displacement function.
+--
+moveTheta :: (Radian -> Radian) -> LocThetaCF u a -> LocThetaCF u a
+moveTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta)
+
+
+
 --------------------------------------------------------------------------------
 -- CTM
 
@@ -102,13 +214,11 @@
 
 type instance DUnit (ShapeCTM u) = u
 
-makeShapeCTM :: Num u => Point2 u -> ShapeCTM u
-makeShapeCTM pt = ShapeCTM { ctm_center   = pt
-                           , ctm_scale_x  = 1
-                           , ctm_scale_y  = 1
-                           , ctm_rotation = 0 }
-
-
+makeShapeCTM :: Num u => Point2 u -> Radian -> ShapeCTM u
+makeShapeCTM pt ang = ShapeCTM { ctm_center   = pt
+                               , ctm_scale_x  = 1
+                               , ctm_scale_y  = 1
+                               , ctm_rotation = ang }
 
 
 instance Num u => Scale (ShapeCTM u) where
@@ -141,11 +251,13 @@
 ctmAngle = ctm_rotation
 
 
-
-projectPoint :: (Real u, Floating u) => Point2 u -> ShapeCTM u  -> Point2 u
-projectPoint (P2 x y) (ShapeCTM { ctm_center   = (P2 dx dy)
-                                , ctm_scale_x  = sx
-                                , ctm_scale_y  = sy
-                                , ctm_rotation = theta     }) =
-    translate dx dy $ rotate theta $ P2 (sx*x) (sy*y)
-
+displaceCenter :: (Real u, Floating u) => Vec2 u -> ShapeCTM u  -> Point2 u
+displaceCenter v0 (ShapeCTM { ctm_center   = ctr0
+                            , ctm_scale_x  = sx
+                            , ctm_scale_y  = sy
+                            , ctm_rotation = theta }) = ctr .+^ v
+  where
+    ctr = rotate theta $ scale sx sy ctr0
+    v   = rotateAbout theta ctr $ scale sx sy v0
+     
+    
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
@@ -32,7 +32,6 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space 
 
 import Control.Applicative
 
@@ -45,49 +44,54 @@
       { circ_ctm    :: ShapeCTM u
       , circ_radius :: !u 
       }
-  deriving (Eq,Show)
   
 type DCircle = Circle Double
 
 type instance DUnit (Circle u) = u
 
 
-
+--------------------------------------------------------------------------------
+-- Affine trans
 
-mapCircleCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u
-mapCircleCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u
+mapCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm
 
 instance Num u => Scale (Circle u) where
-  scale sx sy = mapCircleCTM (scale sx sy)
+  scale sx sy = mapCTM (scale sx sy)
 
 
 instance Rotate (Circle u) where
-  rotate ang = mapCircleCTM (rotate ang)
+  rotate ang = mapCTM (rotate ang)
                   
 
 instance (Real u, Floating u) => RotateAbout (Circle u) where
-  rotateAbout ang pt = mapCircleCTM (rotateAbout ang pt)
+  rotateAbout ang pt = mapCTM (rotateAbout ang pt)
 
 
 instance Num u => Translate (Circle u) where
-  translate dx dy = mapCircleCTM (translate dx dy)
+  translate dx dy = mapCTM (translate dx dy)
 
 
+--------------------------------------------------------------------------------
+-- Anchors
 
-runCircle :: (u -> ShapeCTM u -> a) -> Circle u -> a
-runCircle fn (Circle { circ_ctm = ctm, circ_radius = radius }) = 
-    fn radius ctm
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> Vec2 u) -> Circle u -> Point2 u
+runDisplaceCenter fn (Circle { circ_ctm    = ctm
+                             , circ_radius = radius }) = 
+    displaceCenter (fn radius) ctm
 
 
+
 instance (Real u, Floating u) => CenterAnchor (Circle u) where
-  center = runCircle (\_ -> ctmCenter)
+  center = runDisplaceCenter $ \_ -> V2 0 0 
 
 
 instance (Real u, Floating u) => CardinalAnchor (Circle u) where
-  north = runCircle $ \r -> projectPoint $ P2 0    r
-  south = runCircle $ \r -> projectPoint $ P2 0  (-r)
-  east  = runCircle $ \r -> projectPoint $ P2 r    0
-  west  = runCircle $ \r -> projectPoint $ P2 (-r) 0
+  north = runDisplaceCenter $ \r -> V2 0    r
+  south = runDisplaceCenter $ \r -> V2 0  (-r)
+  east  = runDisplaceCenter $ \r -> V2 r    0
+  west  = runDisplaceCenter $ \r -> V2 (-r) 0
 
 
 instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where
@@ -98,29 +102,35 @@
 
 
 instance (Real u, Floating u) => RadialAnchor (Circle u) where
-  radialAnchor theta = runCircle $ \r -> projectPoint $ zeroPt .+^ avec theta r
-
+  radialAnchor ang = runDisplaceCenter $ \r -> avec ang r
 
 
 
 
+--------------------------------------------------------------------------------
+-- Construction
 
--- | 'circle'  : @ radius -> shape @
+-- | 'circle'  : @ radius -> Shape @
 --
-circle :: (Real u, Floating u) => u -> LocShape u (Circle u)
-circle radius = intoLocShape (mkCircle radius) (mkCirclePath radius)
+circle :: (Real u, Floating u, FromPtSize u) 
+       => u -> Shape u (Circle u)
+circle radius = makeShape (mkCircle radius) (mkCirclePath radius)
           
 
 
-mkCircle :: Num u => u -> LocCF u (Circle u)
-mkCircle radius = promoteR1 $ \ctr -> 
-    pure $ Circle { circ_ctm = makeShapeCTM ctr, circ_radius = radius }
-
+mkCircle :: Num u => u -> LocThetaCF u (Circle u)
+mkCircle radius = promoteR2 $ \ctr theta -> 
+    pure $ Circle { circ_ctm    = makeShapeCTM ctr theta
+                  , circ_radius = radius 
+                  }
 
 
-mkCirclePath :: (Floating u, Ord u) => u -> LocCF u (Path u)
-mkCirclePath radius = promoteR1 $ \ctr -> 
-    pure $ traceCurvePoints $ bezierCircle 2 radius ctr 
+-- Rotation (theta) can be ignored.
+--
+mkCirclePath :: (Floating u, Ord u, FromPtSize u) 
+             => u -> LocThetaCF u (Path u)
+mkCirclePath radius = promoteR2 $ \ctr _ -> 
+    pure $ traceCurvePoints $ bezierCircle radius ctr 
 
 
 
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
@@ -12,7 +12,7 @@
 -- Stability   :  highly unstable
 -- Portability :  GHC
 --
--- Simple shapes - rectangle, circle diamond, ellipse.
+-- Diamond (rhombus).
 -- 
 --------------------------------------------------------------------------------
 
@@ -26,17 +26,16 @@
 
   ) where
 
-import Wumpus.Drawing.Geometry.Intersection
-import Wumpus.Drawing.Geometry.Paths
 import Wumpus.Drawing.Paths
 import Wumpus.Drawing.Shapes.Base
 
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Quadrant
+import Wumpus.Basic.Geometry.Paths
+import Wumpus.Basic.Kernel      
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space 
-import Data.VectorSpace
 
 import Control.Applicative
 
@@ -58,39 +57,63 @@
 type instance DUnit (Diamond u) = u
 
 
-mapDiamondCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u
-mapDiamondCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm
+--------------------------------------------------------------------------------
+-- Affine trans
 
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u
+mapCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm
+
 instance Num u => Scale (Diamond u) where
-  scale sx sy = mapDiamondCTM (scale sx sy)
+  scale sx sy = mapCTM (scale sx sy)
 
 
 instance Rotate (Diamond u) where
-  rotate ang = mapDiamondCTM (rotate ang)
+  rotate ang = mapCTM (rotate ang)
                   
 
 instance (Real u, Floating u) => RotateAbout (Diamond u) where
-  rotateAbout ang pt = mapDiamondCTM (rotateAbout ang pt)
+  rotateAbout ang pt = mapCTM (rotateAbout ang pt)
 
 
 instance Num u => Translate (Diamond u) where
-  translate dx dy = mapDiamondCTM (translate dx dy)
+  translate dx dy = mapCTM (translate dx dy)
 
 
 
-runDiamond :: (u -> u -> ShapeCTM u  -> a) -> Diamond u -> a
-runDiamond fm (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = 
-   fm hw hh ctm
+--------------------------------------------------------------------------------
+-- Anchors
 
+-- | 'runDisplaceCenter' : @ ( half_width 
+--                           * half_height -> Vec ) * diamond -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> u -> Vec2 u) -> Diamond u -> Point2 u
+runDisplaceCenter fn (Diamond { dia_ctm = ctm
+                              , dia_hw = hw
+                              , dia_hh = hh }) = 
+   displaceCenter (fn hw hh) ctm
 
+
 instance (Real u, Floating u) => CenterAnchor (Diamond u) where
-  center = runDiamond (\_ _ -> ctmCenter)
+  center = runDisplaceCenter $ \_ _ -> V2 0 0
 
+instance (Real u, Floating u) => ApexAnchor (Diamond u) where
+  apex = runDisplaceCenter $ \_  hh -> V2 0 hh
+
+instance (Real u, Floating u) => SideMidpointAnchor (Diamond u) where
+  sideMidpoint n a = step (n `mod` 4) 
+    where
+      step 1 = midpoint (north a) (west a)
+      step 2 = midpoint (west a)  (south a)
+      step 3 = midpoint (south a) (east a)
+      step _ = midpoint (east a)  (north a)
+
+
 instance (Real u, Floating u) => CardinalAnchor (Diamond u) where
-  north = runDiamond $ \_  hh -> projectPoint $ P2 0 hh
-  south = runDiamond $ \_  hh -> projectPoint $ P2 0 (-hh)
-  east  = runDiamond $ \hw _  -> projectPoint $ P2 hw 0
-  west  = runDiamond $ \hw _  -> projectPoint $ P2 (-hw) 0
+  north = apex
+  south = runDisplaceCenter $ \_  hh -> V2 0 (-hh)
+  east  = runDisplaceCenter $ \hw _  -> V2 hw 0
+  west  = runDisplaceCenter $ \hw _  -> V2 (-hw) 0
 
 instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where
   northeast x = midpoint (north x) (east x)
@@ -101,52 +124,34 @@
 
 
 instance (Real u, Floating u) => RadialAnchor (Diamond u) where
-   radialAnchor = diamondIntersect
+    radialAnchor ang = runDisplaceCenter $ \hw hh -> 
+                         diamondRadialVector hw hh ang
 
 
--- Utils.Intersection needs improving...
 
 
-diamondIntersect :: (Real u, Floating u) 
-                 => Radian -> Diamond u -> Point2 u
-diamondIntersect theta (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = 
-    let ps  = diamondPoints hw hh ctm 
-        ctr = ctmCenter ctm
-    in maybe ctr id $ findIntersect ctr theta $ polygonLines ps
-    
-
-
-midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
-midpoint p1 p2 = let v = 0.5 *^ pvec p1 p2 in p1 .+^ v
-
-
+--------------------------------------------------------------------------------
+-- Construction
 
 -- | 'diamond'  : @ half_width * half_height -> shape @
 --
 -- Note - args might change to tull_width and full_height...
 --
 diamond :: (Real u, Floating u, FromPtSize u) 
-        => u -> u -> LocShape u (Diamond u)
-diamond hw hh = intoLocShape (mkDiamond hw hh) (mkDiamondPath hw hh)
+        => u -> u -> Shape u (Diamond u)
+diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath hw hh)
 
 
-mkDiamond :: Num u => u -> u -> LocCF u (Diamond u)
-mkDiamond hw hh = promoteR1 $ \ctr -> 
-    pure $ Diamond { dia_ctm = makeShapeCTM ctr, dia_hw = hw, dia_hh = hh }
+mkDiamond :: Num u => u -> u -> LocThetaCF u (Diamond u)
+mkDiamond hw hh = promoteR2 $ \ctr theta -> 
+    pure $ Diamond { dia_ctm = makeShapeCTM ctr theta
+                   , dia_hw  = hw
+                   , dia_hh = hh 
+                   }
 
 
 mkDiamondPath :: (Real u, Floating u, FromPtSize u) 
-              => u -> u -> LocCF u (Path u)
-mkDiamondPath hw hh = promoteR1 $ \ctr -> 
-    roundCornerShapePath $ diamondCoordPath hw hh ctr
-
-
-diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u]
-diamondPoints hw hh ctm = map (projectPoint `flip` ctm) [ s, e, n, w ]
-  where
-    s = P2   0  (-hh)
-    e = P2   hw    0
-    n = P2   0    hh
-    w = P2 (-hw)   0 
-
-
+              => u -> u -> LocThetaCF u (Path u)
+mkDiamondPath hw hh = promoteR2 $ \ctr theta -> 
+    roundCornerShapePath $ map (rotateAbout theta ctr) 
+                         $ diamondCoordPath hw hh ctr
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
@@ -35,7 +35,6 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space 
 
 import Control.Applicative
 
@@ -57,7 +56,8 @@
 
 type instance DUnit (Ellipse u) = u
 
-
+--------------------------------------------------------------------------------
+-- Affine trans
 
 mapEllipseCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u
 mapEllipseCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm
@@ -78,11 +78,17 @@
   translate dx dy = mapEllipseCTM (translate dx dy)
 
 
-runEllipse :: (u -> u -> ShapeCTM u  -> a) -> Ellipse u -> a
-runEllipse fn (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) = 
-    fn rx ry ctm
+--------------------------------------------------------------------------------
+-- Anchors
 
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> u -> Vec2 u) -> Ellipse u -> Point2 u
+runDisplaceCenter fn (Ellipse { ell_ctm = ctm
+                       , ell_rx  = rx
+                       , ell_ry  = ry }) = 
+    displaceCenter (fn rx ry) ctm
 
+
 -- | x_radius is the unit length.
 --
 scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t
@@ -90,12 +96,12 @@
 
 
 instance (Real u, Floating u) => CenterAnchor (Ellipse u) where
-  center = runEllipse $ \_ _ -> ctmCenter
+  center = runDisplaceCenter $ \_ _ -> V2 0 0
 
 
 instance (Real u, Floating u) => RadialAnchor (Ellipse u) where
-  radialAnchor theta = runEllipse $ \rx ry -> 
-    projectPoint $ scaleEll rx ry $ zeroPt .+^ avec theta rx
+  radialAnchor theta = runDisplaceCenter $ \rx ry -> 
+                         scaleEll rx ry $ avec theta rx
 
 
 instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where
@@ -112,23 +118,27 @@
   northwest = radialAnchor (0.75*pi)
 
 
-
+--------------------------------------------------------------------------------
+-- Construction
 
 -- | 'ellipse'  : @ x_radii * y_radii -> shape @
 --
-ellipse :: (Floating u, Ord u) => u -> u -> LocShape u (Ellipse u)
-ellipse rx ry = 
-    intoLocShape (mkEllipse rx ry) (mkEllipsePath rx ry)
+ellipse :: (Real u, Floating u, FromPtSize u, Ord u) 
+        => u -> u -> Shape u (Ellipse u)
+ellipse rx ry = makeShape (mkEllipse rx ry) (mkEllipsePath rx ry)
 
 
-mkEllipse :: Num u => u -> u -> LocCF u (Ellipse u)
-mkEllipse rx ry = promoteR1 $ \ctr -> 
-    pure $ Ellipse { ell_ctm = makeShapeCTM ctr, ell_rx = rx, ell_ry = ry }
+mkEllipse :: Num u => u -> u -> LocThetaCF u (Ellipse u)
+mkEllipse rx ry = promoteR2 $ \ctr theta -> 
+    pure $ Ellipse { ell_ctm = makeShapeCTM ctr theta
+                   , ell_rx  = rx
+                   , ell_ry  = ry 
+                   }
 
--- This is wrong...
---
-mkEllipsePath :: (Floating u, Ord u) => u -> u -> LocCF u (Path u)
-mkEllipsePath rx ry = promoteR1 $ \(P2 x y) -> 
-    pure $ traceCurvePoints $ map (translate x y . scaleEll rx ry) 
-                            $ bezierCircle 2 rx zeroPt
+
+mkEllipsePath :: (Real u, Floating u, FromPtSize u, Ord u) 
+              => u -> u -> LocThetaCF u (Path u)
+mkEllipsePath rx ry = promoteR2 $ \pt theta -> 
+    pure $ traceCurvePoints $ map (rotateAbout theta pt) 
+                            $ bezierEllipse rx ry pt
 
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,121 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.InvSemicircle
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Inverse semicircle. 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.InvSemicircle
+  ( 
+
+    InvSemicircle
+  , DInvSemicircle
+  , invsemicircle
+
+  ) where
+
+import Wumpus.Drawing.Shapes.Base
+import Wumpus.Drawing.Shapes.Semicircle
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+
+
+--------------------------------------------------------------------------------
+-- Inverse semicircle
+
+newtype InvSemicircle u = InvSemicircle { getInvSemicircle :: Semicircle u }
+
+  
+type DInvSemicircle = InvSemicircle Double
+
+type instance DUnit (InvSemicircle u) = u
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapSemicircle :: (Semicircle u -> Semicircle u) 
+              -> InvSemicircle u 
+              -> InvSemicircle u
+mapSemicircle f = InvSemicircle . f . getInvSemicircle
+
+instance Num u => Scale (InvSemicircle u) where
+  scale sx sy = mapSemicircle (scale sx sy)
+
+
+instance Rotate (InvSemicircle u) where
+  rotate ang = mapSemicircle (rotate ang)
+                  
+
+instance (Real u, Floating u) => RotateAbout (InvSemicircle u) where
+  rotateAbout ang pt = mapSemicircle (rotateAbout ang pt)
+
+
+instance Num u => Translate (InvSemicircle u) where
+  translate dx dy = mapSemicircle (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+runRotateAnchor :: (Real u, Floating u) 
+                => (Semicircle u -> Point2 u) -> InvSemicircle u -> Point2 u
+runRotateAnchor f (InvSemicircle a) = rotateAbout pi (center a) (f a)
+
+
+instance (Real u, Floating u) => CenterAnchor (InvSemicircle u) where
+  center = center . getInvSemicircle
+
+instance (Real u, Floating u) => ApexAnchor (InvSemicircle u) where
+  apex = runRotateAnchor apex
+
+instance (Real u, Floating u) => TopCornerAnchor (InvSemicircle u) where
+  topLeftCorner  = runRotateAnchor bottomRightCorner
+  topRightCorner = runRotateAnchor bottomLeftCorner
+
+instance (Real u, Floating u) => CardinalAnchor (InvSemicircle u) where
+  north = runRotateAnchor south
+  south = runRotateAnchor north
+  east  = runRotateAnchor west
+  west  = runRotateAnchor east
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor2 (InvSemicircle u) where
+  northeast = runRotateAnchor southwest
+  southeast = runRotateAnchor northwest
+  southwest = runRotateAnchor northeast
+  northwest = runRotateAnchor southeast
+
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    RadialAnchor (InvSemicircle u) where
+  radialAnchor theta = 
+    runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'invsemicircle'  : @ radius -> Shape @
+--
+invsemicircle :: (Real u, Floating u, FromPtSize u) 
+           => u -> Shape u (InvSemicircle u)
+invsemicircle radius = 
+    fmap InvSemicircle $ updatePathAngle (+ pi) $ semicircle radius
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,123 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.InvSemiellipse
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Inverse semiellipse. 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.InvSemiellipse
+  ( 
+
+    InvSemiellipse
+  , DInvSemiellipse
+  , invsemiellipse
+
+  ) where
+
+import Wumpus.Drawing.Shapes.Base
+import Wumpus.Drawing.Shapes.Semiellipse
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+
+
+--------------------------------------------------------------------------------
+-- Inverse semiellipse
+
+newtype InvSemiellipse u = InvSemiellipse { getInvSemiellipse :: Semiellipse u }
+
+  
+type DInvSemiellipse = InvSemiellipse Double
+
+type instance DUnit (InvSemiellipse u) = u
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapSemiellipse :: (Semiellipse u -> Semiellipse u) 
+              -> InvSemiellipse u 
+              -> InvSemiellipse u
+mapSemiellipse f = InvSemiellipse . f . getInvSemiellipse
+
+instance Num u => Scale (InvSemiellipse u) where
+  scale sx sy = mapSemiellipse (scale sx sy)
+
+
+instance Rotate (InvSemiellipse u) where
+  rotate ang = mapSemiellipse (rotate ang)
+                  
+
+instance (Real u, Floating u) => RotateAbout (InvSemiellipse u) where
+  rotateAbout ang pt = mapSemiellipse (rotateAbout ang pt)
+
+
+instance Num u => Translate (InvSemiellipse u) where
+  translate dx dy = mapSemiellipse (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+runRotateAnchor :: (Real u, Floating u) 
+                => (Semiellipse u -> Point2 u) -> InvSemiellipse u -> Point2 u
+runRotateAnchor f (InvSemiellipse a) = rotateAbout pi (center a) (f a)
+
+
+instance (Real u, Floating u) => CenterAnchor (InvSemiellipse u) where
+  center = center . getInvSemiellipse
+
+instance (Real u, Floating u, FromPtSize u) => 
+    ApexAnchor (InvSemiellipse u) where
+  apex = runRotateAnchor apex
+
+instance (Real u, Floating u) => TopCornerAnchor (InvSemiellipse u) where
+  topLeftCorner  = runRotateAnchor bottomRightCorner
+  topRightCorner = runRotateAnchor bottomLeftCorner
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor (InvSemiellipse u) where
+  north = runRotateAnchor south
+  south = runRotateAnchor north
+  east  = runRotateAnchor west
+  west  = runRotateAnchor east
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor2 (InvSemiellipse u) where
+  northeast = runRotateAnchor southwest
+  southeast = runRotateAnchor northwest
+  southwest = runRotateAnchor northeast
+  northwest = runRotateAnchor southeast
+
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    RadialAnchor (InvSemiellipse u) where
+  radialAnchor theta = 
+    runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'invsemiellipse'  : @ rx * ry -> Shape @
+--
+invsemiellipse :: (Real u, Floating u, FromPtSize u) 
+           => u -> u -> Shape u (InvSemiellipse u)
+invsemiellipse rx ry = 
+    fmap InvSemiellipse $ updatePathAngle (+ pi) $ semiellipse rx ry
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,147 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.InvTriangle
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Inverse version of the Triangle shape.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.InvTriangle
+  ( 
+
+    InvTriangle
+  , DInvTriangle
+  , invtriangle
+
+
+  ) where
+
+import Wumpus.Drawing.Shapes.Base
+import Wumpus.Drawing.Shapes.Triangle
+
+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+
+
+
+
+-- Datatype
+
+newtype InvTriangle u = InvTriangle { getInvTriangle :: Triangle u }
+
+
+
+type DInvTriangle = InvTriangle Double
+
+type instance DUnit (InvTriangle u) = u
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapTriangle :: (Triangle u -> Triangle u) -> InvTriangle u -> InvTriangle u
+mapTriangle f = InvTriangle . f . getInvTriangle 
+
+
+instance Num u => Scale (InvTriangle u) where
+  scale sx sy = mapTriangle (scale sx sy)
+
+
+instance Rotate (InvTriangle u) where
+  rotate ang = mapTriangle (rotate ang)
+                  
+
+instance (Real u, Floating u) => RotateAbout (InvTriangle u) where
+  rotateAbout ang pt = mapTriangle (rotateAbout ang pt)
+
+
+instance Num u => Translate (InvTriangle u) where
+  translate dx dy = mapTriangle (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- I think anchors should be rotated about the center by pi...
+
+runRotateAnchor :: (Real u, Floating u) 
+                => (Triangle u -> Point2 u) -> InvTriangle u -> Point2 u
+runRotateAnchor f (InvTriangle a) = rotateAbout pi (center a) (f a)
+
+
+instance (Real u, Floating u) => CenterAnchor (InvTriangle u) where
+  center = center . getInvTriangle
+
+
+-- apex is same on InvTriangle as regular triangle
+
+instance (Real u, Floating u) => ApexAnchor (InvTriangle u) where
+  apex = runRotateAnchor apex
+
+-- Top corners are bottom corners of the wrapped triangle.
+--
+instance (Real u, Floating u) => TopCornerAnchor (InvTriangle u) where
+  topLeftCorner  = runRotateAnchor bottomRightCorner
+  topRightCorner = runRotateAnchor bottomLeftCorner
+
+
+-- Use established points on the InvTrangle - don\'t delegate to 
+-- the base Triangle.
+--
+instance (Real u, Floating u) => SideMidpointAnchor (InvTriangle u) where
+  sideMidpoint n a = step (n `mod` 3) 
+    where
+      step 1 = midpoint (topRightCorner a) (topLeftCorner a)
+      step 2 = midpoint (topLeftCorner a)  (apex a)
+      step _ = midpoint (apex a)           (topRightCorner a)
+
+
+
+-- east and west should be parallel to the centroid.
+--
+
+instance (Real u, Floating u) => CardinalAnchor (InvTriangle u) where
+  north = runRotateAnchor south
+  south = runRotateAnchor north
+  east  = runRotateAnchor west
+  west  = runRotateAnchor east
+
+
+instance (Real u, Floating u) => CardinalAnchor2 (InvTriangle u) where
+  northeast = runRotateAnchor southwest
+  southeast = runRotateAnchor northwest
+  southwest = runRotateAnchor northeast
+  northwest = runRotateAnchor southeast
+
+
+
+instance (Real u, Floating u) => RadialAnchor (InvTriangle u) where
+  radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta)
+
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'invtriangle'  : @ top_base_width * height -> Triangle @
+--
+--
+invtriangle :: (Real u, Floating u, FromPtSize u)
+            => u -> u -> Shape u (InvTriangle u)
+invtriangle bw h = fmap InvTriangle $ updatePathAngle (+ pi) $ triangle bw h
+    
+
+
+
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,269 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Parallelogram
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Parallelogram.
+--
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Parallelogram
+  ( 
+
+    Parallelogram
+  , DParallelogram
+  , parallelogram
+  , zparallelogram
+
+
+  ) where
+
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Intersection
+import Wumpus.Basic.Geometry.Paths
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Control.Applicative
+
+
+
+
+--------------------------------------------------------------------------------
+-- Parallelogram
+
+-- | A Paralleogram.
+--
+data Parallelogram u = Parallelogram 
+      { pll_ctm         :: ShapeCTM u
+      , pll_base_width  :: !u
+      , pll_height      :: !u
+      , pll_base_l_ang  :: Radian
+      , pll_syn_props   :: SyntheticProps u
+      }
+
+
+-- | Note (center) is a line dropped from the center of the
+-- paralleogram.
+-- 
+-- > base_minor is the (center) to left corner.
+-- > base_major is the (center) to right corner.
+--
+data SyntheticProps u = SyntheticProps
+      { pll_base_minor  :: u
+      , pll_base_major  :: u
+      }
+
+
+type DParallelogram = Parallelogram Double
+
+type instance DUnit (Parallelogram u) = u
+
+
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Parallelogram u -> Parallelogram u
+mapCTM f = (\s i -> s { pll_ctm = f i }) <*> pll_ctm
+
+instance Num u => Scale (Parallelogram u) where
+  scale sx sy = mapCTM (scale sx sy)
+
+
+instance Rotate (Parallelogram u) where
+  rotate ang = mapCTM (rotate ang)
+                  
+
+instance (Real u, Floating u) => RotateAbout (Parallelogram u) where
+  rotateAbout ang pt = mapCTM (rotateAbout ang pt)
+
+
+instance Num u => Translate (Parallelogram u) where
+  translate dx dy = mapCTM (translate dx dy)
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- | 'runDisplaceCenter' : @ ( half_base_width
+--                           * half_height 
+--                           * base_minor
+--                           * base_major -> Vec ) * parallelogram -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> u -> u -> u -> Vec2 u) -> Parallelogram u -> Point2 u
+runDisplaceCenter fn (Parallelogram { pll_ctm        = ctm
+                                    , pll_base_width = bw
+                                    , pll_height     = h  
+                                    , pll_syn_props  = syn }) = 
+    displaceCenter (fn (0.5 * bw) (0.5 * h) 
+                       (pll_base_minor syn) (pll_base_major syn)) ctm
+
+
+
+instance (Real u, Floating u) => CenterAnchor (Parallelogram u) where
+  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0
+
+-- top anchors swap the base minor and major...
+--
+instance (Real u, Floating u) => TopCornerAnchor (Parallelogram u) where
+  topLeftCorner  = runDisplaceCenter $ \_ hh _ bmaj -> V2 (-bmaj) hh
+  topRightCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 bmin    hh
+
+instance (Real u, Floating u) => BottomCornerAnchor (Parallelogram u) where
+  bottomLeftCorner  = runDisplaceCenter $ \_ hh bmin _ -> V2 (-bmin) (-hh)
+  bottomRightCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 bmaj    (-hh)
+
+instance (Real u, Floating u) => SideMidpointAnchor (Parallelogram u) where
+  sideMidpoint n a = step (n `mod` 4) 
+    where
+      step 1 = midpoint (topRightCorner a)    (topLeftCorner a)
+      step 2 = midpoint (topLeftCorner a)     (bottomLeftCorner a)
+      step 3 = midpoint (bottomLeftCorner a)  (bottomRightCorner a)
+      step _ = midpoint (bottomRightCorner a) (topRightCorner a)
+
+
+
+instance (Real u, Floating u) => CardinalAnchor (Parallelogram u) where
+  north = runDisplaceCenter $ \_  hh _ _ -> V2 0 hh
+  south = runDisplaceCenter $ \_  hh _ _ -> V2 0 (-hh)
+  east  = runDisplaceCenter $ \hw _  _ _ -> V2 hw 0
+  west  = runDisplaceCenter $ \hw _  _ _ -> V2 (-hw) 0
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor2 (Parallelogram u) where
+  northeast = pllRadialAnchor (0.25*pi)
+  southeast = pllRadialAnchor (1.75*pi)
+  southwest = pllRadialAnchor (1.25*pi)
+  northwest = pllRadialAnchor (0.75*pi)
+
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+     RadialAnchor (Parallelogram u) where
+   radialAnchor = pllRadialAnchor
+
+
+-- TODO - update this to a quadrant function...
+--
+pllRadialAnchor :: (Real u, Floating u, FromPtSize u) 
+                => Radian -> Parallelogram u -> Point2 u
+pllRadialAnchor theta (Parallelogram { pll_ctm       = ctm
+                                     , pll_height    = h
+                                     , pll_syn_props = syn }) =
+    post $ findIntersect zeroPt theta $ polygonLineSegments ps
+  where 
+    ps   = pllPoints (pll_base_minor syn) (pll_base_major syn) h
+    post = \ans -> case ans of 
+                    Nothing       -> displaceCenter (V2 0 0) ctm
+                    Just (P2 x y) -> displaceCenter (V2 x y) ctm
+    
+
+--------------------------------------------------------------------------------
+-- Construction
+
+
+-- | 'parallelogram'  : @ width * height * bottom_left_ang -> Parallelogram @
+--
+--
+parallelogram :: (Real u, Floating u, FromPtSize u) 
+              => u -> u -> Radian -> Shape u (Parallelogram u)
+parallelogram bw h lang =
+    let props = synthesizeProps bw h lang 
+    in makeShape (mkParallelogram bw h lang props) 
+                 (mkParallelogramPath (pll_base_minor props) 
+                                      (pll_base_major props) h)
+
+
+-- | 'zparallelogram'  : @ base_width * height -> Parallelogram @
+--
+--
+zparallelogram :: (Real u, Floating u, FromPtSize u) 
+              => u -> u -> Shape u (Parallelogram u)
+zparallelogram bw h = parallelogram bw h ang
+  where
+    ang = d2r (60::Double)
+
+
+--------------------------------------------------------------------------------
+
+
+mkParallelogram :: (Real u, Fractional u) 
+                => u -> u -> Radian -> SyntheticProps u 
+                -> LocThetaCF u (Parallelogram u)
+mkParallelogram bw h lang props = promoteR2 $ \ctr theta -> 
+    pure $ Parallelogram { pll_ctm          = makeShapeCTM ctr theta
+                         , pll_base_width   = bw
+                         , pll_height       = h
+                         , pll_base_l_ang   = lang
+                         , pll_syn_props    = props
+                         }
+
+-- Note - expects ang value 0 < ang < 180, though does not check...
+-- 
+synthesizeProps :: Fractional u => u -> u -> Radian -> SyntheticProps u
+synthesizeProps bw h lang 
+    | lang == 0.5*pi = let hw = 0.5 * bw in SyntheticProps hw hw
+    | lang >  0.5*pi = less_ninety
+    | otherwise      = grtr_ninety
+  where
+    less_ninety = let extw            = h / (fromRadian $ tan lang)
+                      half_rect_width = 0.5 * (bw + extw)
+                  in SyntheticProps half_rect_width (half_rect_width - extw)
+
+    grtr_ninety = let extw            = h / (fromRadian $ tan (pi-lang))
+                      half_rect_width = 0.5 * (bw + extw)
+                  in SyntheticProps (half_rect_width - extw) half_rect_width
+
+                       
+
+
+
+mkParallelogramPath :: (Real u, Floating u, FromPtSize u) 
+                    => u -> u -> u -> LocThetaCF u (Path u)
+mkParallelogramPath bw_minor bw_major h = promoteR2 $ \ctr theta -> 
+    roundCornerShapePath $ map (rotateAbout theta ctr) 
+                         $ pllPath bw_minor bw_major h ctr
+
+
+pllPath :: (Real u, Floating u) 
+       => u -> u -> u -> LocCoordPath u
+pllPath bw_minor bw_major h (P2 x y) = [ bl, br, tr, tl ]
+  where
+    hh = 0.5 * h
+    bl = P2 (x - bw_minor) (y - hh)
+    br = P2 (x + bw_major) (y - hh)
+    tl = P2 (x - bw_major) (y + hh)     -- topleft subtracts major
+    tr = P2 (x + bw_minor) (y + hh)     -- topright adds minor
+
+
+pllPoints :: (Real u, Floating u) 
+          => u -> u -> u -> [Point2 u]
+pllPoints bw_minor bw_major h = [ bl, br, tr, tl ]
+  where
+    hh = 0.5 * h     
+    bl = P2 (-bw_minor) (-hh) 
+    br = P2   bw_major  (-hh)
+    tl = P2 (-bw_major) hh
+    tr = P2   bw_minor  hh
+
+
+
+
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
@@ -13,6 +13,9 @@
 -- Portability :  GHC
 --
 -- Rectangle shape.
+--
+-- Note - CardinalAnchor2 (northeast etc.) point to their radial 
+-- positions (this is a change since earlier versions).
 -- 
 --------------------------------------------------------------------------------
 
@@ -25,12 +28,12 @@
 
   ) where
 
-import Wumpus.Drawing.Geometry.Intersection
-import Wumpus.Drawing.Geometry.Paths
 import Wumpus.Drawing.Paths
 import Wumpus.Drawing.Shapes.Base
 
-import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Paths              -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Quadrant
+import Wumpus.Basic.Kernel
 
 import Wumpus.Core                              -- package: wumpus-core
 
@@ -39,8 +42,7 @@
 
 
 
---------------------------------------------------------------------------------
--- Rectangle
+-- Data type
 
 data Rectangle u = Rectangle 
       { rect_ctm    :: ShapeCTM u
@@ -55,82 +57,109 @@
 type instance DUnit (Rectangle u) = u
 
 
-mapRectangleCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u
-mapRectangleCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm
+--------------------------------------------------------------------------------
+-- Affine trans
 
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u
+mapCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm
+
 instance Num u => Scale (Rectangle u) where
-  scale sx sy = mapRectangleCTM (scale sx sy)
+  scale sx sy = mapCTM (scale sx sy)
 
 
 instance Rotate (Rectangle u) where
-  rotate ang = mapRectangleCTM (rotate ang)
+  rotate ang = mapCTM (rotate ang)
                   
 
 instance (Real u, Floating u) => RotateAbout (Rectangle u) where
-  rotateAbout ang pt = mapRectangleCTM (rotateAbout ang pt)
+  rotateAbout ang pt = mapCTM (rotateAbout ang pt)
 
 
 instance Num u => Translate (Rectangle u) where
-  translate dx dy = mapRectangleCTM (translate dx dy)
+  translate dx dy = mapCTM (translate dx dy)
 
+--------------------------------------------------------------------------------
+-- Anchors
 
 
 
-runRectangle :: (u -> u -> ShapeCTM u -> a) -> Rectangle u -> a
-runRectangle fn (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) = 
-   fn hw hh ctm
+-- | 'runDisplaceCenter' : @ ( half_width
+--                           * half_height -> Vec ) * rectangle -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> u -> Vec2 u) -> Rectangle u -> Point2 u
+runDisplaceCenter fn (Rectangle { rect_ctm = ctm
+                                , rect_hw  = hw
+                                , rect_hh  = hh }) = 
+   displaceCenter (fn hw hh) ctm
 
+
 instance (Real u, Floating u) => CenterAnchor (Rectangle u) where
-  center = runRectangle (\ _ _ -> ctmCenter)
+  center = runDisplaceCenter $ \_ _ -> V2 0 0
 
+instance (Real u, Floating u) => TopCornerAnchor (Rectangle u) where
+  topLeftCorner  = runDisplaceCenter $ \hw hh -> V2 (-hw) hh
+  topRightCorner = runDisplaceCenter $ \hw hh -> V2   hw  hh
+
+instance (Real u, Floating u) => BottomCornerAnchor (Rectangle u) where
+  bottomLeftCorner  = runDisplaceCenter $ \hw hh -> V2 (-hw) (-hh)
+  bottomRightCorner = runDisplaceCenter $ \hw hh -> V2   hw  (-hh)
+
+instance (Real u, Floating u) => SideMidpointAnchor (Rectangle u) where
+  sideMidpoint n a = step (n `mod` 4) 
+    where
+      step 1 = north a
+      step 2 = west a
+      step 3 = south a
+      step _ = east a
+
+
 instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where
-  north = runRectangle $ \_  hh -> projectPoint $ P2 0 hh
-  south = runRectangle $ \_  hh -> projectPoint $ P2 0 (-hh)
-  east  = runRectangle $ \hw _  -> projectPoint $ P2 hw 0
-  west  = runRectangle $ \hw _  -> projectPoint $ P2 (-hw) 0
+  north = runDisplaceCenter $ \_  hh -> V2 0 hh
+  south = runDisplaceCenter $ \_  hh -> V2 0 (-hh)
+  east  = runDisplaceCenter $ \hw _  -> V2 hw 0
+  west  = runDisplaceCenter $ \hw _  -> V2 (-hw) 0
 
 instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where
-  northeast = runRectangle $ \hw hh -> projectPoint $ P2 hw hh
-  southeast = runRectangle $ \hw hh -> projectPoint $ P2 hw (-hh)
-  southwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) (-hh)
-  northwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) hh
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
 
 
 instance (Real u, Floating u) => RadialAnchor (Rectangle u) where
-  radialAnchor theta = runRectangle $ \hw hh -> 
-    projectPoint $ rectangleIntersect hw hh theta
+  radialAnchor theta = runDisplaceCenter $ \hw hh -> 
+                          rectRadialVector hw hh theta
 
--- Note - the answer needs projecting with the CTM...
---
-rectangleIntersect :: (Real u, Floating u) 
-                   => u -> u -> Radian -> Point2 u
-rectangleIntersect hw hh theta = 
-    maybe zeroPt id $ findIntersect zeroPt theta $ rectangleLines zeroPt hw hh 
 
 
+--------------------------------------------------------------------------------
+-- Construction
 
+
 -- | 'rectangle'  : @ width * height -> shape @
 --
 rectangle :: (Real u, Floating u, FromPtSize u) 
-          => u -> u -> LocShape u (Rectangle u)
+          => u -> u -> Shape u (Rectangle u)
 rectangle w h = 
-    intoLocShape (mkRectangle (0.5*w) (0.5*h))
-                 (mkRectPath  (0.5*w) (0.5*h))
+    makeShape (mkRectangle (0.5*w) (0.5*h))
+              (mkRectPath  (0.5*w) (0.5*h))
 
 
-mkRectangle :: Num u => u -> u -> LocCF u (Rectangle u)
-mkRectangle hw hh = promoteR1 $ \ctr -> 
-    pure $ Rectangle { rect_ctm    = makeShapeCTM ctr
+mkRectangle :: Num u => u -> u -> LocThetaCF u (Rectangle u)
+mkRectangle hw hh = promoteR2 $ \ctr theta -> 
+    pure $ Rectangle { rect_ctm    = makeShapeCTM ctr theta
                      , rect_hw     = hw
                      , rect_hh     = hh
                      }
 
 
 mkRectPath :: (Real u, Floating u, FromPtSize u) 
-           => u -> u -> LocCF u (Path u)
-mkRectPath hw hh = promoteR1 $ \ctr -> 
+           => u -> u -> LocThetaCF u (Path u)
+mkRectPath hw hh = promoteR2 $ \ctr theta -> 
     let btm_left = displace (-hw) (-hh) ctr
-    in roundCornerShapePath $ rectangleCoordPath (2*hw) (2*hh) btm_left
+    in roundCornerShapePath $ map (rotateAbout theta ctr)
+                            $ rectangleCoordPath (2*hw) (2*hh) btm_left
     
 
 
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,235 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Semicircle
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Semicircle. 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Semicircle
+  ( 
+
+    Semicircle
+  , DSemicircle
+  , semicircle
+
+  ) where
+
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Intersection
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+import Control.Applicative
+
+
+
+--------------------------------------------------------------------------------
+-- Datatype
+
+data Semicircle u = Semicircle 
+      { sc_ctm          :: ShapeCTM u
+      , sc_radius       :: !u 
+      , sc_syn_props    :: SyntheticProps u
+      }
+
+
+
+-- | rect_width is the width of the (greater) enclosing rectangle.
+data SyntheticProps u = SyntheticProps
+      { sc_ctr_minor  :: u
+      , sc_ctr_major  :: u
+      }
+  
+type DSemicircle = Semicircle Double
+
+type instance DUnit (Semicircle u) = u
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semicircle u -> Semicircle u
+mapCTM f = (\s i -> s { sc_ctm = f i }) <*> sc_ctm
+
+instance Num u => Scale (Semicircle u) where
+  scale sx sy = mapCTM (scale sx sy)
+
+
+instance Rotate (Semicircle u) where
+  rotate ang = mapCTM (rotate ang)
+                  
+
+instance (Real u, Floating u) => RotateAbout (Semicircle u) where
+  rotateAbout ang pt = mapCTM (rotateAbout ang pt)
+
+
+instance Num u => Translate (Semicircle u) where
+  translate dx dy = mapCTM (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- | 'runDisplaceCenter' : @ ( radius
+--                           * height_minor 
+--                           * height_major -> Vec ) * semicircle -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> u -> u -> Vec2 u) -> Semicircle u -> Point2 u
+runDisplaceCenter fn (Semicircle { sc_ctm       = ctm
+                                 , sc_radius    = radius
+                                 , sc_syn_props = syn    }) = 
+    displaceCenter (fn radius (sc_ctr_minor syn) (sc_ctr_major syn)) ctm
+
+
+instance (Real u, Floating u) => CenterAnchor (Semicircle u) where
+  center = runDisplaceCenter $ \_ _ _ -> V2 0 0
+
+instance (Real u, Floating u) => ApexAnchor (Semicircle u) where
+  apex = runDisplaceCenter $ \_ _    cmaj -> V2 0  cmaj
+
+instance (Real u, Floating u) => BottomCornerAnchor (Semicircle u) where
+  bottomLeftCorner  = runDisplaceCenter $ \r hminor _  -> V2 (-r) (-hminor)
+  bottomRightCorner = runDisplaceCenter $ \r hminor _  -> V2  r   (-hminor)
+
+instance (Real u, Floating u) => CardinalAnchor (Semicircle u) where
+  north = apex
+  south = runDisplaceCenter $ \_ cmin _    -> V2 0  (-cmin)
+  east  = runDisplaceCenter $ \r cmin _    -> let x = pyth r cmin in V2 x 0
+  west  = runDisplaceCenter $ \r cmin _    -> let x = pyth r cmin in V2 (-x) 0
+
+-- | Use Pythagoras formula for working out the /east/ and /west/
+-- distances. A right-triangle is formed below the centroid, 
+-- radius is the hypotenuese, hminor is the other side.
+--
+pyth :: Floating u => u -> u -> u
+pyth hyp s1 = sqrt $ pow2 hyp - pow2 s1
+  where
+    pow2 = (^ (2::Int))
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor2 (Semicircle u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+
+
+instance (Real u, Floating u, FromPtSize u) => RadialAnchor (Semicircle u) where
+  radialAnchor theta = runDisplaceCenter (scRadialVec theta)
+
+
+scRadialVec :: (Real u, Floating u, Ord u, FromPtSize u)
+            => Radian -> u -> u -> u -> Vec2 u
+scRadialVec theta radius hminor _ = go theta
+  where
+    (lang,rang)                     = baselineRange radius hminor
+    (bctr, br, _, bl)               = constructionPoints radius hminor
+    plane                           = makePlane zeroPt theta
+    base_line                       = LineSegment bl br
+    left_curve                      = mkCurve radius half_pi bctr
+    right_curve                     = mkCurve radius 0 bctr
+    post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)
+    go a | lang <= a && a <= rang   = post $ interLinesegLine base_line plane 
+         | half_pi <= a && a < lang = post $ interCurveLine left_curve plane
+         | otherwise                = post $ interCurveLine right_curve plane
+
+
+mkCurve :: Floating u => u -> Radian -> Point2 u -> BezierCurve u
+mkCurve radius theta ctr = BezierCurve p0 p1 p2 p3
+  where
+    (BezierCurve p0 p1 p2 p3) = bezierMinorArc half_pi radius theta ctr
+
+
+
+-- | 'constructionPoints' : @ radius * hminor -> 
+--     (base_ctr, base_right, apex, base_left) @
+--
+-- Assumes centroid is (0,0).
+--
+constructionPoints :: Num u 
+                   => u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)
+constructionPoints radius hminor = (bctr, br, apx, bl)
+  where
+    bctr  = P2 0 (-hminor)
+    br    = bctr .+^ hvec radius
+    apx   = bctr .+^ vvec radius
+    bl    = bctr .-^ hvec radius
+
+
+
+
+-- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @
+--
+-- Find the angle range where a ray from the centroid will cross
+-- the baseline rather than cut the curve.
+--
+baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)
+baselineRange radius hminor = (lang, rang)
+  where
+    ang   = toRadian $ atan (radius / hminor)
+    lang  = (1.5*pi) - ang
+    rang  = (1.5*pi) + ang
+
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'semicircle'  : @ radius -> Shape @
+--
+semicircle :: (Real u, Floating u, FromPtSize u) 
+           => u -> Shape u (Semicircle u)
+semicircle radius = 
+    let props = synthesizeProps radius
+    in makeShape (mkSemicircle radius props) 
+                 (mkSemicirclePath radius (sc_ctr_minor props))
+          
+
+synthesizeProps :: Floating u => u -> SyntheticProps u
+synthesizeProps radius = 
+    SyntheticProps { sc_ctr_minor  = cminor
+                   , sc_ctr_major  = cmajor
+                   }
+  where
+    cminor = (4 * radius) / (3 * pi)
+    cmajor = radius - cminor
+
+
+mkSemicircle :: Num u => u -> SyntheticProps u -> LocThetaCF u (Semicircle u)
+mkSemicircle radius props = promoteR2 $ \ctr theta -> 
+    pure $ Semicircle { sc_ctm = makeShapeCTM ctr theta
+                      , sc_radius = radius
+                      , sc_syn_props = props 
+                      }
+
+
+
+-- TODO - need to check other shapes to see if the are deriving 
+-- the center properly...
+--
+mkSemicirclePath :: (Real u, Floating u, FromPtSize u) 
+                 => u -> u -> LocThetaCF u (Path u)
+mkSemicirclePath radius cminor = promoteR2 $ \pt theta ->
+    let ctr = displacePerpendicular (-cminor) theta pt
+    in pure $ traceCurvePoints $ bezierArcPoints pi radius theta ctr 
+
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,265 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Semiellipse
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Semiellipse.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Semiellipse
+  ( 
+
+    Semiellipse
+  , DSemiellipse
+  , semiellipse
+
+  ) where
+
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Intersection
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Control.Applicative
+
+
+
+--------------------------------------------------------------------------------
+-- Datatype
+
+data Semiellipse u = Semiellipse 
+      { se_ctm          :: ShapeCTM u
+      , se_rx           :: !u 
+      , se_ry           :: !u
+      , se_syn_props    :: SyntheticProps u
+      }
+
+
+
+-- | rect_width is the width of the (greater) enclosing rectangle.
+data SyntheticProps u = SyntheticProps
+      { se_ry_minor  :: u
+      , se_ry_major  :: u
+      }
+  
+type DSemiellipse = Semiellipse Double
+
+type instance DUnit (Semiellipse u) = u
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semiellipse u -> Semiellipse u
+mapCTM f = (\s i -> s { se_ctm = f i }) <*> se_ctm
+
+instance Num u => Scale (Semiellipse u) where
+  scale sx sy = mapCTM (scale sx sy)
+
+
+instance Rotate (Semiellipse u) where
+  rotate ang = mapCTM (rotate ang)
+                  
+
+instance (Real u, Floating u) => RotateAbout (Semiellipse u) where
+  rotateAbout ang pt = mapCTM (rotateAbout ang pt)
+
+
+instance Num u => Translate (Semiellipse u) where
+  translate dx dy = mapCTM (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+
+-- | 'runDisplaceCenter' : @ ( rx
+--                           * ry 
+--                           * ry_minor 
+--                           * ry_major -> Vec ) * semiellipse -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u) 
+                  => (u -> u -> u -> u -> Vec2 u) -> Semiellipse u -> Point2 u
+runDisplaceCenter fn (Semiellipse { se_ctm       = ctm
+                                  , se_rx        = rx
+                                  , se_ry        = ry
+                                  , se_syn_props = syn    }) = 
+    displaceCenter (fn rx ry (se_ry_minor syn) (se_ry_major syn)) ctm
+
+
+
+
+instance (Real u, Floating u) => CenterAnchor (Semiellipse u) where
+  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0
+
+instance (Real u, Floating u, FromPtSize u) => 
+    ApexAnchor (Semiellipse u) where
+  apex = runDisplaceCenter $ \_ _ _ ry_major -> V2 0 ry_major
+
+instance (Real u, Floating u) => BottomCornerAnchor (Semiellipse u) where
+  bottomLeftCorner  = runDisplaceCenter $ \rx _ ry_minor _  -> V2 (-rx) (-ry_minor)
+  bottomRightCorner = runDisplaceCenter $ \rx _ ry_minor _  -> V2  rx   (-ry_minor)
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor (Semiellipse u) where
+  north = apex
+  south = runDisplaceCenter $ \_ _ ry_minor _ -> V2 0 (-ry_minor)
+  east  = radialAnchor 0
+  west  = radialAnchor pi
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor2 (Semiellipse u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+
+instance (Real u, Floating u, FromPtSize u) => RadialAnchor (Semiellipse u) where
+  radialAnchor theta = runDisplaceCenter (seRadialVec theta)
+
+
+seRadialVec :: (Real u, Floating u, Ord u, FromPtSize u)
+            => Radian -> u -> u -> u -> u -> Vec2 u
+seRadialVec theta rx ry hminor _ = go theta
+  where
+    (lang,rang)                     = baselineRange rx hminor
+    (bctr, br, _, bl)               = constructionPoints rx ry hminor
+    plane                           = makePlane zeroPt theta
+    base_line                       = LineSegment bl br
+    (right_curve,left_curve)        = bezierSemiellipse rx ry bctr
+    post                            = maybe (V2 0 0) (\(P2 x y) -> V2 x y)
+    go a | lang <= a && a <= rang   = post $ interLinesegLine base_line plane 
+         | half_pi <= a && a < lang = post $ interCurveLine left_curve plane
+         | otherwise                = post $ interCurveLine right_curve plane
+
+
+
+-- | 'constructionPoints' : @ rx * ry * hminor -> 
+--     (base_ctr, base_right, apex, base_left) @
+--
+-- Assumes centroid is (0,0).
+--
+constructionPoints :: Num u 
+                   => u -> u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u)
+constructionPoints rx ry hminor = (bctr, br, apx, bl)
+  where
+    bctr  = P2 0 (-hminor)
+    br    = bctr .+^ hvec rx
+    apx   = bctr .+^ vvec ry
+    bl    = bctr .+^ hvec (-rx)
+
+
+
+
+-- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @
+--
+-- Find the angle range where a ray from the centroid will cross
+-- the baseline rather than cut the curve.
+--
+baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian)
+baselineRange rx hminor = (lang, rang)
+  where
+    ang   = toRadian $ atan (rx / hminor)
+    lang  = (1.5*pi) - ang
+    rang  = (1.5*pi) + ang
+
+
+
+--------------------------------------------------------------------------------
+-- Construction
+
+
+-- | 'semiellipse'  : @ x_radius * y_radius -> Shape @
+--
+semiellipse :: (Real u, Floating u, FromPtSize u) 
+            => u -> u -> Shape u (Semiellipse u)
+semiellipse rx ry = 
+    let props = synthesizeProps ry
+    in makeShape (mkSemiellipse rx ry props) 
+                 (mkSemiellipsePath rx ry (se_ry_minor props))
+          
+
+
+synthesizeProps :: Floating u => u -> SyntheticProps u
+synthesizeProps ry = 
+    SyntheticProps { se_ry_minor  = ry_minor
+                   , se_ry_major  = ry_major
+                   }
+  where
+    ry_minor = (4 * ry) / (3 * pi)
+    ry_major = ry - ry_minor
+
+
+mkSemiellipse :: Num u 
+              => u -> u -> SyntheticProps u -> LocThetaCF u (Semiellipse u)
+mkSemiellipse rx ry props = promoteR2 $ \ctr theta -> 
+    pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta
+                       , se_rx = rx
+                       , se_ry = ry
+                       , se_syn_props = props 
+                       }
+
+
+mkSemiellipsePath :: (Real u, Floating u, FromPtSize u) 
+                  => u -> u -> u -> LocThetaCF u (Path u)
+mkSemiellipsePath rx ry cminor = promoteR2 $ \pt theta ->
+    let ctr = displacePerpendicular (-cminor) theta pt
+    in pure $ traceCurvePoints $ map (rotateAbout theta ctr)
+                               $ bezierSemiellipsePoints rx ry ctr
+
+
+bezierSemiellipsePoints :: Floating u
+                        => u -> u -> Point2 u -> [Point2 u]
+bezierSemiellipsePoints rx ry pt = [ p0, c1,c2,p3, c4,c5,p6 ]
+  where 
+    (BezierCurve p0 c1 c2 p3, BezierCurve _ c4 c5 p6) = bezierSemiellipse rx ry pt
+
+
+-- For Geometry?
+
+-- | Generate the bezier arcs for quadrants I and II. 
+--
+-- Drawing is expected to proceed CCW.
+-- 
+-- Note - Point is the (full) ellipse center.
+--
+bezierSemiellipse :: Floating u
+                  => u -> u -> Point2 u -> (BezierCurve u, BezierCurve u)
+bezierSemiellipse rx ry (P2 x y) = 
+    (BezierCurve p00 c01 c02 p03, BezierCurve p03 c04 c05 p06)
+  where
+    lrx = rx * kappa
+    lry = ry * kappa
+    p00 = P2 (x + rx) y
+    c01 = p00 .+^ vvec lry
+    c02 = p03 .+^ hvec lrx
+
+    p03 = P2 x (y + ry) 
+    c04 = p03 .+^ hvec (-lrx)
+    c05 = p06 .+^ vvec lry
+
+    p06 = P2 (x - rx) y
+
+
+
+kappa :: Floating u => u
+kappa = 4 * ((sqrt 2 - 1) / 3)
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,281 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Trapezium
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Trapezium.
+--
+-- Note cardinal anchors correspond directly to the compass 
+-- positions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Trapezium
+  ( 
+
+    Trapezium
+  , DTrapezium
+  , trapezium
+  , ztrapezium
+
+
+  ) where
+
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Geometry.Intersection       -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Paths
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Data.VectorSpace                         -- package: vector-space
+
+import Control.Applicative
+
+
+
+
+--------------------------------------------------------------------------------
+-- Trapezium
+
+-- | A trapezium.
+--
+data Trapezium u = Trapezium 
+      { tz_ctm          :: ShapeCTM u
+      , tz_base_width   :: !u
+      , tz_height       :: !u
+      , tz_base_l_ang   :: Radian
+      , tz_base_r_ang   :: Radian
+      }
+
+
+type DTrapezium = Trapezium Double
+
+type instance DUnit (Trapezium u) = u
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Trapezium u -> Trapezium u
+mapCTM f = (\s i -> s { tz_ctm = f i }) <*> tz_ctm
+
+instance Num u => Scale (Trapezium u) where
+  scale sx sy = mapCTM (scale sx sy)
+
+
+instance Rotate (Trapezium u) where
+  rotate ang = mapCTM (rotate ang)
+                  
+
+instance (Real u, Floating u) => RotateAbout (Trapezium u) where
+  rotateAbout ang pt = mapCTM (rotateAbout ang pt)
+
+
+instance Num u => Translate (Trapezium u) where
+  translate dx dy = mapCTM (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- | 'runDisplaceCenter' : @ ( half_base_width 
+--                           * half_height
+--                           * left_base_ang 
+--                           * right_base_ang -> Vec ) * trapzium -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> u -> Radian -> Radian -> Vec2 u) 
+                  -> Trapezium u -> Point2 u
+runDisplaceCenter fn (Trapezium { tz_ctm          = ctm
+                                , tz_base_width   = bw
+                                , tz_height       = h
+                                , tz_base_l_ang   = lang
+                                , tz_base_r_ang   = rang }) =
+    displaceCenter (fn (0.5 * bw) (0.5 * h) lang rang) ctm
+
+instance (Real u, Floating u) => CenterAnchor (Trapezium u) where
+  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0
+
+
+
+instance (Real u, Floating u) => BottomCornerAnchor (Trapezium u) where
+  bottomLeftCorner  = runDisplaceCenter $ \hbw hh _ _  -> V2 (-hbw) (-hh)
+  bottomRightCorner = runDisplaceCenter $ \hbw hh _ _  -> V2  hbw   (-hh)
+
+
+instance (Real u, Floating u) => TopCornerAnchor (Trapezium u) where
+  topLeftCorner  = runDisplaceCenter $ \hbw hh lang _  -> 
+                     let vbase = V2 (-hbw) (-hh)
+                         vup   = leftSideVec (2*hh) lang 
+                     in vbase ^+^ vup
+  topRightCorner = runDisplaceCenter $ \hbw hh _ rang  ->
+                     let vbase = V2  hbw   (-hh)
+                         vup   = rightSideVec (2*hh) rang
+                     in vbase ^+^ vup
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    SideMidpointAnchor (Trapezium u) where
+  sideMidpoint n a = step (n `mod` 4) 
+    where
+      step 1 = north a
+      step 2 = west a
+      step 3 = south a
+      step _ = east a
+
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor (Trapezium u) where
+  north = runDisplaceCenter $ \_ hh _ _ -> V2 0 hh
+  south = runDisplaceCenter $ \_ hh _ _ -> V2 0 (-hh)
+  east  = tzRadialAnchor 0
+  west  = tzRadialAnchor pi
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    CardinalAnchor2 (Trapezium u) where
+  northeast = tzRadialAnchor (0.25*pi)
+  southeast = tzRadialAnchor (1.75*pi)
+  southwest = tzRadialAnchor (1.25*pi)
+  northwest = tzRadialAnchor (0.75*pi)
+
+
+
+instance (Real u, Floating u, FromPtSize u) => 
+    RadialAnchor (Trapezium u) where
+  radialAnchor = tzRadialAnchor
+
+-- TODO - update this to a quadrant function...
+--
+tzRadialAnchor :: (Real u, Floating u, FromPtSize u) 
+               => Radian -> Trapezium u -> Point2 u
+tzRadialAnchor theta (Trapezium { tz_ctm        = ctm
+                                , tz_base_width = bw
+                                , tz_height     = h
+                                , tz_base_l_ang = lang
+                                , tz_base_r_ang = rang }) =
+    post $ findIntersect zeroPt theta $ polygonLineSegments ps
+  where 
+    ps   = tzPoints bw h lang rang
+    post = \ans -> case ans of 
+                    Nothing       -> displaceCenter (V2 0 0) ctm
+                    Just (P2 x y) -> displaceCenter (V2 x y) ctm
+    
+    
+--------------------------------------------------------------------------------
+-- Construction
+
+
+-- | 'trapezium'  : @ base_width * height * bottom_left_ang * 
+--     bottom_right_ang -> Shape @
+--
+--
+trapezium :: (Real u, Floating u, FromPtSize u) 
+          => u -> u -> Radian -> Radian -> Shape u (Trapezium u)
+trapezium bw h lang rang = 
+    makeShape (mkTrapezium bw h lang rang) (mkTrapeziumPath bw h lang rang)
+
+
+-- | 'ztrapezium'  : @ base_width * height -> Trapezium @
+--
+--
+ztrapezium :: (Real u, Floating u, FromPtSize u) 
+           => u -> u -> Shape u (Trapezium u)
+ztrapezium bw h = trapezium bw h ang ang
+  where
+    ang = d2r (60::Double)
+
+
+--------------------------------------------------------------------------------
+
+
+mkTrapezium :: (Real u, Fractional u) 
+            => u -> u -> Radian -> Radian -> LocThetaCF u (Trapezium u)
+mkTrapezium bw h lang rang = promoteR2 $ \ctr theta -> 
+    pure $ Trapezium { tz_ctm           = makeShapeCTM ctr theta
+                     , tz_base_width    = bw
+                     , tz_height        = h
+                     , tz_base_l_ang    = lang
+                     , tz_base_r_ang    = rang
+                     }
+
+
+mkTrapeziumPath :: (Real u, Floating u, FromPtSize u) 
+                => u -> u -> Radian -> Radian -> LocThetaCF u (Path u)
+mkTrapeziumPath bw h lang rang = promoteR2 $ \ctr theta -> 
+    roundCornerShapePath $ map (rotateAbout theta ctr) 
+                         $ tzPath bw h lang rang ctr
+
+
+tzPath :: (Real u, Floating u) 
+       => u -> u -> Radian -> Radian -> LocCoordPath u
+tzPath bw h lang rang (P2 x y) = [ bl, br, tr, tl ]
+  where
+    half_base = 0.5 * bw
+    hh        = 0.5 * h
+    br        = P2 (x + half_base ) (y - hh)
+    bl        = P2 (x - half_base ) (y - hh)
+    tr        = displaceVec (rightSideVec h rang) br
+    tl        = displaceVec (leftSideVec h lang) bl
+
+
+tzPoints :: (Real u, Floating u) 
+               => u -> u -> Radian -> Radian -> [Point2 u]
+tzPoints bw h lang rang = [ bl, br, tr, tl ]
+  where
+    half_base = 0.5 * bw
+    hh        = 0.5 * h
+    bl        = P2 (-half_base) (-hh)
+    br        = P2 half_base    (-hh)
+    tr        = displaceVec (rightSideVec h rang) br
+    tl        = displaceVec (leftSideVec h lang) bl
+
+
+
+-- | Calculate the vector that produces the upper-left point given
+-- the lower-left point.
+--
+-- Note - expects ang value 0 < ang < 180, though does not check...
+-- 
+leftSideVec :: Floating u => u -> Radian -> Vec2 u
+leftSideVec h lang | lang <  0.5*pi = less_ninety
+                   | lang == 0.5*pi = vvec h
+                   | otherwise      = grtr_ninety
+  where
+    less_ninety = let dist = h / (fromRadian $ sin lang) in avec lang dist
+    grtr_ninety = let theta = lang - (0.5*pi) 
+                      dist  = h / (fromRadian $ cos theta) 
+                  in avec lang dist
+
+
+
+
+-- | Calculate the vector that produces the upper-right point given
+-- the lower-right point.
+--
+-- Note - expects ang value 0 < ang < 180, though does not check...
+-- 
+rightSideVec :: Floating u => u -> Radian -> Vec2 u
+rightSideVec h rang | rang <  0.5*pi = less_ninety
+                    | rang == 0.5*pi = vvec h
+                    | otherwise      = grtr_ninety
+  where
+    less_ninety = let dist  = h / (fromRadian $ sin rang) in avec (pi - rang) dist
+    grtr_ninety = let theta = rang - (0.5*pi) 
+                      dist  = h / (fromRadian $ cos theta) 
+                  in avec (pi - rang) dist
+
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,226 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Shapes.Triangle
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Isosceles triangle.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Shapes.Triangle
+  ( 
+
+    Triangle
+  , DTriangle
+  , triangle
+
+  ) where
+
+import Wumpus.Drawing.Paths
+import Wumpus.Drawing.Shapes.Base
+
+import Wumpus.Basic.Geometry.Base               -- package: wumpus-basic
+import Wumpus.Basic.Geometry.Quadrant
+import Wumpus.Basic.Geometry.Paths
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import Control.Applicative
+
+
+
+
+-- Datatype
+
+-- | An isosceles triangle, oriented /upwards/.
+--
+data Triangle u = Triangle 
+      { tri_ctm         :: ShapeCTM u
+      , tri_height      :: !u
+      , tri_base_width  :: !u
+      , tri_syn_props   :: SyntheticProps u
+      }
+      
+data SyntheticProps u = SyntheticProps
+      { tri_hmajor      :: u           
+      , tri_hminor      :: u
+      , tri_base_ang    :: Radian
+      , tri_apex_ang    :: Radian
+      }
+
+
+type DTriangle = Triangle Double
+
+type instance DUnit (Triangle u) = u
+
+
+--------------------------------------------------------------------------------
+-- Affine trans
+
+mapTriangleCTM :: (ShapeCTM u -> ShapeCTM u) 
+               -> Triangle u -> Triangle u
+mapTriangleCTM f = (\s i -> s { tri_ctm = f i }) <*> tri_ctm
+
+instance Num u => Scale (Triangle u) where
+  scale sx sy = mapTriangleCTM (scale sx sy)
+
+
+instance Rotate (Triangle u) where
+  rotate ang = mapTriangleCTM (rotate ang)
+                  
+
+instance (Real u, Floating u) => RotateAbout (Triangle u) where
+  rotateAbout ang pt = mapTriangleCTM (rotateAbout ang pt)
+
+
+instance Num u => Translate (Triangle u) where
+  translate dx dy = mapTriangleCTM (translate dx dy)
+
+
+--------------------------------------------------------------------------------
+-- Anchors
+
+-- | 'runDisplaceCenter' : @ ( half_base_width 
+--                           * height_minor 
+--                           * height_major 
+--                           * base_ang -> Vec ) * traingle -> Point @
+--
+runDisplaceCenter :: (Real u, Floating u)
+                  => (u -> u -> u -> Radian -> Vec2 u) -> Triangle u -> Point2 u
+runDisplaceCenter fn (Triangle { tri_ctm        = ctm
+                               , tri_base_width = bw
+                               , tri_syn_props  = syn }) =  
+    displaceCenter (fn (0.5*bw) hminor hmajor base_ang) ctm
+  where
+    hminor   = tri_hminor syn        
+    hmajor   = tri_hmajor syn
+    base_ang = tri_base_ang syn
+
+
+
+instance (Real u, Floating u) => CenterAnchor (Triangle u) where
+  center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0
+
+
+instance (Real u, Floating u) => ApexAnchor (Triangle u) where
+  apex = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj
+
+
+instance (Real u, Floating u) => BottomCornerAnchor (Triangle u) where
+  bottomLeftCorner  = runDisplaceCenter $ \hbw hmin _ _  -> V2 (-hbw) (-hmin)
+  bottomRightCorner = runDisplaceCenter $ \hbw hmin _ _  -> V2  hbw   (-hmin)
+
+
+-- east and west should be parallel to the centroid.
+--
+
+instance (Real u, Floating u) => CardinalAnchor (Triangle u) where
+  north = runDisplaceCenter $ \_   _    hmaj _    -> V2 0 hmaj
+  south = runDisplaceCenter $ \_   hmin _    _    -> V2 0 (-hmin)
+  east  = runDisplaceCenter $ \hbw hmin _    ang  -> findEast hbw hmin ang
+  west  = runDisplaceCenter $ \hbw hmin _    ang  -> findWest hbw hmin ang
+
+
+instance (Real u, Floating u) => SideMidpointAnchor (Triangle u) where
+  sideMidpoint n a = step (n `mod` 3) 
+    where
+      step 1 = midpoint (apex a) (bottomLeftCorner a)
+      step 2 = midpoint (bottomLeftCorner a) (bottomRightCorner a)
+      step _ = midpoint (bottomRightCorner a) (apex a)
+
+
+findEast :: Fractional u => u -> u -> Radian -> Vec2 u
+findEast half_base_width hminor base_ang = V2 xdist 0
+  where
+    b1    = hminor / (fromRadian $ tan base_ang)
+    xdist = half_base_width - b1
+
+findWest :: Fractional u => u -> u -> Radian -> Vec2 u
+findWest hbw hm ang = let (V2 xdist 0) = findEast hbw hm ang in V2 (-xdist) 0 
+
+
+
+instance (Real u, Floating u) => CardinalAnchor2 (Triangle u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+
+instance (Real u, Floating u) => RadialAnchor (Triangle u) where
+  radialAnchor theta = runDisplaceCenter $ \hbw hmin hmaj _ -> 
+                         triangleRadialVector hbw hmin hmaj theta
+       
+    
+--------------------------------------------------------------------------------
+-- Construction
+
+-- | 'triangle'  : @ base_width * height -> Shape @
+--
+--
+triangle :: (Real u, Floating u, FromPtSize u) 
+         => u -> u -> Shape u (Triangle u)
+triangle bw h =
+    let props  = synthesizeProps bw h
+        hminor = tri_hminor props
+        hmajor = tri_hmajor props
+    in makeShape (mkTriangle bw h props) (mkTrianglePath bw hminor hmajor)
+
+
+
+
+
+mkTriangle :: (Real u, Fractional u) 
+           => u -> u -> SyntheticProps u -> LocThetaCF u (Triangle u)
+mkTriangle bw h props = promoteR2 $ \ctrd theta -> 
+    pure $ Triangle { tri_ctm        = makeShapeCTM ctrd theta
+                    , tri_base_width = bw
+                    , tri_height     = h 
+                    , tri_syn_props  = props
+                    }
+
+
+synthesizeProps :: (Real u, Fractional u) => u -> u -> SyntheticProps u
+synthesizeProps bw h = 
+    SyntheticProps { tri_hmajor      = hmajor
+                   , tri_hminor      = hminor
+                   , tri_base_ang    = base_ang
+                   , tri_apex_ang    = apex_ang
+                   }
+  where
+    half_base   = 0.5 * bw 
+    hminor      = h / 3
+    hmajor      = 2 * hminor 
+    base_ang    = atan $ toRadian (h / half_base)
+    apex_ang    = 2 * ((pi/4) - base_ang)
+
+
+
+mkTrianglePath :: (Real u, Floating u, FromPtSize u) 
+               => u -> u -> u -> LocThetaCF u (Path u)
+mkTrianglePath bw hminor hmajor = promoteR2 $ \ctr theta -> 
+    roundCornerShapePath $ map (rotateAbout theta ctr) 
+                         $ trianglePath bw hminor hmajor ctr
+
+
+trianglePath :: (Real u, Floating u) 
+             => u -> u -> u -> LocCoordPath u
+trianglePath bw hminor hmajor (P2 x y) = [br, apx, bl]
+  where
+    half_base = 0.5 * bw
+    br        = P2 (x + half_base ) (y - hminor)
+    apx       = P2 x (y + hmajor)
+    bl        = P2 (x - half_base ) (y - hminor)
+
diff --git a/src/Wumpus/Drawing/Text/Base.hs b/src/Wumpus/Drawing/Text/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Text/Base.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Text.Base
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC
+--
+-- Helpers for working with measured / advance text.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Text.Base
+  ( 
+
+    advtext
+  , textVector
+  , charVector
+
+  , multilineHeight
+  , textObjectPos
+  , borderedTextObjectPos
+
+  , centerToBaseline
+  , centerSpinePoints
+
+  ) where
+
+import Wumpus.Drawing.Chains
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+import Wumpus.Core.Text.GlyphIndices
+
+import Data.VectorSpace                         -- package: vector-space
+
+import Control.Applicative
+import Data.Char
+import qualified Data.Map               as Map
+import Data.Maybe 
+
+
+-- | Single line text, returning its advance vector.
+--
+advtext :: FromPtSize u => EscapedText -> AdvGraphic u
+advtext esc = lift0R1 (textVector esc) >>= \v -> replaceAns v $ escapedline esc
+
+
+-- kernchar versions to do...
+
+
+textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u)
+textVector esc = 
+    cwLookupTable >>= \table -> 
+       let cs = destrEscapedText id esc 
+       in return $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs
+     
+charVector :: FromPtSize u => EscapedChar -> DrawingInfo (AdvanceVec u)
+charVector ch = cwLookupTable >>= \table -> return $ charWidth table ch
+   
+
+-- | This is outside the Drawing context as we don\'t want to get
+-- the @cwLookupTable@ for every char.
+--
+charWidth :: FromPtSize u 
+          => CharWidthTable u -> EscapedChar -> AdvanceVec u
+charWidth fn (CharLiteral c) = fn $ ord c
+charWidth fn (CharEscInt i)  = fn i
+charWidth fn (CharEscName s) = fn ix
+  where
+    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices
+
+
+--------------------------------------------------------------------------------
+-- Measurement and start points for multiline text
+
+
+-- | Height of multiline text is cap_height to descender for the 
+-- first line, then baseline-to-baseline span for the remaining
+-- lines.
+--
+multilineHeight :: (Real u, Floating u, FromPtSize u) 
+                   => Int -> DrawingInfo u
+multilineHeight line_count 
+    | line_count < 1  = return 0
+    | line_count == 1 = glyphVerticalSpan
+    | otherwise       = fn <$> glyphVerticalSpan <*> baselineSpacing
+  where
+    fn h1 bspan = let rest_spans = bspan * fromIntegral (line_count - 1)
+                  in h1 + rest_spans
+
+
+
+-- | Height of multiline text is cap_height to descender for the 
+-- first line, then baseline-to-baseline span for the remaining
+-- lines.
+-- 
+-- The answer is in centerform, i.e.:
+--
+-- > ObjectPos  half_width  half_width  half_height  half_height 
+--
+textObjectPos :: (Real u, Floating u, FromPtSize u) 
+                   => Int -> u -> DrawingInfo (ObjectPos u)
+textObjectPos line_count w =
+    fmap (0.5*) (multilineHeight line_count) >>= \hh ->
+    let hw    = 0.5 * w
+    in return $ ObjectPos hw hw hh hh 
+
+
+-- | Variant of 'textObjectPos' where the calculation includes
+-- margins around all four sides of the enclosing rectangle.
+--
+-- Margin sizes are taken from the 'text_margin' field in the 
+-- 'DrawingContext'.
+--
+borderedTextObjectPos :: (Real u, Floating u, FromPtSize u) 
+                      => Int -> u -> DrawingInfo (ObjectPos u)
+borderedTextObjectPos line_count w =
+    multilineHeight line_count >>= \h ->
+    getTextMargin >>= \(xsep,ysep) -> 
+    let hw    = (2 * xsep) + (0.5 * w)
+        hh    = (2 * ysep) + (0.5 * h)
+    in return $ ObjectPos hw hw hh hh 
+
+
+
+-- | Calculate the distance from the center of a one-line textbox 
+-- to the baseline. Note the height of a textbox is @vspan@ which 
+-- is cap_height + descender
+--
+centerToBaseline :: (Fractional u, FromPtSize u) => DrawingInfo u
+centerToBaseline = 
+    (\ch vspan -> ch - 0.5 * vspan) <$> glyphCapHeight <*> glyphVerticalSpan
+
+-- | All drawing is done on a spine that plots points from the 
+-- first line of text. The spine is calculated from its center and
+-- has to account for the inclination.
+--
+centerSpinePoints :: Floating u 
+                  => Int -> Radian -> LocChain u
+centerSpinePoints n theta
+    | n <= 1    = promoteR1 $ \ctr -> return [ctr]
+    | otherwise = promoteR1 $ \ctr -> 
+                    baselineSpacing >>= \h1 -> 
+                    let dist_top = h1 * centerCount n
+                        top      = thetaNorthwards dist_top theta ctr    
+                    in return (take n $ iterate (thetaSouthwards h1 theta) top)
+
+
+-- | Count the steps from the center to an end:
+--
+-- >
+-- > 1 = 0     .
+-- > 2 = 0.5   .__.
+-- > 3 = 1     .__.__.
+-- > 4 = 1.5   .__.__.__.
+-- >
+--
+centerCount :: Fractional u => Int -> u
+centerCount i = (fromIntegral i) / 2 - 0.5
diff --git a/src/Wumpus/Drawing/Text/CatText.hs b/src/Wumpus/Drawing/Text/CatText.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Drawing/Text/CatText.hs
@@ -0,0 +1,207 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Text.Text
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC
+--
+-- Left-to-right text.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Drawing.Text.CatText
+  ( 
+   
+    CatText
+  , leftAlign
+  , centerAlign
+  , rightAlign
+
+  , blank
+  , space
+  , string
+  , (<>)
+  , (<+>) 
+
+  , fontColour
+
+  ) where
+
+import Wumpus.Drawing.Chains
+import Wumpus.Drawing.Text.Base
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl )
+import qualified Wumpus.Basic.Utils.JoinList as JL
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.Char ( ord )
+
+-- Need to know line width (horizontal) and line count (vertical) 
+-- to render...
+--
+-- Can obviously access line count if we avoid avoid operators 
+-- for vertical composition operator and delegate it to rendering
+-- instead:
+--
+-- > rightAlign :: [CatText u] -> PosImage u (BoundingBox u)
+--
+
+-- A CatPrim returns a drawing function (AdvGraphic) to be used
+-- drawing final rendering.
+--
+type CatPrim u = CF (u, AdvGraphic u)
+
+newtype CatText u = CatText { getCatText :: JoinList (CatPrim u) }
+
+
+
+-- | 'HMove' : @ half_max_width * line_width -> Horizontal_Displacement @
+--
+type HMove u = u -> u -> u
+
+leftAMove :: Num u => HMove u
+leftAMove half_max _ = negate half_max
+ 
+centerAMove :: Fractional u => HMove u
+centerAMove _ elt_w = negate $ 0.5 * elt_w
+
+rightAMove :: Num u => HMove u
+rightAMove half_max elt_w = half_max - elt_w
+
+
+
+leftAlign :: (Real u, FromPtSize u, Floating u) 
+          => [CatText u] -> PosImage u (BoundingBox u)
+leftAlign = drawMulti leftAMove
+
+centerAlign :: (Real u, FromPtSize u, Floating u) 
+            => [CatText u] -> PosImage u (BoundingBox u)
+centerAlign = drawMulti centerAMove
+
+rightAlign :: (Real u, FromPtSize u, Floating u) 
+           => [CatText u] -> PosImage u (BoundingBox u)
+rightAlign = drawMulti rightAMove
+
+
+
+drawMulti :: (Real u, FromPtSize u, Floating u) 
+          => HMove u -> [CatText u] -> PosImage u (BoundingBox u)
+drawMulti moveF xs = promoteR2 $ \start rpos -> 
+    evalAllLines xs                     >>= \all_lines -> 
+    centerToBaseline                    >>= \down -> 
+    borderedTextObjectPos line_count (fst all_lines) >>= \opos ->
+    let chn   = centerSpinePoints line_count 0 
+        gs    = positionHLines moveF down all_lines 
+        gf    = unchainZip emptyLocGraphic gs chn
+        posG  = makePosImage opos gf
+        bbox  = objectPosBounds start rpos opos
+    in replaceAns bbox $ atStartPos posG start rpos     
+  where
+    line_count    = length xs
+
+positionHLines :: Fractional u 
+               => HMove u -> u -> (u,[(u, AdvGraphic u)]) -> [LocGraphic u]
+positionHLines mkH down (max_w,xs) = map fn xs
+  where
+    half_max       = 0.5 * max_w
+    moveF w1       = let v = vec (mkH half_max w1) (-down) 
+                     in moveStart $ displaceVec v 
+    fn (elt_w, gf) = ignoreAns $ moveF elt_w $ gf
+
+
+evalAllLines :: (Num u, Ord u) 
+             => [CatText u] -> DrawingInfo (u, [(u, AdvGraphic u)])
+evalAllLines = fmap post . mapM evalLine
+  where
+    post xs = let mx = foldr (\(a,_) x -> max a x) 0 xs in (mx,xs)
+            
+
+
+
+
+evalLine :: Num u => CatText u -> DrawingInfo (u, AdvGraphic u)
+evalLine ct = case viewl $ getCatText ct of
+    EmptyL -> return (0,  replaceAns (hvec 0) $ emptyLocGraphic)
+    af :< rest -> af >>= \a -> go a (viewl rest)
+  where
+    go acc     EmptyL     = return acc
+    go (dx,af) (mf :< ms) = let moveF = moveStart (displaceH dx)
+                            in mf >>= \(u,gf) -> 
+                               go (dx+u, af `oplus` moveF gf) (viewl ms)
+
+
+
+
+
+-- | Build a blank CatText with no output and a 0 width vector.
+--
+blank :: Num u => CatText u
+blank = catOne $ return (0, replaceAns (hvec 0) $ emptyLocGraphic)
+
+-- | Note - a space character is not draw in the output, instead 
+-- 'space' advances the width vector by the width of a space in 
+-- the current font.
+--
+space :: FromPtSize u => CatText u
+space = catOne $ 
+   charVector (CharEscInt $ ord ' ') >>= \v -> 
+   return (advanceH v, replaceAns v $ emptyLocGraphic)
+
+-- | Build a CatText from a string.
+--
+string :: FromPtSize u => String -> CatText u
+string = catOne . stringPrim
+
+
+infixr 6 <>, <+>
+
+-- | Concatenate two CatTexts separated with no spacing.
+--
+(<>) :: CatText u -> CatText u -> CatText u
+a <> b = CatText $ JL.join (getCatText a) (getCatText b) 
+
+
+-- | Concatenate two CatTexts separated with a space.
+--
+(<+>) :: FromPtSize u => CatText u -> CatText u -> CatText u
+a <+> b = a <> space <> b 
+
+
+
+-- Note - @fill@ combinators cf. @wl-pprint@ (but left and right) 
+-- will be very useful.
+--
+-- Also PosImages can be inlined in text...
+--
+
+catOne :: CatPrim u -> CatText u
+catOne = CatText . JL.one 
+
+
+stringPrim :: FromPtSize u => String -> CatPrim u
+stringPrim = escapedPrim . escapeString
+
+escapedPrim :: FromPtSize u => EscapedText -> CatPrim u
+escapedPrim esc = textVector esc >>= \v -> 
+                  return (vector_x v, replaceAns v $ escapedline esc)
+
+
+catMap :: (AdvGraphic u -> AdvGraphic u) -> CatText u -> CatText u
+catMap f = CatText . fmap (fmap (\(u,ag) -> (u, f $ ag))) . getCatText
+
+catlocal :: DrawingContextF -> CatText u -> CatText u
+catlocal fn = catMap (localize fn)
+
+
+fontColour :: RGBi -> CatText u -> CatText u
+fontColour rgb = catlocal (strokeColour rgb)
+
+
diff --git a/src/Wumpus/Drawing/Text/LRText.hs b/src/Wumpus/Drawing/Text/LRText.hs
--- a/src/Wumpus/Drawing/Text/LRText.hs
+++ b/src/Wumpus/Drawing/Text/LRText.hs
@@ -4,385 +4,285 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Drawing.Text.LRText
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2011
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
 -- Stability   :  unstable
 -- Portability :  GHC
 --
--- Left-to-right measured text. The text uses glyph metrics so it 
--- can be positioned accurately.
+-- Left-to-right measured text that supports radial inclination.
+-- Caveat - rendering at any degree other than the horizontal may
+-- not look good in PostScript or SVG.
 -- 
--- \*\* WARNING \*\* - the API for this module needs work. The 
--- current API is not satisfactory for drawing according to a 
--- start position (there are other reasonable start positions than 
--- the ones currently supported - adding them would explode the 
--- number of definitions).
+-- Note - LRText does not use the 'text_margin' setting from the 
+-- 'DrawingContext'.
+--
+-- \*\* WARNING \*\* - the API for this module needs some polish.
+--
 -- 
 --------------------------------------------------------------------------------
 
 module Wumpus.Drawing.Text.LRText
   ( 
 
-    baseCenterLine
-  , baseLeftLine
-  , baseRightLine
-
-  , rbaseCenterLine
-  , rbaseLeftLine
-  , rbaseRightLine
-
-  , ctrCenterLine
-  , baseCenterEscChar
+    singleLine
+  , escSingleLine
+  , rsingleLine
+  , rescSingleLine
 
   , multiAlignLeft
   , multiAlignCenter
   , multiAlignRight
 
-  , rmultiAlignLeft
-  , rmultiAlignCenter
-  , rmultiAlignRight
- 
+  , textAlignCenter
+  , textAlignLeft
+  , textAlignRight
 
   ) where
 
+import Wumpus.Drawing.Chains
+import Wumpus.Drawing.Text.Base
 
-import Wumpus.Basic.Kernel
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
 
 import Wumpus.Core                              -- package: wumpus-core
-import Wumpus.Core.Text.GlyphIndices
 
 import Data.AffineSpace                         -- package: vector-space
 import Data.VectorSpace
 
-import Control.Applicative
-import Data.Char
-import qualified Data.Map               as Map
-import Data.Maybe 
 
-
--- Note - BoundedLocThetaGraphic is probably an adequate type
--- even though the same text will have a different bounding box
--- if it is rotated (the sides of the BBox are always parallel to 
--- the x and y axes even if the text is not parrale to the 
--- x-axis). 
--- 
--- I cannot think of any compelling graphics that need a more 
--- accurate type. The execption is text cannot have exact anchors 
--- however this is a moot /if/ text is considered as a labelling 
--- of an existing rectangle (which may or may not have been 
--- rotated).
 --
+-- Note - margins are not added to the text. This seems to be the 
+-- right thing to do in the case of rotated text, where the ortho
+-- projection of the rectangle already can add spacing between 
+-- the RectPos and the actual text.
+--
 
 
+-------------------
 
--- One line of multiline text
+-- | One line of multiline text
 --
-data OnelineText u = OnelineText EscapedText (AdvanceVec u)
-
+data OnelineText u = OnelineText 
+        { text_content        :: EscapedText
+        , oneline_adv         :: AdvanceVec u
+        }
 
--- | max_width * oneline_text -> LocThetaGraphic
+-- Design note - using a LocThetaImage could be used instead, but
+-- as the angle of inclination is interior to the final type the 
+-- it is used explicitly.
 --
-type LocThetaDrawOneline u = u -> OnelineText u -> LocThetaGraphic u
+type OnelineDrawF u = 
+    Radian -> AdvanceVec u -> OnelineText u -> LocImage u (BoundingBox u)
 
 
--- | max_width * oneline_text -> LocThetaGraphic
---
-type BoundedLocThetaOneline u = u -> OnelineText u -> BoundedLocThetaGraphic u
 
 
--- | Draw one line of left-aligned text, knowing the max_width 
--- of all the lines of text.
---
--- All left-aligned text is moved left by half the max_width.
---
--- Note - implicit point is baseline-center, this is perhaps 
--- unintituitive given the functions name but it is an 
--- advantage for drawing multi-line text.
--- 
-drawLeftAligned :: Floating u => LocThetaDrawOneline u
-drawLeftAligned max_width (OnelineText esc _) = 
-    promoteR2 $ \baseline_ctr theta -> 
-       let mv = displaceParallel ((-0.5) * max_width) theta
-       in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
-       
+singleLine :: (Real u, Floating u, FromPtSize u) 
+           => String -> PosImage u (BoundingBox u)
+singleLine ss = onelineDraw onelineACenter 0 (escapeString ss)
 
+escSingleLine :: (Real u, Floating u, FromPtSize u) 
+              => EscapedText -> PosImage u (BoundingBox u)
+escSingleLine = onelineDraw onelineACenter 0
 
--- | Draw one line of center-aligned text. Center aligned text is 
--- oblivious to the max_width of all the lines of text.
---
--- Each line of center-aligned text is moved left by half its 
--- advance vector.
---
--- Implicit point is baseline-center.
---
-drawCenterAligned :: Floating u => LocThetaDrawOneline u
-drawCenterAligned _ (OnelineText esc av) = 
-    promoteR2 $ \baseline_ctr theta -> 
-       let mv = displaceParallel (negate $ 0.5 * advanceH av) theta
-       in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
-       
 
--- | Draw one line of right-aligned text, knowing the max_width 
--- of all the lines of text.
---
--- Each right-aligned text line is moved by the width component 
--- of the advance vector minus half the max width.
---
--- Note - implicit point is baseline-center, this is perhaps 
--- unintituitive given the functions name but it is an 
--- advantage for drawing multi-line text.
--- 
-drawRightAligned :: Floating u => LocThetaDrawOneline u
-drawRightAligned max_width (OnelineText esc av) = 
-    promoteR2 $ \baseline_ctr theta -> 
-      let mv = displaceParallel ((0.5 * max_width) - advanceH av) theta
-      in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
+rsingleLine :: (Real u, Floating u, FromPtSize u) 
+            => Radian -> String -> PosImage u (BoundingBox u)
+rsingleLine theta ss = onelineDraw onelineACenter theta (escapeString ss)
 
+rescSingleLine :: (Real u, Floating u, FromPtSize u) 
+               => Radian -> EscapedText -> PosImage u (BoundingBox u)
+rescSingleLine = onelineDraw onelineACenter
 
+multiAlignLeft :: (Real u, Floating u, FromPtSize u) 
+               => Radian -> String -> PosImage u (BoundingBox u)
+multiAlignLeft theta ss = 
+   drawMultiline onelineALeft theta (map escapeString $ lines ss)
 
+multiAlignCenter :: (Real u, Floating u, FromPtSize u) 
+               => Radian -> String -> PosImage u (BoundingBox u)
+multiAlignCenter theta ss = 
+   drawMultiline onelineACenter theta (map escapeString $ lines ss)
 
--- Impilict point is baseline-center.
---
-onelineBBox :: (Real u, Floating u, FromPtSize u) 
-            => OnelineText u -> LocThetaDrawingInfo u (BoundingBox u)
-onelineBBox (OnelineText _ av) = 
-    promoteR2 $ \baseline_ctr theta -> 
-      glyphHeightRange >>= \(ymin, ymax) ->
-      getTextMargin    >>= \(xsep, ysep) -> 
-        let hw        = 0.5 * advanceH av 
-            btm_left  = baseline_ctr .+^ vec (-hw) ymin
-            top_right = baseline_ctr .+^ vec hw    ymax
-            bbox      = expandBB xsep ysep (BBox btm_left top_right)
-        in pure $ centerOrthoBBox theta bbox
-  where
-    expandBB xsep ysep (BBox (P2 x0 y0) (P2 x1 y1)) = 
-        BBox (P2 (x0-xsep) (y0-ysep)) (P2 (x1+xsep) (y1+ysep))
-    
+multiAlignRight :: (Real u, Floating u, FromPtSize u) 
+               => Radian -> String -> PosImage u (BoundingBox u)
+multiAlignRight theta ss = 
+   drawMultiline onelineARight theta (map escapeString $ lines ss)
 
 
+textAlignLeft :: (Real u, Floating u, FromPtSize u) 
+              => String -> LocImage u (BoundingBox u)
+textAlignLeft ss = multiAlignLeft 0 ss `startPos` CENTER
 
+textAlignCenter :: (Real u, Floating u, FromPtSize u) 
+               => String -> LocImage u (BoundingBox u)
+textAlignCenter ss = multiAlignCenter 0 ss `startPos` CENTER 
 
+textAlignRight :: (Real u, Floating u, FromPtSize u) 
+               => String -> LocImage u (BoundingBox u)
+textAlignRight ss = multiAlignRight 0 ss `startPos` CENTER 
 
 
--- This should have max_width as a param...
---
-makeMoveableLine :: (Real u, Floating u, FromPtSize u) 
-                 => LocThetaDrawOneline u 
-                 -> BoundedLocThetaOneline u
-makeMoveableLine drawF max_width oline =
-      intoLocThetaImage (onelineBBox oline) (drawF max_width oline)
 
-onelineAlg :: (Real u, Floating u, FromPtSize u) 
-           => DisplaceFun u 
-           -> LocThetaDrawOneline u 
-           -> EscapedText
-           -> BoundedLocThetaGraphic u
-onelineAlg ptMoveF drawF esc = 
-   promoteR2 $ \pt theta -> 
-     onelineEscText esc >>= \ans@(OnelineText _ av) ->
-       let max_width = advanceH av
-           move      = ptMoveF max_width ans theta 
-       in apply2R2 (makeMoveableLine drawF max_width ans) (move pt) theta
 
+-- Note - inclination is not part of the ContextFunction...
 
+drawMultiline :: (Real u, Floating u, FromPtSize u) 
+              => OnelineDrawF u -> Radian -> [EscapedText] 
+              -> PosImage u (BoundingBox u)
+drawMultiline _     _     []  = lift1R2 emptyBoundedLocGraphic
+drawMultiline drawF theta [x] = onelineDraw drawF theta x
+drawMultiline drawF theta xs  = promoteR2 $ \start rpos ->
+    linesToInterims xs >>= \(max_adv, ones) -> 
+    rotObjectPos theta line_count (advanceH max_adv) >>= \opos -> 
+    let chn   = centerSpinePoints line_count theta
+        gs    = map (drawF theta max_adv) ones
+        gf    = unchainZip emptyBoundedLocGraphic gs chn
+        posG  = makePosImage opos gf
+    in  atStartPos posG start rpos     
+  where
+    line_count = length xs
 
 
 
--- | Draw 1 line...
---
--- Impilict point is baseline-left.
---
 
-baseLeftLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocGraphic u
-baseLeftLine ss = rbaseLeftLine ss `rot` 0
-
+onelineDraw :: (Real u, Floating u, FromPtSize u) 
+            => OnelineDrawF u -> Radian -> EscapedText -> PosImage u (BoundingBox u)
+onelineDraw drawF theta esc = promoteR2 $ \start rpos ->
+    onelineEscText esc        >>= \otext -> 
+    rotObjectPos theta 1 (advanceH $ oneline_adv otext) >>= \opos  -> 
+    let max_adv = oneline_adv otext 
+        gf      = drawF theta max_adv otext
+        posG    = makePosImage opos gf
+    in  atStartPos posG start rpos 
 
 
--- | Draw 1 line...
---
--- Impilict point is baseline-center.
+-- | LR text needs the objectPos under rotation.
 --
-baseCenterLine :: (Real u, Floating u, FromPtSize u) 
-               => String -> BoundedLocGraphic u
-baseCenterLine ss = rbaseCenterLine ss `rot` 0
+rotObjectPos :: (Real u, Floating u, FromPtSize u) 
+             => Radian -> Int -> u -> DrawingInfo (ObjectPos u)
+rotObjectPos theta line_count max_w =
+    fmap (orthoObjectPos theta) $ textObjectPos line_count max_w 
 
 
 
+    
 
--- | Draw 1 line...
---
--- Impilict point is baseline-right.
+-- | Note - this returns the answer in center form, regardless
+-- of whether the input was in center form.
+-- 
+-- So it is probably not a general enough function for the 
+-- PosImage library.
 --
-baseRightLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocGraphic u
-baseRightLine ss = rbaseRightLine ss `rot` 0
+orthoObjectPos :: (Real u, Floating u) 
+               => Radian -> ObjectPos u -> ObjectPos u
+orthoObjectPos theta (ObjectPos xmin xmaj ymin ymaj) = 
+    ObjectPos bbox_hw bbox_hw bbox_hh bbox_hh
+  where
+    input_hw  = 0.5 * (xmin + xmaj)
+    input_hh  = 0.5 * (ymin + ymaj)
+    bbox0     = BBox (P2 (-input_hw) (-input_hh)) (P2 input_hw input_hh)
+    bbox1     = retraceBoundary (rotateAbout theta zeroPt) bbox0
+    bbox_hw   = 0.5 * (boundaryWidth bbox1)
+    bbox_hh   = 0.5 * (boundaryHeight bbox1)
 
 
 
-rbaseLeftLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocThetaGraphic u
-rbaseLeftLine ss = 
-    onelineAlg leftToCenter drawLeftAligned (escapeString ss)
 
 
-rbaseCenterLine :: (Real u, Floating u, FromPtSize u) 
-                => String -> BoundedLocThetaGraphic u
-rbaseCenterLine ss = 
-    onelineAlg centerToCenter drawCenterAligned (escapeString ss)
 
 
-rbaseRightLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocThetaGraphic u
-rbaseRightLine ss = 
-    onelineAlg rightToCenter drawRightAligned (escapeString ss)
-
-
--- Note - assumes the ymin of the font is 0 or less.
+-- | Draw left-aligned text. Effictively this is:
 --
-ctrCenterLine :: (Real u, Floating u, FromPtSize u) 
-              => String -> BoundedLocGraphic u
-ctrCenterLine ss =
-    glyphHeightRange >>= \(ymin, ymax) -> 
-      let hh = 0.5 * ymax - ymin in 
-        moveStartPoint (displaceV $ negate $ hh - abs ymin) $ baseCenterLine ss
-
-
-
-baseCenterEscChar :: (Real u, Floating u, FromPtSize u) 
-                  => EscapedChar -> BoundedLocGraphic u
-baseCenterEscChar esc = body `rot` 0
+-- > Leftwards for the half the max vector
+-- >
+-- > Down to the baseline from the center.
+--
+onelineALeft :: (Real u, Floating u, FromPtSize u)  
+             => OnelineDrawF u 
+onelineALeft theta max_adv otext = promoteR1 $ \ctr -> 
+    centerToBaseline >>= \down -> 
+    atRot (orthoBB max_adv) ctr theta >>= \bbox -> 
+    let pt = move down theta ctr 
+    in replaceAns bbox $ atRot (rescapedline $ text_content otext) pt theta
   where
-    body = onelineAlg centerToCenter drawCenterAligned (wrapEscChar esc)
-
-
-
-
+    vec1      = negateV $ 0.5 *^ max_adv
+    move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang
 
 
--- | max_width * interim_text * theta -> (Point -> Point)
+-- | Draw center-aligned text. Effictively this is:
 --
-type DisplaceFun u = u -> OnelineText u -> Radian -> PointDisplace u
-
-centerToCenter :: DisplaceFun u
-centerToCenter _ _ _ = id
-
-leftToCenter :: Floating u => DisplaceFun u
-leftToCenter max_width _ theta =
-    displaceParallel (0.5 * max_width) theta
-
-rightToCenter :: Floating u => DisplaceFun u
-rightToCenter max_width (OnelineText _ av) theta =
-    displaceParallel ((0.5 * max_width) - advanceH av) theta
-
-
-
-
-multiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u)
-               => String
-               -> BoundedLocGraphic u
-multiAlignLeft ss = rmultiAlignLeft ss `rot` 0
-
-
-multiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u)
-                 => String
-                 -> BoundedLocGraphic u
-multiAlignCenter ss = rmultiAlignCenter ss `rot` 0
-
-
-
-
-multiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u)
-                => String
-                -> BoundedLocGraphic u
-multiAlignRight ss = rmultiAlignRight ss `rot` 0
-
-
-rmultiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u)
-               => String
-               -> BoundedLocThetaGraphic u
-rmultiAlignLeft = multilineTEXT (makeMoveableLine drawLeftAligned)
-
-
-rmultiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u)
-                  => String
-                  -> BoundedLocThetaGraphic u
-rmultiAlignCenter = multilineTEXT (makeMoveableLine drawCenterAligned)
-
-
-rmultiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u)
-                 => String
-                 -> BoundedLocThetaGraphic u
-rmultiAlignRight = multilineTEXT (makeMoveableLine drawRightAligned)
-
-
-
-multilineTEXT :: (Floating u, Ord u, FromPtSize u)
-              => BoundedLocThetaOneline u
-              -> String
-              -> BoundedLocThetaGraphic u
-multilineTEXT _  [] = lift1R2 emptyBoundedLocGraphic
-multilineTEXT mf ss = 
-    lift0R2 (linesToInterims ss) >>= \(max_av, itexts) -> 
-      centralPoints (length itexts) >>= \pts -> 
-        zipMultis (advanceH max_av) mf itexts pts
-
-
-      
-
-zipMultis :: (Ord u, FromPtSize u)
-          => u
-          -> BoundedLocThetaOneline u
-          -> [OnelineText u] -> [Point2 u]
-          -> BoundedLocThetaGraphic u
-zipMultis _     _  []     _       = lift1R2 $ emptyBoundedLocGraphic
-zipMultis _     _  _      []      = lift1R2 $ emptyBoundedLocGraphic
-zipMultis max_w mf (a:as) (b:bs) = step a b as bs
+-- > Leftwards for the half the width vector
+-- >
+-- > Down to the baseline from the center.
+--
+onelineACenter :: (Real u, Floating u, FromPtSize u)  
+               => OnelineDrawF u
+onelineACenter theta max_adv otext = promoteR1 $ \ctr -> 
+    centerToBaseline >>= \down -> 
+    atRot (orthoBB max_adv) ctr theta >>= \bbox ->  
+    let pt = move down theta ctr 
+    in replaceAns bbox $ atRot (rescapedline $ text_content otext) pt theta
   where
-    mkGraphic itext pt        = promoteR2 $ \_ theta -> 
-                                  apply2R2 (mf max_w itext) pt theta
-    step r s (r2:rs) (s2:ss)  = liftA2 oplus (mkGraphic r s) (step r2 s2 rs ss)
-    step r s _       _        = mkGraphic r s
-
-
+    vec1      = negateV $ 0.5 *^ oneline_adv otext
+    move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang
 
 
--- | @ana@ is an /anacrusis/ factor - if there are even points
--- half the baseline_spacing is added to get the top point
+-- | Draw right-aligned text. Effictively this is:
 --
-centralPoints :: Floating u => Int -> LocThetaDrawingInfo u [Point2 u]
-centralPoints n | n < 2     = promoteR2 $ \ctr _  -> return [ctr]
-                | even n    = body (n `div` 2) (0.5*)
-                | otherwise = body (n `div` 2) (0 *) 
+-- > Rightwards for the half the max vector
+-- >
+-- > Leftwards for the width vector
+-- >
+-- > Down to the baseline from the center.
+--
+onelineARight :: (Real u, Floating u, FromPtSize u)  
+              => OnelineDrawF u
+onelineARight theta max_adv otext = promoteR1 $ \ctr -> 
+    centerToBaseline >>= \down -> 
+    atRot (orthoBB max_adv) ctr theta >>= \bbox -> 
+    let pt = move down theta ctr 
+    in replaceAns bbox $ atRot (rescapedline $ text_content otext) pt theta
   where
-    body halfn ana  = promoteR2 $ \ctr theta -> 
-                        baselineSpacing >>= \h ->
-                          let y0  = (h * fromIntegral halfn) + ana h
-                              top = displacePerpendicular y0 theta ctr
-                          in pure $ trailPoints n h theta top
-        
+    vec1      = (0.5 *^ max_adv) ^-^ oneline_adv otext
+    move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang
 
 
-trailPoints :: Floating u => Int -> u -> Radian -> Point2 u -> [Point2 u]
-trailPoints n height theta top = take n $ iterate fn top
-  where
-    fn pt = displacePerpendicular (-height) theta pt
 
+-- Note - for multiline text, the bounding box (of one line) is 
+-- always the same size regardless of the alignment of the textlines.
+--
+orthoBB :: (Real u, Floating u, FromPtSize u) 
+        => AdvanceVec u -> LocThetaDrawingInfo u (BoundingBox u)
+orthoBB (V2 w _) = promoteR2 $ \ctr theta -> 
+    glyphVerticalSpan >>= \h ->
+    let bl  = ctr .-^ V2 (0.5 * w) (0.5 * h)
+        bb1 = boundingBox bl (bl .+^ V2 w h)
+        bb2 = retraceBoundary (rotateAbout theta ctr) bb1
+    in return bb2
 
 
+
 --------------------------------------------------------------------------------
 
 -- This isn't worth the complexity to get down to one traversal...
 
+-- | Turn the input list of lines of 'EscapedText' into 
+-- 'OnelineText' and return the result list twinned with the 
+-- largest 'AdvanceVec'.
+--
 linesToInterims :: (FromPtSize u, Ord u) 
-                => String -> DrawingInfo (AdvanceVec u, [OnelineText u])
-linesToInterims = fmap post . mapM (onelineEscText . escapeString) . lines
+                => [EscapedText] -> DrawingInfo (AdvanceVec u, [OnelineText u])
+linesToInterims = fmap post . mapM onelineEscText
   where
     post xs                    = let vmax = foldr fn (hvec 0) xs in (vmax,xs)
     fn (OnelineText _ av) vmax = avMaxWidth av vmax
 
+
+
+
 avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u
 avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a
 
@@ -390,20 +290,3 @@
 onelineEscText esc = fmap (OnelineText esc) $ textVector esc
 
 
-
-textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u)
-textVector esc = 
-    cwLookupTable >>= \table -> 
-       let cs = destrEscapedText id esc 
-       in pure $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs
-     
-   
-
-
-charWidth :: FromPtSize u 
-          => CharWidthTable u -> EscapedChar -> AdvanceVec u
-charWidth fn (CharLiteral c) = fn $ ord c
-charWidth fn (CharEscInt i)  = fn i
-charWidth fn (CharEscName s) = fn ix
-  where
-    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices
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
@@ -23,7 +23,7 @@
 
 -- | Version number
 --
--- > (0,1,0)
+-- > (0,2,0)
 --
 wumpus_drawing_version :: (Int,Int,Int)
-wumpus_drawing_version = (0,1,0)
+wumpus_drawing_version = (0,2,0)
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.2.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -38,6 +38,16 @@
   .
   Changelog:
   .
+  v0.1.0 to 0.2.0:
+  .
+  * Added new Shapes.
+  .
+  * Move Geometry modules to Wumpus-Basic.
+  .
+  * Re-implemented Chains.
+  .
+  * Re-implemented LR-Text. Added CatText.
+  .
   v0.1.0:
   .
   * Initial release - this is a split from @Wumpus-Basic@ making 
@@ -73,7 +83,8 @@
   demo/FontPic.hs,
   demo/LeftRightText.hs,
   demo/PetriNet.hs,
-  demo/PictureCompo.hs,
+  demo/SingleLine.hs,
+  demo/SampleShapes.hs,
   demo/Symbols.hs,
   demo/TableChains.hs
 
@@ -81,11 +92,9 @@
   hs-source-dirs:     src
   build-depends:      base            <  5, 
                       containers      >= 0.3     && <= 0.6,
-                      directory       >= 1.0     && <  2.0, 
-                      filepath        >= 1.1     && <  2.0,
                       vector-space    >= 0.6     && <  1.0,
-                      wumpus-core     >= 0.42.0  && <  0.43.0,
-                      wumpus-basic    == 0.15.0
+                      wumpus-core     >= 0.43.0  && <  0.44.0,
+                      wumpus-basic    == 0.16.0
 
   
   exposed-modules:
@@ -99,8 +108,7 @@
     Wumpus.Drawing.Colour.X11Colours,
     Wumpus.Drawing.Dots.AnchorDots,
     Wumpus.Drawing.Dots.Marks,
-    Wumpus.Drawing.Geometry.Intersection,
-    Wumpus.Drawing.Geometry.Paths,
+    Wumpus.Drawing.Grids,
     Wumpus.Drawing.Paths,
     Wumpus.Drawing.Paths.Base,
     Wumpus.Drawing.Paths.Connectors,
@@ -111,7 +119,17 @@
     Wumpus.Drawing.Shapes.Circle,
     Wumpus.Drawing.Shapes.Diamond,
     Wumpus.Drawing.Shapes.Ellipse,
+    Wumpus.Drawing.Shapes.InvSemicircle,
+    Wumpus.Drawing.Shapes.InvSemiellipse,
+    Wumpus.Drawing.Shapes.InvTriangle,
+    Wumpus.Drawing.Shapes.Parallelogram,
     Wumpus.Drawing.Shapes.Rectangle,
+    Wumpus.Drawing.Shapes.Trapezium,
+    Wumpus.Drawing.Shapes.Semicircle,
+    Wumpus.Drawing.Shapes.Semiellipse,
+    Wumpus.Drawing.Shapes.Triangle,
+    Wumpus.Drawing.Text.Base,
+    Wumpus.Drawing.Text.CatText,
     Wumpus.Drawing.Text.LRText,
     Wumpus.Drawing.Text.SafeFonts,
     Wumpus.Drawing.Turtle.TurtleClass,