diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs
new file mode 100644
--- /dev/null
+++ b/demo/ClipPic.hs
@@ -0,0 +1,101 @@
+{-# OPTIONS -Wall #-}
+
+-- Note - how the background is built in this example is very 
+-- expensive, i.e. it generates large PostScript and SVG files
+-- because the text elements are drawn many more times than they
+-- are actually seen.
+--
+-- This example just illustrates that clipping-paths work and 
+-- uses a complicated background to make that point.
+--
+
+
+module ClipPic where
+
+import Wumpus.Basic.Chains
+import Wumpus.Basic.Colour.SVGColours
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Paths
+import Wumpus.Basic.PictureLanguage
+import Wumpus.Basic.Text.LRSymbol
+import Wumpus.Basic.Text.LRText
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import System.Directory
+
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    >> writeEPS_latin1 "./out/clip_pic.eps" pic
+    >> writeSVG_latin1 "./out/clip_pic.svg" pic
+
+
+pic_drawing_ctx :: DrawingContext
+pic_drawing_ctx = standardContext 14
+
+
+pic :: DPicture
+pic = pic1 `nextToV` (stackOver [cpic1, cpic2, cpic3] cpic4)
+
+
+pic1 :: DPicture
+pic1 = liftToPictureU $ execDrawing pic_drawing_ctx $ 
+         localCtx (secondaryColour medium_slate_blue) $ do
+            draw $ fillPath path01
+            localCtx (secondaryColour powder_blue) $ 
+                     draw $ fillPath path02
+            draw $ fillPath path03
+            draw $ fillPath path04
+
+
+background :: RGBi -> DPicture 
+background rgb = liftToPictureU $ execDrawing pic_drawing_ctx $ 
+                   localCtx (primaryColour rgb) $ do                  
+                     mapM_ iheartHaskell ps
+
+   where
+     ps = unchain (coordinateScalingContext 86 16) $ tableDown 18 8
+
+cpic1 :: DPicture 
+cpic1 = clip (toPrimPathU path01) (background black)
+  
+cpic2 :: DPicture 
+cpic2 = clip (toPrimPathU path02) (background medium_violet_red)
+
+cpic3 :: DPicture 
+cpic3 = clip (toPrimPathU path03) (background black)
+
+cpic4 :: DPicture 
+cpic4 = clip (toPrimPathU path04) (background black)
+
+
+iheartHaskell :: Num u => FromPtSize u => Point2 u -> Drawing u () 
+iheartHaskell pt = 
+    draw $ (execLRText $ char 'I' >> heart >> mapM_ char "Haskell") `at` pt
+
+
+path01 :: Floating u => Path u
+path01 = execPath zeroPt $ hline 80 >> rlineto (vec 112 160) 
+                                    >> rlineto (vec (-112) 160)
+                                    >> hline (-80)
+                                    >> rlineto (vec 112 (-160))
+                                    >> rlineto (vec (-112) (-160))
+ 
+
+path02 :: Floating u => Path u
+path02 = execPath (P2 112 0) $ hline 80 >> rlineto (vec 72 112)
+                                        >> rlineto (vec 72 (-112))
+                                        >> hline 80
+                                        >> rlineto (vec (-224) 320)
+                                        >> hline (-80)
+                                        >> rlineto (vec 112 (-160))
+                                        >> rlineto (vec (-112) (-160))
+
+path03 :: Floating u => Path u
+path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) 
+
+path04 :: Floating u => Path u
+path04 = execPath (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) 
+
diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs
--- a/demo/ColourCharts.hs
+++ b/demo/ColourCharts.hs
@@ -4,10 +4,12 @@
 
 import ColourDefns
 
+import Wumpus.Basic.Chains
 import Wumpus.Basic.Graphic
 
 import Wumpus.Core                              -- package: wumpus-core
 
+import Control.Monad
 import System.Directory
 
 
@@ -20,40 +22,29 @@
     writeSVG_latin1 "./out/X11colours.svg" x11_landscape
 
 svg :: Picture Double
-svg = makePicture 60 160 all_svg_colours
+svg = makePicture 52 all_svg_colours
 
 x11_landscape :: Picture Double
-x11_landscape = makePicture 60 140 all_x11_colours
+x11_landscape = makePicture 52 all_x11_colours
 
 x11_portrait :: Picture Double
-x11_portrait = makePicture 72 140 all_x11_colours     
-
-makePicture :: Int -> Double -> [(String,RGBi)] -> DPicture 
-makePicture row_count unit_width xs = 
-    liftToPictureU $ execDrawing (standardContext 10) $ 
-        downLeftRight row_count unit_width $ mapM_ fn xs
-   where
-     fn (name,rgb) = colourSample name rgb
-
+x11_portrait = makePicture 72 all_x11_colours     
 
--- Note - cannot use node twice as it increments the point supply.
---
-colourSample :: String -> RGBi -> ChainT Double (Drawing Double) ()
-colourSample name rgb = localCtx (secondaryColour rgb) $ do 
-    { pt <- position 
-    ; draw $ borderedRectangle 15 10 `at` pt
-    ; draw $ textline name `at` displace 20 2 pt 
-    }    
+makePicture :: Int -> [(String,RGBi)] -> DPicture 
+makePicture row_count xs = 
+    liftToPictureU $ execDrawing (standardContext 9) $ 
+        tableGraphic row_count xs
 
+tableGraphic :: Int -> [(String,RGBi)] -> Drawing Double ()
+tableGraphic row_count xs = 
+    zipWithM_ (\(name,rgb) pt -> colourSample name rgb pt) xs ps
+  where
+    ps = unchain (coordinateScalingContext 152 11) $ tableDown row_count 10 
 
 
-downLeftRight :: (Monad m, Num u, Ord u) 
-              => Int -> u -> ChainT u m a -> m a
-downLeftRight row_count width ma = runChainT fn start_pt ma
-  where
-    y_top       = 12 * fromIntegral row_count
-    start_pt    = P2 0 y_top
-    
-    fn (P2 x y) | y < 0     = P2 (x+width) y_top
-                | otherwise = P2 x (y - 12)   
+colourSample :: String -> RGBi -> DPoint2 -> Drawing Double ()
+colourSample name rgb pt = localCtx (secondaryColour rgb) $ do 
+    draw $ borderedRectangle 15 10 `at` pt
+    draw $ textline name `at` displace 20 2 pt 
+        
 
diff --git a/demo/FontPic.hs b/demo/FontPic.hs
--- a/demo/FontPic.hs
+++ b/demo/FontPic.hs
@@ -2,17 +2,15 @@
 
 module FontPic where
 
-import Wumpus.Basic.SafeFonts
+import Wumpus.Basic.Chains
+import Wumpus.Basic.Graphic
 import Wumpus.Basic.Colour.SVGColours ( steel_blue )
 import Wumpus.Basic.Colour.X11Colours ( indian_red1 )
-import Wumpus.Basic.PictureLanguage
+import Wumpus.Basic.SafeFonts
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space
-import Data.VectorSpace
-
-import Data.List ( unfoldr )
+import Control.Monad
 
 import System.Directory
 
@@ -29,103 +27,83 @@
     writeSVG_latin1 "./out/font_symbol.svg"    symbol_pic
 
 
-makeFontLabel :: RGBi -> FontAttr -> DPoint2 -> DPrimElement
-makeFontLabel rgb fa = textlabel rgb fa msg
+fontMsg :: FontFace -> Int -> String
+fontMsg ff sz = msgF []
   where
-    msg = unwords [ font_name $ font_face fa, (show $ font_size fa) ++ "pt"]
+    msgF = showString (font_name ff) . showChar ' ' . shows sz . showString "pt"
 
-blueLabel :: FontFace -> Int -> DPoint2 -> DPrimElement
-blueLabel ff i = makeFontLabel steel_blue (FontAttr i ff)
 
-redLabel :: FontFace -> Int -> DPoint2 -> DPrimElement
-redLabel ff i = makeFontLabel indian_red1 (FontAttr i ff)
+makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic
+makeLabel rgb ff sz = 
+    localLG (primaryColour rgb . fontsize sz . fontface ff) 
+            (textline $ fontMsg ff sz)
 
+-- indian_red1
+-- steel_blue
 
 point_sizes :: [Int]
 point_sizes = [10, 12, 18, 24, 36, 48]
 
---------------------------------------------------------------------------------
--- Times
+positions :: [Int]
+positions = [0, 12, 27, 49, 78, 122] 
 
-times_pic :: Picture Double
-times_pic = timesroman_pic `nextToV` timesitalic_pic     `nextToV` timesbold_pic
-                           `nextToV` timesbolditalic_pic
 
+pointChain :: LocChain Int Int Double
+pointChain = verticals positions
 
+fontGraphic :: RGBi -> FontFace -> DPoint2 -> Drawing Double ()
+fontGraphic rgb ff pt = 
+    let ps = unchain (coordinateScalingContext 1 1) $ pointChain pt in 
+      zipWithM_ (\p1 sz -> draw $ makeLabel rgb ff sz `at` p1) ps point_sizes
 
-timesroman_pic :: Picture Double
-timesroman_pic = 
-    frame $ zipWith (blueLabel timesRoman) point_sizes (mkPoints 1.5)
 
-timesitalic_pic :: Picture Double
-timesitalic_pic = 
-    frame $ zipWith (redLabel timesItalic) point_sizes (mkPoints 1.5)
+std_ctx :: DrawingContext
+std_ctx = standardContext 10
 
-timesbold_pic :: Picture Double
-timesbold_pic = 
-    frame $ zipWith (blueLabel timesBold) point_sizes (mkPoints 1.5)
 
-timesbolditalic_pic :: Picture Double
-timesbolditalic_pic = 
-    frame $ zipWith (redLabel timesBoldItalic) point_sizes (mkPoints 1.5)
+fontPicture :: [(RGBi,FontFace)] -> DPicture
+fontPicture xs = liftToPictureU $ execDrawing std_ctx $  
+                   zipWithM (\(rgb,ff) pt -> fontGraphic rgb ff pt) xs ps
+  where
+    ps = unchain (coordinateScalingContext 1 180) $ tableDown 4 1
 
+
+
 --------------------------------------------------------------------------------
+-- Times
+
+times_pic :: Picture Double
+times_pic = 
+    fontPicture [ (steel_blue,  timesRoman)
+                , (indian_red1, timesItalic)
+                , (steel_blue,  timesBold)
+                , (indian_red1, timesBoldItalic)
+                ] 
+
 helvetica_pic :: Picture Double
-helvetica_pic = vcat helvetica_pic1 [ helveticaoblique_pic  
-                                    , helveticabold_pic
-                                    , helveticaboldoblique_pic ]
-                     
+helvetica_pic = 
+    fontPicture [ (steel_blue,  helvetica)
+                , (indian_red1, helveticaOblique)
+                , (steel_blue,  helveticaBold)
+                , (indian_red1, helveticaBoldOblique)
+                ] 
 
-helvetica_pic1 :: Picture Double
-helvetica_pic1 = 
-    frame $ zipWith (blueLabel helvetica) point_sizes (mkPoints 1.5)
 
-helveticaoblique_pic :: Picture Double
-helveticaoblique_pic = 
-    frame $ zipWith (redLabel helveticaOblique) point_sizes (mkPoints 1.5)
-    
-helveticabold_pic :: Picture Double
-helveticabold_pic = 
-    frame $ zipWith (blueLabel helveticaBold) point_sizes (mkPoints 1.5)
-    
-helveticaboldoblique_pic :: Picture Double
-helveticaboldoblique_pic = 
-    frame $ zipWith (redLabel helveticaBoldOblique) point_sizes (mkPoints 1.5)
 
 --------------------------------------------------------------------------------
 
 courier_pic :: Picture Double
-courier_pic = vcat courier_pic1 [ courieroblique_pic
-                                , courierbold_pic
-                                , courierboldoblique_pic ]
-    
-courier_pic1 :: Picture Double
-courier_pic1 = 
-    frame $ zipWith (blueLabel courier) point_sizes (mkPoints 1.5)
-    
-courieroblique_pic :: Picture Double
-courieroblique_pic = 
-    frame $ zipWith (redLabel courierOblique) point_sizes (mkPoints 1.5)
-    
-courierbold_pic :: Picture Double
-courierbold_pic = 
-    frame $ zipWith (blueLabel courierBold) point_sizes (mkPoints 1.5)
-    
-courierboldoblique_pic :: Picture Double
-courierboldoblique_pic = 
-    frame $ zipWith (redLabel courierBoldOblique) point_sizes (mkPoints 1.5)
+courier_pic = 
+    fontPicture [ (steel_blue,  courier)
+                , (indian_red1, courierOblique)
+                , (steel_blue,  courierBold)
+                , (indian_red1, courierBoldOblique)
+                ] 
 
+
 --------------------------------------------------------------------------------
 
     
 symbol_pic :: Picture Double
 symbol_pic = 
-    frame $ zipWith (blueLabel symbol) point_sizes (mkPoints 1.5)
-
-
---------------------------------------------------------------------------------
-
-
-mkPoints :: Num u => u -> [Point2 u]
-mkPoints n = unfoldr phi zeroPt where
-  phi pt = Just (pt, pt .+^ (V2 0 15 ^* n))
+    fontPicture [ (steel_blue, symbol) ]
diff --git a/demo/Shapes.hs b/demo/Shapes.hs
new file mode 100644
--- /dev/null
+++ b/demo/Shapes.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+-- Acknowledgment - the petri net is taken from Claus Reinke\'s
+-- paper /Haskell-Coloured Petri Nets/.
+
+
+module Shapes where
+
+import Wumpus.Basic.Anchors
+import Wumpus.Basic.Arrows
+import Wumpus.Basic.Colour.SVGColours
+import Wumpus.Basic.Graphic                     -- package: wumpus-basic
+import Wumpus.Basic.Paths
+import Wumpus.Basic.Shapes.Base
+import Wumpus.Basic.Shapes.Derived
+import Wumpus.Basic.SafeFonts
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+import System.Directory
+
+
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    writeEPS_latin1 "./out/shapes01.eps" pic1
+    writeSVG_latin1 "./out/shapes01.svg" pic1
+    writeEPS_latin1 "./out/petri_net.eps" petri_net
+    writeSVG_latin1 "./out/petri.svg" petri_net
+    
+
+pic1 :: DPicture
+pic1 = liftToPictureU $ execDrawing (standardContext 14) $ do
+         _ <- drawi $ drawShape $ translate 220 10 $ rotate30
+                                                   $ lrectangle 90 30 "Rectangle"
+         _ <- drawi $ drawShape $ translate 100  0 $ lcircle 10 "C0"
+   
+         _ <- localCtx (primaryColour red) $ 
+                       drawi $ drawShape $ translate 220 10 $ rotate30 $ coordinate
+         _ <- drawi $ drawShape $ translate 0   40 $ ldiamond 10 10 "d1"
+         _ <- drawi $ drawShape $ translate 400 50 $ lrectangle 20 100 "R2"
+         return ()
+
+
+
+
+petri_net :: DPicture
+petri_net = liftToPictureU $ execDrawing (standardContext 14) $ do
+              pw     <- place 0 140
+              tu1    <- transition 70 140
+              rtw    <- place 140 140
+              tu2    <- transition 210 140
+              w      <- place 280 140
+              tu3    <- transition 350 140
+              res    <- place 280 70
+              pr     <- place 0 0
+              tl1    <- transition 70 0
+              rtr    <- place 140 0
+              tl2    <- transition 210 0
+              r      <- place 280 0
+              tl3    <- transition 350 0
+              connector (east pw)  (west tu1)              
+              connector (east tu1) (west rtw)
+              connector (east rtw) (west tu2)
+              connector (east tu2) (west w)
+              connector (east w)   (west tu3)
+              connectorC 32 (north tu3) (north pw)
+              connector (east pr)  (west tl1)              
+              connector (east tl1) (west rtr)
+              connector (east rtr) (west tl2)
+              connector (east tl2) (west r)
+              connector (east r)   (west tl3)
+              connectorC (-32) (south tl3) (south pr)
+              connector (southwest res) (northeast tl2)
+              connector (northwest tl3) (southeast res)
+              connectorD 6    (southwest tu3) (northeast res)
+              connectorD (-6) (southwest tu3) (northeast res) 
+              connectorD 6    (northwest res) (southeast tu2)
+              connectorD (-6) (northwest res) (southeast tu2) 
+              draw $ lblParensParens `at` (P2 (-36) 150)
+              draw $ lblParensParens `at` (P2 300 60)
+              draw $ lblParensParensParens `at` (P2 (-52) (-14))
+              draw $ lblBold "processing_w"   `at` (southwards 12 pw)
+              draw $ lblBold "ready_to_write" `at` (southwards 12 rtw)
+              draw $ lblBold "writing"        `at` (southwards 12 w)
+              draw $ lblBold' "resource"      `at` (P2 300 72)
+              draw $ lblBold "processing_r"   `at` (northwards 12 pr)
+              draw $ lblBold "ready_to_read"  `at` (northwards 12 rtr)
+              draw $ lblBold "reading"        `at` (northwards 12 r)
+              return ()
+
+greenFill :: DrawingCtxM m => m a -> m a
+greenFill = localCtx (secondaryColour lime_green)
+
+place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) 
+      => u -> u -> m (Circle u)
+place x y = greenFill $ drawi $ drawShape $ translate x y $ circle 14
+
+transition :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) 
+           => u -> u -> m (Rectangle u)
+transition x y = greenFill $ drawi $ drawShape $ translate x y $ rectangle 32 22
+
+connector :: ( Real u, Floating u, FromPtSize u
+             , DrawingCtxM m, TraceM m, u ~ MonUnit m )
+          => Point2 u -> Point2 u -> m ()
+connector p1 p2 = do
+   _ <- drawi $ arrowTri60 connectS `conn` p1 $ p2
+   return ()
+
+
+connectorC :: ( Real u, Floating u, FromPtSize u
+             , DrawingCtxM m, TraceM m, u ~ MonUnit m )
+           => u -> Point2 u -> Point2 u -> m ()
+connectorC v p1 p2 = do
+    _ <- drawi $ arrowTri60 (arbv v) `conn` p1 $ p2
+    return ()
+
+connectorD :: ( Real u, Floating u, FromPtSize u
+             , DrawingCtxM m, TraceM m, u ~ MonUnit m )
+           => u -> Point2 u -> Point2 u -> m ()
+connectorD u p1 p2 = do
+    _ <- drawi $ arrowTri60 (joint u) `conn` p1 $ p2
+    return ()
+
+
+lblParensParens :: Num u => LocGraphic u
+lblParensParens = localLG (fontface helvetica) $ textline "(),()"
+
+lblParensParensParens :: Num u => LocGraphic u
+lblParensParensParens = localLG (fontface helvetica) $ textline "(),(),()"
+
+
+lblBold' :: Num u => String -> LocGraphic u
+lblBold' ss = localLG (fontface helveticaBold) $ textline ss
+
+
+lblBold :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u
+lblBold ss = localLG (fontface helveticaBold) $ centermonoTextline ss
diff --git a/demo/Symbols.hs b/demo/Symbols.hs
new file mode 100644
--- /dev/null
+++ b/demo/Symbols.hs
@@ -0,0 +1,261 @@
+{-# OPTIONS -Wall #-}
+
+module Symbols where
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.SafeFonts
+import Wumpus.Basic.Text.LRSymbol
+import Wumpus.Basic.Text.LRText
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Control.Monad
+import Prelude hiding ( pi, product )
+
+import System.Directory
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    demo01
+
+
+demo01 :: IO ()
+demo01 = do 
+    writeEPS_latin1 "./out/symbols.eps" pic1
+    writeSVG_latin1 "./out/symbols.svg" pic1
+
+std_ctx :: DrawingContext
+std_ctx = fontface timesRoman $ standardContext 12
+
+pic1 :: DPicture 
+pic1 = liftToPictureU $ execDrawing std_ctx $ do
+         zipWithM_ mdraw letters_01 column_01
+         zipWithM_ sdraw letters_01 column_01
+         zipWithM_ mdraw letters_02 column_02
+         zipWithM_ sdraw letters_02 column_02
+         zipWithM_ mdraw letters_03 column_03
+         zipWithM_ sdraw letters_03 column_03
+         zipWithM_ mdraw letters_04 column_04
+         zipWithM_ sdraw letters_04 column_04
+         zipWithM_ mdraw letters_05 column_05
+         zipWithM_ sdraw letters_05 column_05
+         zipWithM_ mdraw letters_06 column_06
+         zipWithM_ sdraw letters_06 column_06
+
+  where
+    mdraw (_,ma) pt = draw $ execLRText ma `at` pt
+    sdraw (s,_)  pt = draw $ textline s `at` pt .+^ hvec 16
+
+letters_01 :: [(String, LRText Double ())]
+letters_01 = 
+    [ ("uAlpha",                uAlpha) 
+    , ("uBeta",                 uBeta)
+    , ("uChi",                  uChi)
+    , ("uDelta",                uDelta)
+    , ("uEpsilon",              uEpsilon)
+    , ("uEta",                  uEta)
+    , ("uEuro",                 uEuro)
+    , ("uGamma",                uGamma)
+    , ("uIfraktur",             uIfraktur)
+    , ("uIota",                 uIota)
+    , ("uKappa",                uKappa)
+    , ("uLambda",               uLambda)
+    , ("uMu",                   uMu)
+    , ("uNu",                   uNu)
+    , ("uOmega",                uOmega)
+    , ("uOmicron",              uOmicron)
+    , ("uPhi",                  uPhi)
+    , ("uPi",                   uPi)
+    , ("uPsi",                  uPsi)
+    , ("uRfraktur",             uRfraktur)
+    , ("uRho",                  uRho)
+    , ("uSigma",                uSigma)
+    , ("uTau",                  uTau)
+    , ("uTheta",                uTheta)
+    , ("uUpsilon",              uUpsilon)
+    , ("uUpsilon1",             uUpsilon1)
+    , ("uXi",                   uXi)
+    , ("uZeta",                 uZeta)
+    , ("aleph",                 aleph)
+    , ("alpha",                 alpha)
+    , ("ampersand",             ampersand)
+    , ("angle",                 angle)
+    , ("angleleft",             angleleft)
+    , ("angleright",            angleright)
+    , ("approxequal",           approxequal)
+    ]
+
+letters_02 :: [(String, LRText Double ())]
+letters_02 = 
+    [ ("arrowboth",             arrowboth) 
+    , ("arrowdblboth",          arrowdblboth)
+    , ("arrowdbldown",          arrowdbldown)
+    , ("arrowdblleft",          arrowdblleft)
+    , ("arrowdblright",         arrowdblright)
+    , ("arrowdblup",            arrowdblup)
+    , ("arrowdown",             arrowdown)
+    , ("arrowleft",             arrowleft)
+    , ("arrowright",            arrowright)
+    , ("arrowup",               arrowup)
+    , ("asteriskmath",          asteriskmath)
+    , ("bar",                   bar)
+    , ("beta",                  beta)
+    , ("braceleft",             braceleft)
+    , ("braceright",            braceright)
+    , ("bracketleft",           bracketleft)
+    , ("bracketright",          bracketright)
+    , ("bullet",                bullet)
+    , ("carriagereturn",        carriagereturn)
+    , ("chi",                   chi)
+    ]
+
+letters_03 :: [(String, LRText Double ())]
+letters_03 = 
+    [ ("circlemultiply",        circlemultiply) 
+    , ("circleplus",            circleplus)
+    , ("club",                  club)
+    , ("colon",                 colon)
+    , ("comma",                 comma)
+    , ("congruent",             congruent)
+    , ("copyrightsans",         copyrightsans)
+    , ("copyrightserif",        copyrightserif)
+    , ("degree",                degree)
+    , ("delta",                 delta)
+    , ("diamond",               diamond)
+    , ("divide",                divide)
+    , ("dotmath",               dotmath)
+    , ("eight",                 eight)
+    , ("element",               element)
+    , ("ellipsis",              ellipsis)
+    , ("emptyset",              emptyset)
+    , ("epsilon",               epsilon)
+    , ("equal",                 equal)
+    , ("equivalence",           equivalence)
+    , ("eta",                   eta)
+    , ("exclam",                exclam)
+    , ("existential",           existential)
+    , ("five",                  five)
+    , ("florin",                florin)
+    , ("four",                  four)
+    , ("fraction",              fraction)
+    , ("gamma",                 gamma)
+    , ("gradient",              gradient)
+    , ("greater",               greater)
+    , ("greaterequal",          greaterequal)
+    , ("heart",                 heart)
+    , ("infinity",              infinity)
+    , ("integral",              integral)
+    ]
+
+
+letters_04 :: [(String, LRText Double ())]
+letters_04 = 
+    [ ("intersection",          intersection)
+    , ("iota",                  iota)
+    , ("kappa",                 kappa)
+    , ("lambda",                lambda)
+    , ("less",                  less)
+    , ("lessequal",             lessequal)
+    , ("logicaland",            logicaland)
+    , ("logicalnot",            logicalnot)
+    , ("logicalor",             logicalor)
+    , ("lozenge",               lozenge)
+    , ("minus",                 minus)
+    , ("minute",                minute)
+    , ("mu",                    mu)
+    , ("multiply",              multiply)
+    , ("nine",                  nine)
+    , ("notelement",            notelement)
+    , ("notequal",              notequal)
+    , ("notsubset",             notsubset)
+    , ("nu",                    nu)
+    , ("numbersign",            numbersign)
+    , ("omega",                 omega)
+    , ("omega1",                omega1)
+    , ("omicron",               omicron)
+    , ("one",                   one)
+    , ("parenleft",             parenleft)
+    , ("parenright",            parenright)
+    ]
+
+letters_05 :: [(String, LRText Double ())]
+letters_05 = 
+    [ ("partialdiff",           partialdiff)
+    , ("percent",               percent)
+    , ("period",                period)
+    , ("perpendicular",         perpendicular)
+    , ("phi",                   phi)
+    , ("phi1",                  phi1)
+    , ("pi",                    pi)
+    , ("plus",                  plus)
+    , ("plusminus",             plusminus)
+    , ("product",               product)
+    , ("propersubset",          propersubset)
+    , ("propersuperset",        propersuperset)
+    , ("proportional",          proportional)
+    , ("psi",                   psi)
+    , ("question",              question)
+    , ("radical",               radical)
+    , ("radicalex",             radicalex)
+    , ("reflexsubset",          reflexsubset)
+    , ("reflexsuperset",        reflexsuperset)
+    , ("registersans",          registersans)
+    , ("registerserif",         registerserif)
+    , ("rho",                   rho)
+    ]
+
+letters_06 :: [(String, LRText Double ())]
+letters_06 = 
+    [ ("second",                second)
+    , ("semicolon",             semicolon)
+    , ("seven",                 seven)
+    , ("sigma",                 sigma)
+    , ("sigma1",                sigma1)
+    , ("similar",               similar)
+    , ("six",                   six)
+    , ("slash",                 slash)
+    , ("space",                 space)
+    , ("spade",                 spade)
+    , ("suchthat",              suchthat)
+    , ("summation",             summation)
+    , ("tau",                   tau)
+    , ("therefore",             therefore)
+    , ("theta",                 theta)
+    , ("theta1",                theta1)
+    , ("three",                 three)
+    , ("trademarksans",         trademarksans)
+    , ("trademarkserif",        trademarkserif)
+    , ("two",                   two)
+    , ("underscore",            underscore)
+    , ("union",                 union)
+    , ("universal",             universal)
+    , ("upsilon",               upsilon)
+    , ("weierstrass",           weierstrass)
+    , ("xi",                    xi)
+    , ("zero",                  zero)
+    , ("zeta",                  zeta)
+    ]
+
+-- TODO - this should use a chain when the Chain API stablizes.
+
+column_01 :: Num u => [Point2 u]
+column_01 = iterate (.+^ vvec (-16)) (P2 0 600)
+
+column_02 :: Num u => [Point2 u]
+column_02 = iterate (.+^ vvec (-16)) (P2 100 600)
+
+column_03 :: Num u => [Point2 u]
+column_03 = iterate (.+^ vvec (-16)) (P2 200 600)
+
+column_04 :: Num u => [Point2 u]
+column_04 = iterate (.+^ vvec (-16)) (P2 300 600)
+
+column_05 :: Num u => [Point2 u]
+column_05 = iterate (.+^ vvec (-16)) (P2 400 600)
+
+column_06 :: Num u => [Point2 u]
+column_06 = iterate (.+^ vvec (-16)) (P2 500 600)
diff --git a/src/Wumpus/Basic/Anchors.hs b/src/Wumpus/Basic/Anchors.hs
--- a/src/Wumpus/Basic/Anchors.hs
+++ b/src/Wumpus/Basic/Anchors.hs
@@ -28,10 +28,23 @@
   , TextAnchor(..)
   , RadialAnchor(..)
 
+  -- * extended anchor points
+  , northwards
+  , southwards
+  , eastwards
+  , westwards
+  , northeastwards
+  , southeastwards
+  , southwestwards
+  , northwestwards
+
+  , radialConnectorPoints
+
   ) where
 
 import Wumpus.Core                      -- package: wumpus-core
 
+import Data.AffineSpace                 -- package: vector-space
 
 class CenterAnchor t where
   center :: DUnit t ~ u => t -> Point2 u
@@ -66,3 +79,67 @@
 class RadialAnchor t where
   radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u
 
+
+extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u
+extendPtDist d p1 p2 = let v   = pvec p1 p2
+                           ang = direction v
+                           len = vlength v
+                       in p1 .+^ avec ang (len+d)
+
+
+
+northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
+              , u ~ DUnit t ) 
+           => u -> t -> Point2 u
+northwards u a = extendPtDist u (center a) (north a)
+
+
+southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
+              , u ~ DUnit t ) 
+           => u -> t -> Point2 u
+southwards u a = extendPtDist u (center a) (south a)
+
+eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
+             , u ~ DUnit t ) 
+          => u -> t -> Point2 u
+eastwards u a = extendPtDist u (center a) (east a)
+
+westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
+             , u ~ DUnit t ) 
+          => u -> t -> Point2 u
+westwards u a = extendPtDist u (center a) (west a)
+
+
+northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
+                  , u ~ DUnit t ) 
+               => u -> t -> Point2 u
+northeastwards u a = extendPtDist u (center a) (northeast a)
+
+
+southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
+                  , u ~ DUnit t ) 
+               => u -> t -> Point2 u
+southeastwards u a = extendPtDist u (center a) (southeast a)
+
+southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
+                  , u ~ DUnit t ) 
+               => u -> t -> Point2 u
+southwestwards u a = extendPtDist u (center a) (southwest a)
+
+northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
+                  , u ~ DUnit t ) 
+               => u -> t -> Point2 u
+northwestwards u a = extendPtDist u (center a) (northwest a)
+
+
+--------------------------------------------------------------------------------
+
+radialConnectorPoints :: ( Real u, Floating u
+                         , CenterAnchor t1, RadialAnchor t1
+                         , CenterAnchor t2, RadialAnchor t2
+                         , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) 
+                      => t1 -> t2 -> (Point2 u, Point2 u) 
+radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b)
+  where
+    theta = direction $ pvec (center a) (center b)
+    
diff --git a/src/Wumpus/Basic/Arrows.hs b/src/Wumpus/Basic/Arrows.hs
--- a/src/Wumpus/Basic/Arrows.hs
+++ b/src/Wumpus/Basic/Arrows.hs
@@ -40,7 +40,6 @@
 import Wumpus.Basic.Arrows.Tips
 import Wumpus.Basic.Graphic
 import Wumpus.Basic.Paths
-import Wumpus.Basic.Paths.Base
 import Wumpus.Basic.Utils.Intersection ( langle )
 
 import Wumpus.Core                      -- package: wumpus-core
@@ -48,11 +47,11 @@
 import Control.Applicative
 import Data.Monoid
 
-liftPathF :: PathF u -> ConnDrawingF u (Path u)
-liftPathF pF p1 p2 = pureDF $ pF p1 p2
+liftConnPath :: ConnPath u -> ConnDrawingF u (Path u)
+liftConnPath pF p1 p2 = pureDF $ pF p1 p2
 
-line :: Num u => PathF u -> ConnImage u (Path u)
-line pathF = intoConnImage (liftPathF pathF) (pathGraphic pathF)
+line :: Num u => ConnPath u -> ConnImage u (Path u)
+line pathF = intoConnImage (liftConnPath pathF) (pathGraphic pathF)
 
 
 -- Here the path is already shortened - we have accounted for the
@@ -74,10 +73,10 @@
 -- path segments.
 --
 rightPathProps :: (Real u, Floating u, FromPtSize u) 
-               => PathF u -> ConnDrawingF u (Path u,Radian)
+               => ConnPath u -> ConnDrawingF u (Path u,Radian)
 rightPathProps pathF p1 p2 = 
     (\h sw -> (shortenPath h sw, calcTheta h))
-      <$> asksDF lowerxHeight <*> asksDF (line_width . stroke_props)  
+      <$> markHeight <*> lineWidth
   where
     long_path          = pathF p1 p2  
     shortenPath lxh sw = shortenR (lxh + (realToFrac sw)) long_path 
@@ -87,7 +86,7 @@
 
 
 triTipRight :: (Real u, Floating u, FromPtSize u) 
-            => PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u) 
+            => ConnPath u -> (Radian -> LocGraphic u) -> ConnImage u (Path u) 
 triTipRight pathF tipF p1 p2 =
     rightPathProps pathF p1 p2          >>= \(shortF,theta) -> 
     lineTipR shortF (tipF theta p2)     >>= \arrow_pic      ->
@@ -99,7 +98,7 @@
 -- This version does not /retract/ the path...
 --
 barbTipRight :: (Real u, Floating u, FromPtSize u) 
-             => PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)  
+             => ConnPath u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)  
 barbTipRight pathF tipF p1 p2 = 
     rightPathProps pathF p1 p2          >>= \(_,theta) -> 
     lineTipR path_zero (tipF theta p2)  >>= \arrow_pic  ->
@@ -110,55 +109,55 @@
 
 
 arrowTri90 :: (Real u, Floating u, FromPtSize u) 
-           => PathF u -> ConnImage u (Path u)
+           => ConnPath u -> ConnImage u (Path u)
 arrowTri90 pathF = triTipRight pathF tri90
  
           
 
 
 arrowTri60 :: (Real u, Floating u, FromPtSize u) 
-           => PathF u -> ConnImage u (Path u)
+           => ConnPath u -> ConnImage u (Path u)
 arrowTri60 pathF = triTipRight pathF tri60
 
  
 arrowTri45 :: (Real u, Floating u, FromPtSize u) 
-           => PathF u -> ConnImage u (Path u)
+           => ConnPath u -> ConnImage u (Path u)
 arrowTri45 pathF = triTipRight pathF tri45
 
 
 arrowOTri90 :: (Real u, Floating u, FromPtSize u) 
-            => PathF u -> ConnImage u (Path u)
+            => ConnPath u -> ConnImage u (Path u)
 arrowOTri90 pathF = triTipRight pathF otri90
      
 
 arrowOTri60 :: (Real u, Floating u, FromPtSize u) 
-            => PathF u -> ConnImage u (Path u)
+            => ConnPath u -> ConnImage u (Path u)
 arrowOTri60 pathF = triTipRight pathF otri60 
 
 
 
 arrowOTri45 :: (Real u, Floating u, FromPtSize u) 
-            => PathF u -> ConnImage u (Path u)
+            => ConnPath u -> ConnImage u (Path u)
 arrowOTri45 pathF = triTipRight pathF otri45
 
 
 
 arrowBarb90 :: (Real u, Floating u, FromPtSize u) 
-            => PathF u -> ConnImage u (Path u)
+            => ConnPath u -> ConnImage u (Path u)
 arrowBarb90 pathF = barbTipRight pathF barb90
 
 arrowBarb60 :: (Real u, Floating u, FromPtSize u) 
-            => PathF u -> ConnImage u (Path u)
+            => ConnPath u -> ConnImage u (Path u)
 arrowBarb60 pathF = barbTipRight pathF barb60
 
 arrowBarb45 :: (Real u, Floating u, FromPtSize u) 
-            => PathF u -> ConnImage u (Path u)
+            => ConnPath u -> ConnImage u (Path u)
 arrowBarb45 pathF = barbTipRight pathF barb45
 
 
                      
 arrowPerp :: (Real u, Floating u, FromPtSize u) 
-          => PathF u -> ConnImage u (Path u)
+          => ConnPath u -> ConnImage u (Path u)
 arrowPerp pathF p1 p2 = 
     lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic)
   where
diff --git a/src/Wumpus/Basic/Arrows/Tips.hs b/src/Wumpus/Basic/Arrows/Tips.hs
--- a/src/Wumpus/Basic/Arrows/Tips.hs
+++ b/src/Wumpus/Basic/Arrows/Tips.hs
@@ -51,7 +51,7 @@
 tripoints triang theta tip = 
     (\h -> let d = h / (fromRadian $ cos halfang) 
            in (tip .-^ v1 d, tip .-^ v2 d))
-      <$> asksDF lowerxHeight
+      <$> markHeight
   where
     halfang = 0.5 * triang
     v1 d    = avec (theta + halfang) d
@@ -68,7 +68,8 @@
       -> (PrimPath u -> Graphic u) 
       -> LocGraphic u
 triAng triang theta gf pt = 
-    tripoints triang theta pt >>= \(u,v) -> gf (vertexPath [pt,u,v])
+    tripoints triang theta pt >>= \(u,v) -> 
+    localDF bothPrimary (gf $  vertexPath [pt,u,v])
 
 
 
@@ -124,7 +125,7 @@
 
 perp :: (Floating u, FromPtSize u) => Radian -> LocGraphic u
 perp theta pt =  
-    asksDF lowerxHeight >>= \ h -> 
+    markHeight >>= \ h -> 
     let v = makeV h in openStroke $ vertexPath [ pt .+^ v, pt .-^ v]
   where
     makeV h  = avec (theta + pi/2) (0.5 * h)
diff --git a/src/Wumpus/Basic/Chains.hs b/src/Wumpus/Basic/Chains.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Chains.hs
@@ -0,0 +1,29 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Chains
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Shim module.
+--
+-- WARNING - very unstable.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Chains
+  (
+    module Wumpus.Basic.Chains.Base
+  , module Wumpus.Basic.Chains.Derived
+  
+
+  ) where
+
+
+import Wumpus.Basic.Chains.Base
+import Wumpus.Basic.Chains.Derived
diff --git a/src/Wumpus/Basic/Chains/Base.hs b/src/Wumpus/Basic/Chains/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Chains/Base.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Chains.Base
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Generate points in an iterated chain.
+--
+-- WARNING - very unstable.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Chains.Base
+  (
+
+
+    Chain
+  , LocChain
+  , chain
+  , chainFrom
+  , unchain
+
+
+  , AnaAlg(..)
+  , IterAlg(..)
+
+  , BivariateAlg
+  , bivariate
+  
+  , SequenceAlg
+  , iteration
+
+  , bounded
+  , pairOnXs
+  , pairOnYs
+
+  ) where
+
+import Wumpus.Basic.Graphic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+-- Chain uses the Scaling monad, but it is not itself a monad.
+
+
+newtype Chain ux uy u = Chain { getChain :: Scaling ux uy u [Point2 u] }
+
+
+type LocChain ux uy u = Point2 u -> Chain ux uy u
+
+
+
+chain :: BivariateAlg ux uy -> Chain ux uy u
+chain alg = Chain (scaledBivariatePt alg)
+
+chainFrom :: Num u => BivariateAlg ux uy -> LocChain ux uy u
+chainFrom alg start = Chain (scaledBivariateVec alg start)
+
+
+unchain :: ScalingContext ux uy u -> Chain ux uy u -> [Point2 u]
+unchain ctx ch = runScaling ctx $ getChain ch
+ 
+
+-- | Chains are built as unfolds - AnaAlg avoids the pair 
+-- constructor in the usual definition of unfoldr and makes the
+-- state strict.
+--
+-- It is expected that all Chains built on unfolds will terminate. 
+--
+data AnaAlg st a = Done | Step a !st
+
+
+-- | IterAlg is a variant of AnaAlg that builds infinite 
+-- sequences (iterations).
+-- 
+-- When lifted to a Chain an iteration is bounded by a count so
+-- it will terminate.
+--
+data IterAlg st a = IterStep a !st 
+
+
+data BivariateAlg ux uy = forall st. BivariateAlg
+      { st_zero     :: st
+      , gen_step    :: st -> AnaAlg st (ux,uy)
+      }
+
+bivariate :: st -> (st -> AnaAlg st (ux,uy)) -> BivariateAlg ux uy
+bivariate st0 step_alg = BivariateAlg { st_zero = st0
+                                      , gen_step = step_alg }
+
+
+scaledBivariatePt :: BivariateAlg ux uy -> Scaling ux uy u [Point2 u]
+scaledBivariatePt (BivariateAlg { st_zero = st0, gen_step = step}) = 
+    go (step st0)   
+  where
+    go Done              = return []
+    go (Step (x,y) next) = scalePt x y    >>= \pt   ->
+                           go (step next) >>= \rest ->  
+                           return  (pt:rest)
+
+-- Note - cannot encode this with (.+^) from Data.AffineSpace.
+-- The u (u ~ MonUnit m) extracted from the Scaling Context is 
+-- not compatible with the u that forms Points (u ~ Diff (Point2 u)).
+
+scaledBivariateVec :: Num u 
+                   => BivariateAlg ux uy 
+                   -> Point2 u 
+                   -> Scaling ux uy u [Point2 u]
+scaledBivariateVec (BivariateAlg { st_zero = st0, gen_step = step}) (P2 x0 y0) = 
+    go (step st0)   
+  where
+    go Done              = return []
+    go (Step (x,y) next) = scaleVec x y   >>= \(V2 dx dy)   ->
+                           go (step next) >>= \rest ->  
+                           return (P2 (x0+dx) (y0+dy):rest)
+
+
+data SequenceAlg a = forall st. SequenceAlg
+      { initial_st  :: st
+      , iter_step   :: st -> IterAlg st a
+      }
+
+iteration :: (a -> a) -> a -> SequenceAlg a
+iteration fn s0 = SequenceAlg { initial_st = s0, iter_step = step }
+  where
+    step s = IterStep s (fn s)
+
+
+bounded :: Int -> SequenceAlg (ux,uy) -> BivariateAlg ux uy
+bounded n (SequenceAlg a0 fn) =
+    BivariateAlg { st_zero     = (0,a0)
+                 , gen_step    = gstep  }
+  where
+    gstep (i,s) | i < n = let (IterStep ans next) = fn s in Step ans (i+1,next)
+    gstep _             = Done
+
+
+
+
+pairOnXs :: (ux -> uy) -> SequenceAlg ux -> SequenceAlg (ux,uy)
+pairOnXs fn (SequenceAlg { initial_st = s0, iter_step = step }) = 
+    SequenceAlg s0 step2
+  where
+    step2 s = let (IterStep a s') = step s in IterStep (a, fn a) s'
+
+
+pairOnYs :: (r -> l) -> SequenceAlg r -> SequenceAlg (l,r) 
+pairOnYs fn (SequenceAlg { initial_st = s0, iter_step = step }) = 
+    SequenceAlg  s0 step2
+  where
+    step2 s = let (IterStep a s') = step s in IterStep (fn a, a) s'
+
diff --git a/src/Wumpus/Basic/Chains/Derived.hs b/src/Wumpus/Basic/Chains/Derived.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Chains/Derived.hs
@@ -0,0 +1,129 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Chains.Derived
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Generate points in an iterated chain.
+--
+-- WARNING - very unstable.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Chains.Derived
+  (
+    
+    univariateX
+  , univariateY
+
+  , tableDown
+  , tableRight
+
+  , horizontal
+  , vertical
+
+  , horizontals
+  , verticals
+
+  , rescale
+
+  ) where
+
+import Wumpus.Basic.Chains.Base
+
+
+
+
+univariateX :: (Fractional uy, Num ux, Num u) 
+            => [ux] -> LocChain ux uy u
+univariateX zs = chainFrom $ bivariate (0,zs) gstep
+  where
+    gstep (_,[])     = Done 
+    gstep (n,x:xs)   = Step (x,n) (n+i,xs)
+    len              = length zs
+    i                = rescale 0 1 0 (fromIntegral $ len-1) 1
+
+
+univariateY :: (Fractional ux, Num uy, Num u) 
+            => [uy] -> LocChain ux uy u
+univariateY zs = chainFrom $ bivariate (0,zs) gstep
+  where
+    gstep (_,[])     = Done 
+    gstep (n,y:ys)   = Step (n,y) (n+i,ys)
+    len              = length zs
+    i                = rescale 0 1 0 (fromIntegral $ len-1) 1
+
+
+
+--------------------------------------------------------------------------------
+-- Tables
+
+
+tableDown :: Int -> Int -> Chain Int Int u
+tableDown rows cols = 
+    chain $ bounded (rows*cols) (iteration (downstep rows) (0,rows-1))
+
+
+
+downstep :: Int -> (Int,Int) -> (Int,Int)
+downstep row_count (x,y) | y == 0 = (x+1,row_count-1)
+downstep _         (x,y)          = (x,y-1)
+
+
+
+tableRight :: Num u => Int -> Int -> Chain Int Int u
+tableRight rows cols = 
+    chain $ bounded (rows*cols) (iteration (rightstep cols) (0,rows-1))
+
+
+rightstep :: Int -> (Int,Int) -> (Int,Int)
+rightstep col_count (x,y) | x == (col_count-1) = (0,y-1)
+rightstep _         (x,y)                      = (x+1,y)
+
+
+horizontal :: Int -> Chain Int Int u
+horizontal count = chain $ bivariate 0 alg
+  where
+    alg st | st == count = Done
+    alg st               = Step (st,0) (st+1)
+
+
+vertical :: Int -> Chain Int Int u
+vertical count = chain $ bivariate 0 alg
+  where
+    alg st | st == count = Done
+    alg st               = Step (0,st) (st+1)
+
+
+
+horizontals :: (Num ua, Num u) => [ua] -> LocChain ua ua u
+horizontals xs0 = chainFrom $ bivariate xs0 alg
+  where
+    alg []     = Done
+    alg (x:xs) = Step (x,0) xs
+
+
+verticals :: (Num ua, Num u)  => [ua] -> LocChain ua ua u
+verticals ys0 = chainFrom $ bivariate ys0 alg
+  where
+    alg []     = Done
+    alg (y:ys) = Step (0,y) ys
+
+
+--------------------------------------------------------------------------------
+-- general helpers
+
+rescale :: Fractional a => a -> a -> a -> a -> a -> a
+rescale outmin outmax innmin innmax a = 
+    outmin + innpos * (outrange / innrange)  
+  where
+    outrange = outmax - outmin
+    innrange = innmax - innmin
+    innpos   = a - innmin 
+
diff --git a/src/Wumpus/Basic/Dots.hs b/src/Wumpus/Basic/Dots.hs
--- a/src/Wumpus/Basic/Dots.hs
+++ b/src/Wumpus/Basic/Dots.hs
@@ -149,7 +149,7 @@
                                  (radialCardinal rad ctr)
 
 circleLDO :: (Floating u, FromPtSize u) => LocDrawingF u (DotAnchor u)
-circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> asksDF markHeight 
+circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> markHeight 
 
 
 
@@ -161,13 +161,13 @@
 
 dotChar :: (Floating u, Real u, FromPtSize u) 
         => Char -> DotLocImage u
-dotChar ch pt = asksDF (textDimensions [ch]) >>= \(w,h) -> 
+dotChar ch pt = monoTextDimensions [ch] >>= \(w,h) -> 
                 intoLocImage (rectangleLDO w h) (markChar ch) pt
 
 
 dotText :: (Floating u, Real u, FromPtSize u) 
         => String -> DotLocImage u 
-dotText ss pt = asksDF (textDimensions ss) >>= \(w,h) -> 
+dotText ss pt = monoTextDimensions ss >>= \(w,h) -> 
                 intoLocImage (rectangleLDO w h) (markText ss) pt
 
 
@@ -201,7 +201,7 @@
 
 
 dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u
-dotSquare pt = asksDF markHeight >>= \ h ->
+dotSquare pt = markHeight >>= \ h ->
                intoLocImage (rectangleLDO h h) markSquare pt
 
 
diff --git a/src/Wumpus/Basic/Dots/Primitive.hs b/src/Wumpus/Basic/Dots/Primitive.hs
--- a/src/Wumpus/Basic/Dots/Primitive.hs
+++ b/src/Wumpus/Basic/Dots/Primitive.hs
@@ -82,18 +82,18 @@
 -- | A mark is the height of a lowercase \'x\'.
 -- 
 standardSize :: FromPtSize u => (u -> LocGraphic u) -> LocGraphic u
-standardSize f = \pt -> asksDF markHeight >>= \h -> f h pt
+standardSize f = \pt -> markHeight >>= \h -> f h pt
 
 halfHeightSize :: (Fractional u, FromPtSize u) 
                => (u -> LocGraphic u) -> LocGraphic u
-halfHeightSize f = \pt -> asksDF markHeight >>= \h -> f (h * 0.5) pt
+halfHeightSize f = \pt -> markHeight >>= \h -> f (h * 0.5) pt
 
 
 
 shiftOrigin :: Num u => u -> u -> LocGraphic u -> LocGraphic u
 shiftOrigin dx dy f = \pt -> f (displace dx dy pt)
 
-markChar :: (Fractional u, FromPtSize u) => Char -> LocGraphic u
+markChar :: (Fractional u, Ord u, FromPtSize u) => Char -> LocGraphic u
 markChar ch = markText [ch]
 
 
@@ -101,9 +101,8 @@
 
 -- Note - eta-expanded (?)
 --
-markText :: (Fractional u, FromPtSize u) => String -> LocGraphic u
-markText ss pt = asksDF (textDimensions ss) >>= \(w,h) -> 
-                 shiftOrigin (0.5 * (-w)) (0.5 * (-h)) (textline ss) pt
+markText :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u
+markText ss = centermonoTextline ss
 
 
 
@@ -148,7 +147,7 @@
             => Point2 u -> DrawingF (PrimPath u)
 pathDiamond pt = (\h -> let hh    = 0.66 * h; hw = 0.5 * h 
                         in vertexPath [dvs hh, dve hw,dvn hh, dvw hw])
-                   <$> asksDF markHeight
+                   <$> markHeight
   where
     dvs hh = pt .+^ vvec (-hh)
     dve hw = pt .+^ hvec hw
@@ -190,14 +189,14 @@
 
 
 markPentagon :: (Floating u, FromPtSize u) => LocGraphic u
-markPentagon pt = asksDF markHeight >>= \h ->
+markPentagon pt = markHeight >>= \h ->
                   closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt
 
  
 
 
 markStar :: (Floating u, FromPtSize u) => LocGraphic u 
-markStar pt = asksDF markHeight >>= \h -> 
+markStar pt = markHeight >>= \h -> 
               let ps = polygonPoints 5 (0.5*h) pt in mconcat $ map fn ps
   where
     fn p1  = openStroke $ path pt [lineTo p1] 
diff --git a/src/Wumpus/Basic/Graphic.hs b/src/Wumpus/Basic/Graphic.hs
--- a/src/Wumpus/Basic/Graphic.hs
+++ b/src/Wumpus/Basic/Graphic.hs
@@ -19,15 +19,17 @@
   (
     module Wumpus.Basic.Graphic.BaseClasses
   , module Wumpus.Basic.Graphic.BaseTypes
-  , module Wumpus.Basic.Graphic.Chain
   , module Wumpus.Basic.Graphic.Drawing
   , module Wumpus.Basic.Graphic.DrawingContext
   , module Wumpus.Basic.Graphic.PrimGraphic
+  , module Wumpus.Basic.Graphic.Query
+  , module Wumpus.Basic.Graphic.ScalingContext
   ) where
 
 import Wumpus.Basic.Graphic.BaseClasses
 import Wumpus.Basic.Graphic.BaseTypes
-import Wumpus.Basic.Graphic.Chain
 import Wumpus.Basic.Graphic.Drawing
 import Wumpus.Basic.Graphic.DrawingContext
 import Wumpus.Basic.Graphic.PrimGraphic
+import Wumpus.Basic.Graphic.Query
+import Wumpus.Basic.Graphic.ScalingContext
diff --git a/src/Wumpus/Basic/Graphic/BaseClasses.hs b/src/Wumpus/Basic/Graphic/BaseClasses.hs
--- a/src/Wumpus/Basic/Graphic/BaseClasses.hs
+++ b/src/Wumpus/Basic/Graphic/BaseClasses.hs
@@ -28,6 +28,8 @@
   , DrawingCtxM(..)
   , asksCtx  
 
+  , ScalingM(..)
+ 
   , PointSupplyM(..)
 
   ) where
@@ -41,8 +43,8 @@
 
 
 
--- DUnit is always for fully saturated types, so (seemingly) an equivalent
--- type family is needed.
+-- DUnit is always for fully saturated type constructors, so 
+-- (seemingly) an equivalent type family is needed for monads.
 
 type family MonUnit m :: * 
 
@@ -63,6 +65,19 @@
 --
 asksCtx :: DrawingCtxM m => (DrawingContext -> a) -> m a
 asksCtx f = askCtx >>= (return . f)
+
+
+-- | Scaling...
+--
+class ScalingM m where
+  type XDim m :: *
+  type YDim m :: *
+  scaleX :: (u ~ MonUnit m, ux ~ XDim m) => ux -> m u
+  scaleY :: (u ~ MonUnit m, uy ~ YDim m) => uy -> m u
+  scalePt  :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) 
+           => ux -> uy -> m (Point2 u)
+  scaleVec :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) 
+           => ux -> uy -> m (Vec2 u)
 
 
 -- | A monad that supplies points, e.g. a turtle monad. 
diff --git a/src/Wumpus/Basic/Graphic/Chain.hs b/src/Wumpus/Basic/Graphic/Chain.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Graphic/Chain.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# OPTIONS -Wall #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Graphic.Chain
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- Supply points in an iterated chain.
---
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Graphic.Chain
-  (
-
-    ChainT
-  , runChainT
-  , horizontal
-
-  ) where
-
-import Wumpus.Basic.Graphic.BaseClasses
-import Wumpus.Basic.Graphic.BaseTypes
-
-import Wumpus.Core                              -- package: wumpus-core
-       
-import Control.Applicative
-import Control.Monad
-
-
-
-newtype ChainT u m a = ChainT { 
-          getChainT :: Point2F u -> Point2 u -> m (a, Point2 u) }
-
-
-type instance MonUnit (ChainT u m) = u
-
-
-
-instance Monad m => Functor (ChainT u m) where
-  fmap f ma = ChainT $ \rf s -> 
-                getChainT ma rf s >>= \(a,s1) -> return (f a, s1)
-
-
-instance Monad m => Applicative (ChainT u m) where
-  pure a    = ChainT $ \_  s -> return (a,s)
-  mf <*> ma = ChainT $ \rf s -> getChainT mf rf s  >>= \(f,s1) ->
-                                getChainT ma rf s1 >>= \(a,s2) ->
-                                return (f a, s2)
-
-
-instance Monad m => Monad (ChainT u m) where
-  return a = ChainT $ \_  s -> return (a,s)
-  m >>= k  = ChainT $ \rf s -> getChainT m rf s >>= \(a,s1) ->
-                               (getChainT . k) a rf s1
-                                     
-
-
-instance Monad m => PointSupplyM (ChainT u m) where
-  position = ChainT $ \rf s -> return (s, rf s)
-
-runChainT :: Monad m 
-          => Point2F u -> Point2 u -> ChainT u m a -> m a
-runChainT f pt0 ma = liftM fst $ getChainT ma f pt0
-
-horizontal :: (Num u, Monad m)
-           => Point2 u -> u -> ChainT u m a -> m a
-horizontal pt0 dx ma = runChainT f pt0 ma
-  where
-    f (P2 x y) = P2 (x+dx) y
-
-
-instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ChainT u m) where
-  trace a = ChainT $ \_ s -> trace a >> return ((), s)
-
-
-instance (Monad m, DrawingCtxM m) => DrawingCtxM (ChainT u m) where
-  askCtx         = ChainT $ \_ s -> askCtx >>= \ctx -> return (ctx, s)
-  localCtx cF ma = ChainT $ \r s -> localCtx cF (getChainT ma r s)
diff --git a/src/Wumpus/Basic/Graphic/Drawing.hs b/src/Wumpus/Basic/Graphic/Drawing.hs
--- a/src/Wumpus/Basic/Graphic/Drawing.hs
+++ b/src/Wumpus/Basic/Graphic/Drawing.hs
@@ -269,7 +269,9 @@
 mbPictureU Nothing  = error "mbPictureU - empty picture."
 mbPictureU (Just a) = a
 
-
+-- Note - need an equivalent to Parsec\`s parseTest that provides
+-- a very simple way to run graphics without concern for return 
+-- type or initial drawing context.
 
 --------------------------------------------------------------------------------
 
diff --git a/src/Wumpus/Basic/Graphic/DrawingContext.hs b/src/Wumpus/Basic/Graphic/DrawingContext.hs
--- a/src/Wumpus/Basic/Graphic/DrawingContext.hs
+++ b/src/Wumpus/Basic/Graphic/DrawingContext.hs
@@ -2,7 +2,7 @@
 
 --------------------------------------------------------------------------------
 -- |
--- Module      :  Wumpus.Basic.Graphic.DrawingAttr
+-- Module      :  Wumpus.Basic.Graphic.DrawingContext
 -- Copyright   :  (c) Stephen Tetley 2010
 -- License     :  BSD3
 --
@@ -27,10 +27,6 @@
     DrawingContext(..)
 
   , standardContext
-  , textAttr
-  , markHeight
-  , lowerxHeight
-  , textDimensions
 
   -- * Modifiers 
   -- ** Line widths
@@ -40,13 +36,24 @@
 
   -- ** Dash Pattern
   , dashPattern
+  , unit_dash_pattern
+  , phase
+  , dphase
+  , doublegaps
+  , doubledashes
 
   -- ** Font properties
   , fontsize
   , fontface
 
+  -- ** Mark drawing size
+  , doublesize
+  , halfsize
+
   -- ** Colour
   , swapColours
+  , bothPrimary
+  , bothSecondary
   , primaryColour
   , secondaryColour 
 
@@ -64,53 +71,28 @@
 import Control.Applicative
 
 data DrawingContext = DrawingContext
-      { stroke_props       :: StrokeAttr
-      , font_props         :: FontAttr
-      , primary_colour     :: RGBi      -- usually the stroke colour
-      , secondary_colour   :: RGBi      -- usually the fill colour
+      { stroke_props          :: StrokeAttr
+      , font_props            :: FontAttr
+      , primary_colour        :: RGBi      -- usually the stroke colour
+      , secondary_colour      :: RGBi      -- usually the fill colour
+      , line_spacing_factor   :: Double
       }
   deriving (Eq,Show)
 
+
 standardContext :: FontSize -> DrawingContext
-standardContext sz = DrawingContext { stroke_props      = default_stroke_attr
-                                    , font_props        = FontAttr sz courier
-                                    , primary_colour    = black
-                                    , secondary_colour  = light_gray  }
+standardContext sz = 
+    DrawingContext { stroke_props           = default_stroke_attr
+                   , font_props             = FontAttr sz courier
+                   , primary_colour         = black
+                   , secondary_colour       = light_gray
+                   , line_spacing_factor    = 1.2  
+                   }
 
 
 
-textAttr :: DrawingContext -> (RGBi,FontAttr)
-textAttr = liftA2 (,) primary_colour font_props
 
 
--- | A Mark is consider to be the height of a lowercase letter
--- in the current font.
--- 
--- Note better to use xlowerHeight
--- 
-markHeight :: FromPtSize u => DrawingContext -> u
-markHeight = fromPtSize . xcharHeight . font_size . font_props
-
-
--- | Height of a lower case \'x\' in Courier.
---  
--- \'x\' has no ascenders or descenders. 
--- 
-lowerxHeight :: FromPtSize u => DrawingContext -> u
-lowerxHeight = fromPtSize . xcharHeight . font_size . font_props
-
-
--- | textDimensions : text -> DrawingContext -> (width,height)
---
-textDimensions :: FromPtSize u => String -> DrawingContext -> (u,u)
-textDimensions str attr = (w,h)
-  where
-    sz = font_size  $ font_props attr
-    w  = fromPtSize $ textWidth  sz (charCount str)
-    h  = fromPtSize $ numeralHeight sz
-
-
-
 updateStrokeProps :: (StrokeAttr -> StrokeAttr) 
                   -> DrawingContext -> DrawingContext
 updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props
@@ -141,7 +123,11 @@
 setLineWidth       :: Double -> DrawingContext -> DrawingContext
 setLineWidth d      = updateStrokeProps (\s -> s { line_width = d })
 
-
+-- | Set the line width to a /thick/.
+--
+-- Note this context update is /oblivious/ - operationally the 
+-- line width is set to exactly @2.0@.
+--
 thick               :: DrawingContext -> DrawingContext
 thick               = setLineWidth thick_line
 
@@ -151,10 +137,37 @@
 thin                :: DrawingContext -> DrawingContext
 thin                = setLineWidth thin_line
 
+--------------------------------------------------------------------------------
 
 dashPattern         :: DashPattern -> DrawingContext -> DrawingContext
 dashPattern d       = updateStrokeProps (\s -> s { dash_pattern = d })        
 
+unit_dash_pattern   :: DashPattern
+unit_dash_pattern   = Dash 0 [(1,1)]
+
+-- oblivious
+phase               :: Int -> DashPattern -> DashPattern
+phase _ Solid       = Solid
+phase i (Dash _ xs) = Dash i xs
+
+-- non-oblivious
+dphase               :: Int -> DashPattern -> DashPattern
+dphase _ Solid       = Solid
+dphase d (Dash i xs) = Dash (i+d) xs
+
+doublegaps              :: DashPattern -> DashPattern
+doublegaps Solid        = Solid
+doublegaps (Dash i xs)  = Dash i (map fn xs)
+  where
+    fn (a,b) = (a,2*b)
+
+doubledashes              :: DashPattern -> DashPattern
+doubledashes Solid        = Solid
+doubledashes (Dash i xs)  = Dash i (map fn xs)
+  where
+    fn (a,b) = (a*2,b)
+
+
 --------------------------------------------------------------------------------
 
 
@@ -166,10 +179,38 @@
 
 --------------------------------------------------------------------------------
 
+-- | Set the font size to double the current size, note the font
+-- size also controls the size of dots, arrowsheads etc.
+-- 
+doublesize          :: DrawingContext -> DrawingContext
+doublesize          = (\s sz -> fontsize (sz*2) s) <*> (font_size . font_props)
+
+
+-- | Set the font size to half the current size, note the font
+-- size also controls the size of dots, arrowsheads etc.
+-- 
+-- As fontsize is an integer this is not exact - half size of
+-- 15pt type is 7pt.
+-- 
+halfsize            :: DrawingContext -> DrawingContext
+halfsize            = (\s sz -> fontsize (sz `div` 2) s) 
+                        <*> (font_size . font_props)
+
+
+--------------------------------------------------------------------------------
+
 swapColours :: DrawingContext -> DrawingContext
 swapColours = 
     (\s a b -> s { primary_colour = b, secondary_colour = a })
         <*> primary_colour <*> secondary_colour
+
+bothPrimary :: DrawingContext -> DrawingContext
+bothPrimary = (\s a -> s { secondary_colour = a }) <*> primary_colour
+
+bothSecondary :: DrawingContext -> DrawingContext
+bothSecondary = (\s a -> s { primary_colour = a }) <*> secondary_colour
+
+
 
 primaryColour :: RGBi -> DrawingContext -> DrawingContext
 primaryColour rgb = \s -> s { primary_colour = rgb } 
diff --git a/src/Wumpus/Basic/Graphic/PrimGraphic.hs b/src/Wumpus/Basic/Graphic/PrimGraphic.hs
--- a/src/Wumpus/Basic/Graphic/PrimGraphic.hs
+++ b/src/Wumpus/Basic/Graphic/PrimGraphic.hs
@@ -28,7 +28,10 @@
   , closedStroke
   , filledPath
   , borderedPath
+  
   , textline
+  , centermonoTextline
+  , textlineMulti
   , hkernline
   , vkernline
 
@@ -39,9 +42,13 @@
 
   , supplyPt
   , localPoint
+  , vecdisplace
   , displace
+  , hdisplace
+  , vdisplace
 
   , straightLine
+  , straightLineBetween
 
   , strokedRectangle
   , filledRectangle
@@ -59,15 +66,21 @@
 
   ) where
 
-import Wumpus.Basic.Graphic.DrawingContext
 import Wumpus.Basic.Graphic.BaseTypes
+import Wumpus.Basic.Graphic.DrawingContext
+import Wumpus.Basic.Graphic.Query
 
 import Wumpus.Core                              -- package: wumpus-core
 
 import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
 
 import Control.Applicative
+import Control.Monad
+import Data.Foldable ( foldrM )
+import Data.Monoid
 
+
 drawGraphic :: (Real u, Floating u, FromPtSize u) 
             => DrawingContext -> Graphic u -> Maybe (Picture u)
 drawGraphic ctx gf = post $ runGraphic ctx gf
@@ -89,44 +102,65 @@
 -- having the same names is actually not so useful...
 
 openStroke :: Num u => PrimPath u -> Graphic u
-openStroke pp = (\rgb attr -> singleH $ ostroke rgb attr pp) 
-                    <$> asksDF primary_colour <*> asksDF stroke_props
-
+openStroke pp = 
+    withStrokeAttr $ \rgb attr -> singleH $ ostroke rgb attr pp
 
 closedStroke :: Num u => PrimPath u -> Graphic u
-closedStroke pp = (\rgb attr -> singleH $ cstroke rgb attr pp) 
-                      <$> asksDF primary_colour <*> asksDF stroke_props
-
+closedStroke pp = 
+    withStrokeAttr $ \rgb attr -> singleH $ cstroke rgb attr pp
 
 filledPath :: Num u => PrimPath u -> Graphic u
-filledPath pp = (\rgb -> singleH $ fill rgb pp) 
-                    <$> asksDF secondary_colour
+filledPath pp = withFillAttr $ \rgb -> singleH $ fill rgb pp
+                 
 
 
 borderedPath :: Num u => PrimPath u -> Graphic u
 borderedPath pp = 
-    (\frgb attr srgb -> singleH $ fillStroke frgb attr srgb pp) 
-        <$> asksDF secondary_colour <*> asksDF stroke_props 
-                                    <*> asksDF primary_colour
-
+    withBorderedAttr $ \frgb attr srgb -> singleH $ fillStroke frgb attr srgb pp
 
 --------------------------------------------------------------------------------
 -- 
 
+
+
 textline :: Num u => String -> LocGraphic u
 textline ss baseline_left =
-    (\(rgb,attr) -> singleH $ textlabel rgb attr ss baseline_left) 
-       <$> asksDF textAttr
+    withTextAttr $ \rgb attr -> singleH $ textlabel rgb attr ss baseline_left
 
+-- | As 'textline' but the supplied point is the /center/.
+--
+-- Centered is inexact - it is calculated with monospaced font
+-- metrics.
+-- 
+centermonoTextline :: (Fractional u, Ord u, FromPtSize u) 
+                   => String -> LocGraphic u
+centermonoTextline ss pt = monoVecToCenter ss  >>= \v ->
+                           textline ss (vecdisplace (negateV v) pt)
+
+
+
+
+
+-- | Point is the baseline left of the bottom line.
+--
+textlineMulti :: Fractional u => [String] -> LocGraphic u
+textlineMulti xs baseline_left = liftM snd $ 
+    lineSpacing >>= \dy -> foldrM (foldStep dy) (baseline_left,mempty) xs
+  where
+    foldStep dy str (pt,gfic) = (\a -> (pt .+^ vvec dy, a `mappend` gfic))
+                                    <$> textline str pt
+                                
+
+
 hkernline :: Num u => [KerningChar u] -> LocGraphic u
 hkernline ks baseline_left = 
-    (\(rgb,attr) -> singleH $ hkernlabel rgb attr ks baseline_left) 
-       <$> asksDF textAttr
+    withTextAttr $ \rgb attr -> singleH $ hkernlabel rgb attr ks baseline_left
+      
 
 vkernline :: Num u => [KerningChar u] -> LocGraphic u
 vkernline ks baseline_left = 
-    (\(rgb,attr) -> singleH $ vkernlabel rgb attr ks baseline_left) 
-       <$> asksDF textAttr
+    withTextAttr $ \rgb attr -> singleH $ vkernlabel rgb attr ks baseline_left
+  
 
 
 --------------------------------------------------------------------------------
@@ -134,20 +168,18 @@
 
 strokedEllipse :: Num u => u -> u -> LocGraphic u
 strokedEllipse hw hh pt =  
-    (\rgb attr -> singleH $ strokeEllipse rgb attr hw hh pt) 
-       <$> asksDF primary_colour <*> asksDF stroke_props
+    withStrokeAttr $ \rgb attr -> singleH $ strokeEllipse rgb attr hw hh pt
+   
 
 filledEllipse :: Num u => u -> u -> LocGraphic u
 filledEllipse hw hh pt =  
-    (\rgb -> singleH $ fillEllipse rgb hw hh pt) 
-       <$> asksDF secondary_colour
+    withFillAttr $ \rgb -> singleH $ fillEllipse rgb hw hh pt
+  
 
 borderedEllipse :: Num u => u -> u -> LocGraphic u
 borderedEllipse hw hh pt = 
-    (\frgb attr srgb -> singleH $ fillStrokeEllipse frgb attr srgb hw hh pt) 
-        <$> asksDF secondary_colour <*> asksDF stroke_props 
-        <*> asksDF primary_colour
-
+    withBorderedAttr $ \frgb attr srgb -> 
+      singleH $ fillStrokeEllipse frgb attr srgb hw hh pt
 
 --------------------------------------------------------------------------------
 
@@ -158,12 +190,20 @@
 supplyPt :: Point2 u -> LocGraphic u -> Graphic u
 supplyPt pt gf = gf pt 
 
+vecdisplace :: Num u => Vec2 u -> Point2 u -> Point2 u
+vecdisplace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)
 
+
 displace :: Num u => u -> u -> Point2 u -> Point2 u
 displace dx dy (P2 x y) = P2 (x+dx) (y+dy)
 
+hdisplace :: Num u => u -> Point2 u -> Point2 u
+hdisplace dx (P2 x y) = P2 (x+dx) y
 
+vdisplace :: Num u => u -> Point2 u -> Point2 u
+vdisplace dy (P2 x y) = P2 x (y+dy)
 
+
 localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u
 localPoint upd gf = \pt -> gf (upd pt)
 
@@ -173,7 +213,12 @@
 
 straightLine :: Fractional u => Vec2 u -> LocGraphic u
 straightLine v = \pt -> openStroke $ path pt [lineTo $ pt .+^ v]
-           
+          
+
+straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u
+straightLineBetween p1 p2 = openStroke $ path p1 [lineTo p2]
+
+
 
 -- | Supplied point is /bottom-left/.
 --
diff --git a/src/Wumpus/Basic/Graphic/Query.hs b/src/Wumpus/Basic/Graphic/Query.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Graphic/Query.hs
@@ -0,0 +1,192 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Graphic.Query
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC with TypeFamilies and more
+--
+-- Querying the Drawing Context.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Graphic.Query
+  ( 
+
+    
+    textAttr
+  , withTextAttr
+
+  , strokeAttr
+  , withStrokeAttr
+
+  , fillAttr
+  , withFillAttr
+
+  , borderedAttr
+  , withBorderedAttr
+
+  , lineWidth
+  , fontSize
+  , markHeight
+  , lineSpacing
+
+  -- 
+  , monoCharWidth
+  , monoSpacerWidth
+  , monoTextWidth
+  , monoTextLength
+  , monoTextHeight
+  , monoNumeralHeight
+  , monoLowerxHeight
+  , monoDescenderDepth
+  , monoTextDimensions
+  , monoVecToCenter  
+  ) where
+
+import Wumpus.Basic.Graphic.BaseTypes
+import Wumpus.Basic.Graphic.DrawingContext
+
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import Control.Applicative
+
+
+textAttr :: DrawingF (RGBi,FontAttr)
+textAttr = (,) <$> asksDF primary_colour <*> asksDF font_props
+
+-- | Because @textAttr@ is so commonly used here is a functional
+-- version that avoids tupling.
+--
+withTextAttr :: (RGBi -> FontAttr -> a) -> DrawingF a
+withTextAttr fn = fn <$> asksDF primary_colour <*> asksDF font_props
+
+
+strokeAttr :: DrawingF (RGBi, StrokeAttr)
+strokeAttr = (,) <$> asksDF primary_colour <*> asksDF stroke_props
+
+withStrokeAttr :: (RGBi -> StrokeAttr -> a) -> DrawingF a
+withStrokeAttr fn = fn <$> asksDF primary_colour <*> asksDF stroke_props
+
+
+fillAttr :: DrawingF RGBi
+fillAttr = asksDF secondary_colour
+
+withFillAttr :: (RGBi -> a) -> DrawingF a
+withFillAttr fn = fn <$> asksDF secondary_colour
+
+borderedAttr :: DrawingF (RGBi, StrokeAttr, RGBi)
+borderedAttr = (,,) <$> asksDF secondary_colour <*> asksDF stroke_props 
+                                                <*> asksDF primary_colour
+
+withBorderedAttr :: (RGBi -> StrokeAttr -> RGBi -> a) -> DrawingF a
+withBorderedAttr fn = 
+    fn <$> asksDF secondary_colour <*> asksDF stroke_props 
+                                   <*> asksDF primary_colour
+
+
+
+
+lineWidth :: DrawingF Double
+lineWidth = line_width <$> asksDF stroke_props
+
+fontSize :: DrawingF Int
+fontSize = font_size <$> asksDF font_props
+
+
+
+
+-- Maybe these functions are better as queries - i.e. functions
+-- of type DrawingF, e.g.
+-- 
+-- > lineSpacing :: Fractional u => DrawingF u
+-- 
+-- Then the /client/ can just bound the answer directly
+-- rather than using 
+--
+-- > askDF lineSpacing >>= \u -> ...
+--
+
+lineSpacing :: Fractional u => DrawingF u
+lineSpacing = 
+    (\sz factor -> realToFrac $ factor * fromIntegral sz)
+      <$> asksDF (font_size . font_props) <*> asksDF line_spacing_factor
+
+-- | A Mark is consider to be the height of a lowercase letter
+-- in the current font.
+-- 
+-- Note better to use xlowerHeight
+-- 
+markHeight :: FromPtSize u => DrawingF u
+markHeight = (fromPtSize . xcharHeight . font_size) <$> asksDF font_props
+
+-- Note - there are probably enough functions that use just 
+-- markHeight to merit a withMarkHeight function.
+
+
+
+
+
+
+--------------------------------------------------------------------------------
+
+withFontSize :: (FontSize -> u) -> DrawingF u
+withFontSize fn = fn . font_size <$> asksDF font_props
+
+monoCharWidth :: FromPtSize u => DrawingF u
+monoCharWidth = withFontSize (fromPtSize . charWidth)
+
+monoSpacerWidth :: FromPtSize u => DrawingF u
+monoSpacerWidth = withFontSize (fromPtSize . spacerWidth)
+
+
+monoTextWidth :: FromPtSize u => Int -> DrawingF u
+monoTextWidth n = withFontSize $ \sz -> fromPtSize $ textWidth sz n
+
+
+monoTextLength :: FromPtSize u => String -> DrawingF u
+monoTextLength ss = monoTextWidth $ charCount ss
+
+
+monoTextHeight :: FromPtSize u => DrawingF u
+monoTextHeight = withFontSize (fromPtSize . textHeight)
+
+monoNumeralHeight :: FromPtSize u => DrawingF u
+monoNumeralHeight = withFontSize (fromPtSize . numeralHeight)
+
+
+-- | Height of a lower case \'x\' in Courier.
+--  
+-- \'x\' has no ascenders or descenders. 
+-- 
+monoLowerxHeight :: FromPtSize u => DrawingF u
+monoLowerxHeight = withFontSize (fromPtSize . xcharHeight)
+
+monoDescenderDepth :: FromPtSize u => DrawingF u
+monoDescenderDepth = withFontSize (fromPtSize . descenderDepth)
+
+
+-- | Query the dimensions of the text using the current font size
+-- but using metrics derived from Courier.
+--
+-- Note - the width will generally be a over-estimate for 
+-- non-monospaced fonts.
+-- 
+monoTextDimensions :: (Num u, Ord u, FromPtSize u) => String -> DrawingF (u,u)
+monoTextDimensions ss = 
+    (\sz -> post $ textBounds sz zeroPt ss) 
+      <$> asksDF (font_size . font_props)
+  where
+    post bb = (boundaryWidth bb, boundaryHeight bb)
+
+
+-- | Vector from baseline left to center
+monoVecToCenter :: (Fractional u, Ord u, FromPtSize u) 
+                => String -> DrawingF (Vec2 u)
+monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) 
+                       <$> monoTextDimensions ss <*> monoDescenderDepth
diff --git a/src/Wumpus/Basic/Graphic/ScalingContext.hs b/src/Wumpus/Basic/Graphic/ScalingContext.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Graphic/ScalingContext.hs
@@ -0,0 +1,173 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Graphic.ScalingContext
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC
+--
+-- Scaling in X and Y
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Graphic.ScalingContext
+  (
+    ScalingContext(..)
+
+  , Scaling
+  , runScaling
+  , ScalingT
+  , runScalingT
+
+  , regularScalingContext
+  , coordinateScalingContext
+
+  , unitX
+  , unitY
+
+
+  ) where
+
+import Wumpus.Basic.Graphic.BaseClasses
+
+import Wumpus.Core				-- package: wumpus-core
+
+import Control.Applicative
+
+data ScalingContext ux uy u = ScalingContext
+      { scale_in_x  :: ux -> u
+      , scale_in_y  :: uy -> u
+      }
+
+
+
+-- Chains (for example) want a plain monad rather than a transformer.
+--
+newtype Scaling ux uy u a = Scaling {
+          getScaling :: ScalingContext ux uy u -> a }
+
+
+type instance MonUnit (Scaling ux uy u) = u
+
+
+
+instance Functor (Scaling ux uy u) where
+  fmap f ma = Scaling $ \ctx -> let a = getScaling ma ctx in f a
+
+instance Applicative (Scaling ux uy u) where
+  pure a    = Scaling $ \_   -> a
+  mf <*> ma = Scaling $ \ctx -> let f = getScaling mf ctx
+                                    a = getScaling ma ctx
+             			in (f a)
+
+instance Monad (Scaling ux uy u) where
+  return a = Scaling $ \_   -> a
+  m >>= k  = Scaling $ \ctx -> let a = getScaling m ctx
+    	     	               in (getScaling . k) a ctx
+
+
+
+instance ScalingM (Scaling ux uy u) where
+  type XDim (Scaling ux uy u) = ux 
+  type YDim (Scaling ux uy u) = uy
+  scaleX ux       = Scaling $ \ctx -> (scale_in_x ctx) ux
+  scaleY uy       = Scaling $ \ctx -> (scale_in_y ctx) uy
+  scalePt ux uy   = Scaling $ \ctx -> P2 (scale_in_x ctx ux) (scale_in_y ctx uy)
+  scaleVec ux uy  = Scaling $ \ctx -> V2 (scale_in_x ctx ux) (scale_in_y ctx uy)
+
+runScaling :: ScalingContext ux uy u -> Scaling ux uy u a -> a
+runScaling ctx sf = (getScaling sf) ctx    
+
+
+
+
+--------------------------------------------------------------------------------
+-- Transformer
+
+-- Turtle (for example) wants a transformer so it can use TraceM
+-- and DrawingCtxM
+--
+newtype ScalingT ux uy u m a = ScalingT { 
+          getScalingT :: ScalingContext ux uy u -> m a }
+
+type instance MonUnit (ScalingT ux uy u m) = u
+
+
+instance Monad m => Functor (ScalingT ux uy u m) where
+  fmap f ma = ScalingT $ \ctx -> getScalingT ma ctx >>= \a -> return (f a)
+
+instance Monad m => Applicative (ScalingT ux uy u m) where
+  pure a    = ScalingT $ \_   -> return a
+  mf <*> ma = ScalingT $ \ctx -> getScalingT mf ctx >>= \f -> 
+                                 getScalingT ma ctx >>= \a ->
+             			 return (f a)
+
+instance Monad m => Monad (ScalingT ux uy u m) where
+  return a = ScalingT $ \_   -> return a
+  m >>= k  = ScalingT $ \ctx -> getScalingT m ctx >>= \a -> 
+    	     	      	     	(getScalingT . k) a ctx
+
+
+instance Monad m => ScalingM (ScalingT ux uy u m) where
+  type XDim (ScalingT ux uy u m) = ux 
+  type YDim (ScalingT ux uy u m) = uy
+  scaleX ux       = ScalingT $ \ctx -> return $ (scale_in_x ctx) ux
+  scaleY uy       = ScalingT $ \ctx -> return $ (scale_in_y ctx) uy
+  scalePt ux uy   = ScalingT $ \ctx -> 
+                      return $ P2 (scale_in_x ctx ux) (scale_in_y ctx uy)
+  scaleVec ux uy  = ScalingT $ \ctx -> 
+                      return $ V2 (scale_in_x ctx ux) (scale_in_y ctx uy)
+
+
+
+-- Cross instances - needed to run SalingT /locally/ in Drawing.
+
+instance DrawingCtxM m => DrawingCtxM (ScalingT ux uy u m) where
+  askCtx   = ScalingT $ \_ -> askCtx >>= \dctx -> return dctx
+  localCtx ctx mf = ScalingT $ \sctx -> localCtx ctx (getScalingT mf sctx)
+
+
+instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ScalingT ux uy u m) where
+  trace a  = ScalingT $ \_ -> trace a 
+
+
+
+
+runScalingT :: ScalingContext ux uy u -> ScalingT ux uy u m a -> m a
+runScalingT ctx sf = (getScalingT sf) ctx    
+
+--------------------------------------------------------------------------------
+-- constructors for scaling context
+
+regularScalingContext :: Num u => u -> ScalingContext u u u
+regularScalingContext u = ScalingContext
+      { scale_in_x  = (\x -> u*x)
+      , scale_in_y  = (\y -> u*y)
+      }
+
+coordinateScalingContext :: Num u => u -> u -> ScalingContext Int Int u
+coordinateScalingContext sx sy = ScalingContext
+      { scale_in_x  = (\x -> sx * fromIntegral x)
+      , scale_in_y  = (\y -> sy * fromIntegral y)
+      }
+
+
+
+--------------------------------------------------------------------------------
+-- operations
+
+
+
+
+unitX :: (ScalingM m, Num ux, ux ~ XDim m, u ~ MonUnit m) => m u
+unitX = scaleX 1
+ 
+unitY :: (ScalingM m, Num uy, uy ~ YDim m, u ~ MonUnit m) => m u
+unitY = scaleY 1
+
+ 
diff --git a/src/Wumpus/Basic/Monads/TurtleClass.hs b/src/Wumpus/Basic/Monads/TurtleClass.hs
--- a/src/Wumpus/Basic/Monads/TurtleClass.hs
+++ b/src/Wumpus/Basic/Monads/TurtleClass.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE FunctionalDependencies     #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -18,22 +16,22 @@
 -- drawing - sending commands to update the a cursor.
 --
 -- While Wumpus generally aims for a more compositional,
--- \"coordinate-free\" style of drawing, some types of 
--- diagram are more easily expressed in the LOGO style.
+-- \"coordinate-free\" style of drawing, some types of diagram 
+-- are more easily expressed in the LOGO style.
 --
+-- Note - as turtle drawing with Wumpus is a /local effect/, 
+-- there is only one instance of TurtleM. Potentially TurtleM 
+-- will be removed and the functions implemented directly. 
+--
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Monads.TurtleClass
   (
 
     Coord
-  , TurtleConfig(..)
-  , regularConfig 
 
   , TurtleM(..)
-  , TurtleScaleM(..)
 
-  , askSteps
   , setsLoc
   , setsLoc_
 
@@ -45,48 +43,22 @@
   , moveDown
   , nextLine
  
-  , getPos
-  , scaleCoord
 
   ) where
 
 
-import Wumpus.Core                      -- package: wumpus-core
 
-import Control.Monad
-
 type Coord = (Int,Int)
 
 
--- Might want to expand this with an initial y-value,
--- otherwise using nextLine will get you negative y-values
--- without care...
-
-data TurtleConfig u = TurtleConfig 
-      { xstep :: !u
-      , ystep :: !u 
-      }  
-  deriving (Eq,Show)
-
-
-regularConfig :: u -> TurtleConfig u
-regularConfig u = TurtleConfig u u 
-
-
 class Monad m => TurtleM m where
   getLoc     :: m (Int,Int)
   setLoc     :: (Int,Int) -> m ()
   getOrigin  :: m (Int,Int)
   setOrigin  :: (Int,Int) -> m ()
 
-class TurtleM m => TurtleScaleM m u | m -> u where 
-  xStep     :: m u
-  yStep     :: m u
 
 
-askSteps :: TurtleScaleM m u => m (u,u)
-askSteps = liftM2 (,) xStep yStep
-
 setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a
 setsLoc f = getLoc      >>= \coord -> 
             let (a,coord') = f coord in setLoc coord' >> return a
@@ -95,7 +67,6 @@
 setsLoc_ f = getLoc     >>= \coord ->  setLoc (f coord)
 
 
-
 resetLoc    :: TurtleM m => m ()
 resetLoc    = getOrigin >>= setLoc
 
@@ -117,14 +88,4 @@
 nextLine    :: TurtleM m => m ()
 nextLine    = getOrigin >>= \(ox,_) ->
               setsLoc_ $ \(_,y) -> (ox,y-1)
-
-
-getPos :: (TurtleScaleM m u, Num u) => m (Point2 u)
-getPos = getLoc   >>= \(x,y)   ->
-         askSteps >>= \(sx,sy) ->
-         return $ P2 (sx * fromIntegral x) (sy * fromIntegral y)
-
-scaleCoord  :: (TurtleScaleM m u, Num u) => (Int,Int) -> m (Point2 u)
-scaleCoord (x,y) = askSteps >>= \(sx,sy) ->
-                   return $ P2 (sx * fromIntegral x) (sy * fromIntegral y)
 
diff --git a/src/Wumpus/Basic/Monads/TurtleMonad.hs b/src/Wumpus/Basic/Monads/TurtleMonad.hs
--- a/src/Wumpus/Basic/Monads/TurtleMonad.hs
+++ b/src/Wumpus/Basic/Monads/TurtleMonad.hs
@@ -38,10 +38,6 @@
   , TurtleT
   , runTurtleT
 
-  -- * Turtle combined with Drawing
-  , TurtleDrawing
-  , runTurtleDrawing
-  , execTurtleDrawing
    
   ) where
 
@@ -54,6 +50,11 @@
 import Control.Monad
 
 
+-- Note - if Turtle is now just a /local effect/ monad is the 
+-- Turtle class still needed? Afterall, there is (probably)
+-- only ever going to be one instance.
+--
+
 -- Turtle is a Reader / State monad
 -- 
 -- The env is the horizontal and vertical move distances.
@@ -66,56 +67,57 @@
       , _current_coord   :: (Int,Int)
       }
 
+type TurtleScalingT u m a = ScalingT Int Int u m a
+
 newtype TurtleT u m a = TurtleT { 
-          getTurtleT :: TurtleConfig u -> TurtleState -> m (a, TurtleState) }
+          getTurtleT :: TurtleState -> TurtleScalingT u m (a, TurtleState) }
 
 type instance MonUnit (TurtleT u m) = u
+    
 
+
 -- Functor
 
 
+
 instance Monad m => Functor (TurtleT u m) where
-  fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->
-                               return (f a, s')
+  fmap f m = TurtleT $ \s -> getTurtleT m s >>= \(a,s') ->
+                             return (f a, s')
 
+
 -- Applicative 
 
 instance Monad m => Applicative (TurtleT u m) where
-  pure a    = TurtleT $ \_ s -> return (a,s)
-  mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s  >>= \(f,s')  ->
-                                getTurtleT ma r s' >>= \(a,s'') ->
-                                return (f a,s'') 
+  pure a    = TurtleT $ \s -> return (a,s)
+  mf <*> ma = TurtleT $ \s -> getTurtleT mf s  >>= \(f,s')  ->
+                              getTurtleT ma s' >>= \(a,s'') ->
+                              return (f a,s'') 
 
 
 -- Monad 
 
 instance Monad m => Monad (TurtleT u m) where
-  return a = TurtleT $ \_ s -> return (a,s)
-  m >>= k  = TurtleT $ \r s -> getTurtleT m r s        >>= \(a,s')  ->
-                               (getTurtleT . k) a r s' >>= \(b,s'') ->
-                               return (b,s'')
+  return a = TurtleT $ \s -> return (a,s)
+  m >>= k  = TurtleT $ \s -> getTurtleT m s        >>= \(a,s')  ->
+                             (getTurtleT . k) a s' >>= \(b,s'') ->
+                             return (b,s'')
 
 
 
 
 instance Monad m => TurtleM (TurtleT u m) where
-  getLoc      = TurtleT $ \_ s@(TurtleState _ c) -> return (c,s)
-  setLoc c    = TurtleT $ \_   (TurtleState o _) -> return ((),TurtleState o c)
-  getOrigin   = TurtleT $ \_ s@(TurtleState o _) -> return (o,s)
-  setOrigin o = TurtleT $ \_   (TurtleState _ c) -> return ((),TurtleState o c)
-
-instance Monad m => TurtleScaleM (TurtleT u m) u where
-  xStep    = TurtleT $ \r s -> return (xstep r,s)
-  yStep    = TurtleT $ \r s -> return (ystep r,s)
+  getLoc      = TurtleT $ \s@(TurtleState _ c) -> return (c,s)
+  setLoc c    = TurtleT $ \(TurtleState o _)   -> return ((),TurtleState o c)
+  getOrigin   = TurtleT $ \s@(TurtleState o _) -> return (o,s)
+  setOrigin o = TurtleT $ \(TurtleState _ c)   -> return ((),TurtleState o c)
 
 
--- Run functions discard the state...
-
 runTurtleT :: (Monad m, Num u) 
-           => TurtleConfig u -> (Int,Int) -> TurtleT u m a -> m a
-runTurtleT cfg ogin mf = liftM fst $ getTurtleT mf cfg (TurtleState ogin ogin)
-
-
+           => (Int,Int) -> ScalingContext Int Int u -> TurtleT u m a -> m a
+runTurtleT ogin cfg mf = 
+    runScalingT cfg (getTurtleT mf st0) >>= \(a,_) -> return a
+  where 
+    st0 = TurtleState ogin ogin 
 
 
 
@@ -123,89 +125,16 @@
 -- Cross instances
 
 instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where
-  askCtx   = TurtleT $ \_ s -> askCtx >>= \ ctx -> return (ctx,s)
-  localCtx ctx mf = TurtleT $ \r s -> localCtx ctx (getTurtleT mf r s)
+  askCtx   = TurtleT $ \s -> askCtx >>= \ ctx -> return (ctx,s)
+  localCtx ctx mf = TurtleT $ \s -> localCtx ctx (getTurtleT mf s)
 
 
 -- This needs undecidable instances...
 
 instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where
-  trace a  = TurtleT $ \_ s -> trace a >> return ((),s)
+  trace a  = TurtleT $ \s -> trace a >> return ((),s)
 
 
 instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where
-  position = getPos
-
---------------------------------------------------------------------------------
-
-
-newtype TurtleDrawing u a = TurtleDrawing { 
-          getTurtleDrawing :: TurtleT u (Drawing u) a }
-
-
-type instance MonUnit (TurtleDrawing u) = u
-
-
-instance Functor (TurtleDrawing u) where
-  fmap f = TurtleDrawing . fmap f . getTurtleDrawing
-
--- Applicative 
-instance Applicative (TurtleDrawing u) where
-  pure a    = TurtleDrawing $ pure a
-  mf <*> ma = TurtleDrawing $ getTurtleDrawing mf <*> getTurtleDrawing ma
-
-
--- Monad 
-
-instance Monad (TurtleDrawing u) where
-  return a = TurtleDrawing $ return a
-  m >>= k  = TurtleDrawing $ getTurtleDrawing m >>= (getTurtleDrawing . k)
-
--- TurtleM
-
-instance TurtleM (TurtleDrawing u) where
-  getLoc      = TurtleDrawing $ getLoc 
-  setLoc c    = TurtleDrawing $ setLoc c
-  getOrigin   = TurtleDrawing $ getOrigin
-  setOrigin o = TurtleDrawing $ setOrigin o
-
-instance TurtleScaleM (TurtleDrawing u) u where
-  xStep    = TurtleDrawing $ xStep
-  yStep    = TurtleDrawing $ yStep
-
-
-
--- TraceM 
-
-instance TraceM (TurtleDrawing u) where
-  trace a = TurtleDrawing $ trace a
-
--- DrawingCtxM
-
-instance DrawingCtxM (TurtleDrawing u) where
-  askCtx          = TurtleDrawing $ askCtx
-  localCtx ctx ma = TurtleDrawing $ localCtx ctx (getTurtleDrawing ma)
-
--- PointSupplyM
-
-instance Num u => PointSupplyM (TurtleDrawing u) where
-  position = getPos
-
-
-runTurtleDrawing :: Num u 
-                 => TurtleConfig u 
-                 -> (Int,Int)
-                 -> DrawingContext
-                 -> TurtleDrawing u a 
-                 -> (a, HPrim u)
-runTurtleDrawing cfg ogin ctx mf = 
-    runDrawing ctx ( runTurtleT cfg ogin $ getTurtleDrawing mf)
-
+  position = TurtleT $ \s@(TurtleState _ (x,y)) -> scalePt x y >>= \pt -> return (pt,s)
 
-execTurtleDrawing :: Num u 
-                  => TurtleConfig u
-                  -> (Int,Int) 
-                  -> DrawingContext
-                  -> TurtleDrawing u a 
-                  -> HPrim u
-execTurtleDrawing cfg ogin ctx mf = snd $ runTurtleDrawing cfg ogin ctx mf
diff --git a/src/Wumpus/Basic/Paths.hs b/src/Wumpus/Basic/Paths.hs
--- a/src/Wumpus/Basic/Paths.hs
+++ b/src/Wumpus/Basic/Paths.hs
@@ -10,155 +10,20 @@
 -- Stability   :  highly unstable
 -- Portability :  GHC
 --
--- Extended path type - more amenable for complex drawings than
--- the type in Wumpus-Core.
---
--- \*\* WARNING \*\* this module is an experiment, and may 
--- change significantly or even be dropped from future revisions.
+-- Shim import module for Paths.
 -- 
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Paths 
   ( 
 
-    connectS
-  , pathGraphic
-
-  , shorten
-  , shortenL
-  , shortenR
-  , midpoint
-  , directionL
-  , directionR
+    module Wumpus.Basic.Paths.Base
+  , module Wumpus.Basic.Paths.Connectors
+  , module Wumpus.Basic.Paths.Construction
 
   ) where
 
-import Wumpus.Basic.Graphic
 import Wumpus.Basic.Paths.Base
+import Wumpus.Basic.Paths.Connectors
 import Wumpus.Basic.Paths.Construction
 
-import Wumpus.Core                              -- package: wumpus-core
-
-import Data.AffineSpace                         -- package: vector-space
-
-import Data.Sequence
-
-
-
-connectS :: Floating u => PathF u
-connectS = \p0 p1 -> execPath p0 $ lineto p1
-
-
-
--- This one might be more useful...
-
-pathGraphic :: Num u => PathF u -> ConnGraphic u
-pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2
-
-
-
-
-shorten  :: (Real u, Floating u, Ord u) => u -> Path u -> Path u
-shorten u p = shortenL u $ shortenR u p
-
---------------------------------------------------------------------------------
--- shorten from the left...
-
-shortenL :: (Real u, Floating u, Ord u) => u -> Path u -> Path u
-shortenL n (Path u bp) | n >= u         = emptyPath
-                       | otherwise      = step n (viewl bp)
-  where
-    step _ EmptyL     = emptyPath
-    step d (e :< se)  = let z = segmentLength e in
-                        case compare d z of
-                          GT -> step (d-z) (viewl se)
-                          EQ -> Path (u-n) se
-                          _  -> Path (u-n) (shortenSegL d e <| se)
-
-
-shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
-shortenSegL n (LineSeg  u l) = LineSeg  (u-n) (shortenLineL n l) 
-shortenSegL n (CurveSeg u c) = CurveSeg (u-n) (snd $ subdividet (n/u) c)
-
-shortenLineL :: (Real u, Floating u) => u -> Line u -> Line u
-shortenLineL n (Line p1 p2) = Line (p1 .+^ v) p2
-  where
-    v0 = p2 .-. p1
-    v  = avec (direction v0) n
-    
---------------------------------------------------------------------------------
--- shorten from the right ...
- 
-shortenR :: (Real u, Floating u, Ord u) => u -> Path u -> Path u
-shortenR n (Path u bp) | n >= u         = emptyPath
-                       | otherwise      = step n (viewr bp)
-  where
-    step _ EmptyR     = emptyPath
-    step d (se :> e)  = let z = segmentLength e in
-                        case compare d z of
-                          GT -> step (d-z) (viewr se)
-                          EQ -> Path (u-n) se
-                          _  -> Path (u-n) (se |> shortenSegR d e)
-
-
-
-shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
-shortenSegR n (LineSeg  u l) = LineSeg  (u-n) (shortenLineR n l) 
-shortenSegR n (CurveSeg u c) = CurveSeg (u-n) (fst $ subdividet ((u-n)/u) c)
-
-
-shortenLineR :: (Real u, Floating u) => u -> Line u -> Line u
-shortenLineR n (Line p1 p2) = Line p1 (p2 .+^ v)
-  where
-    v0 = p1 .-. p2
-    v  = avec (direction v0) n
-
-
-
---------------------------------------------------------------------------------
-
-midpoint :: (Real u, Floating u) => Path u -> Point2 u
-midpoint (Path u bp) = step (u/2) (viewl bp)
-  where
-    step _ EmptyL    = zeroPt
-    step d (e :< se) = let z = segmentLength e in
-                       case compare d z of
-                         GT -> step (d-z) (viewl se)
-                         EQ -> segmentEnd e
-                         _  -> segmentEnd $ shortenSegL d e 
-
-
-
-
-
---------------------------------------------------------------------------------
--- tangents
-
-
-directionL :: (Real u, Floating u) => Path u -> Radian
-directionL (Path _ se) = step $ viewl se
-  where
-    step (LineSeg  _ l :< _) = lineDirectionL l 
-    step (CurveSeg _ c :< _) = curveDirectionL c
-    step _                   = 0
-
-directionR :: (Real u, Floating u) => Path u -> Radian
-directionR (Path _ se) = step $ viewr se
-  where
-    step (_ :> LineSeg  _ l) = lineDirectionR l 
-    step (_ :> CurveSeg _ c) = curveDirectionR c
-    step _                   = 0
-
-
-lineDirectionL :: (Real u, Floating u) => Line u -> Radian
-lineDirectionL (Line p0 p1) = direction (pvec p1 p0)
-
-lineDirectionR :: (Real u, Floating u) => Line u -> Radian
-lineDirectionR (Line p0 p1) = direction (pvec p0 p1)
-
-curveDirectionL :: (Real u, Floating u) => Curve u -> Radian
-curveDirectionL (Curve p0 p1 _ _) = direction $ pvec p1 p0
-
-curveDirectionR :: (Real u, Floating u) => Curve u -> Radian
-curveDirectionR (Curve _ _ p2 p3) = direction $ pvec p2 p3
- 
diff --git a/src/Wumpus/Basic/Paths/Base.hs b/src/Wumpus/Basic/Paths/Base.hs
--- a/src/Wumpus/Basic/Paths/Base.hs
+++ b/src/Wumpus/Basic/Paths/Base.hs
@@ -22,9 +22,7 @@
 module Wumpus.Basic.Paths.Base
   ( 
 
-    PathF
-
-  , Path(..)
+    Path(..)
   , PathSeg(..)
   , Curve(..)
   , Line(..)
@@ -56,7 +54,7 @@
 -- Note - path doesn\'t need a drawing context for 
 -- construction...
 --
-type PathF u = Point2 u -> Point2 u -> Path u
+-- type PathF u = Point2 u -> Point2 u -> Path u
 
 
 data Path u = Path 
diff --git a/src/Wumpus/Basic/Paths/Connectors.hs b/src/Wumpus/Basic/Paths/Connectors.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Paths/Connectors.hs
@@ -0,0 +1,211 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Paths.Connectors
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Extended path type - more amenable for complex drawings than
+-- the type in Wumpus-Core.
+--
+-- \*\* WARNING \*\* this module is an experiment, and may 
+-- change significantly or even be dropped from future revisions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Paths.Connectors 
+  ( 
+
+    ConnPath
+  , connectS
+  , vhconn
+  , hvconn
+  , arbv
+  , arbh
+  , curveconn
+  , joint
+  , pathGraphic
+  , fillPath
+
+  , shorten
+  , shortenL
+  , shortenR
+  , midpoint
+  , directionL
+  , directionR
+
+  ) where
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Paths.Base
+import Wumpus.Basic.Paths.Construction
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Data.Sequence
+
+type ConnPath u = Point2 u -> Point2 u -> Path u
+
+connectS :: Floating u => ConnPath u
+connectS = \p1 p2 -> execPath p1 $ lineto p2
+
+vhconn :: Floating u => ConnPath u
+vhconn p1 p2 = execPath p1 $ verticalHorizontal p2
+
+hvconn :: Floating u => ConnPath u
+hvconn p1 p2 = execPath p1 $ horizontalVertical p2
+
+arbv :: Floating u => u -> ConnPath u
+arbv v p1@(P2 x1 y1) (P2 x2 y2) = execPath p1 $ vline v >> hline dx >> vline dy
+  where
+    dx = x2 - x1
+    dy = y2 - (y1+v)
+
+
+arbh :: Floating u => u -> ConnPath u
+arbh h p1@(P2 x1 y1) (P2 x2 y2) = execPath p1 $ hline h >> vline dy >> hline dx
+  where
+    dx = x2 - (x1+h)
+    dy = y2 - y1
+
+curveconn :: (Floating u, Ord u) => Radian -> Radian -> ConnPath u
+curveconn r1 r2 p1 p2 = execPath p1 $ curveto r1 r2 p2
+
+
+joint :: (Real u, Floating u) => u -> ConnPath u 
+joint u p1@(P2 x1 y1) p2@(P2 x2 y2) = 
+    execPath p1 $ lineto (mid_pt .+^ avec perp_ang u) >> lineto p2
+  where
+    mid_pt    = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1))
+    perp_ang  = (pi*0.5) + direction (pvec p2 p1) 
+
+-- This one might be more useful...
+-- 
+-- ... No - can\'t a add tips to this one.
+--
+pathGraphic :: Num u => ConnPath u -> ConnGraphic u
+pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2
+
+
+-- Mind out for name clash...
+
+-- | Closes and fills a path
+--
+fillPath :: Num u => Path u -> Graphic u
+fillPath = filledPath . toPrimPathU
+
+
+
+shorten  :: (Real u, Floating u, Ord u) => u -> Path u -> Path u
+shorten u p = shortenL u $ shortenR u p
+
+--------------------------------------------------------------------------------
+-- shorten from the left...
+
+shortenL :: (Real u, Floating u, Ord u) => u -> Path u -> Path u
+shortenL n (Path u bp) | n >= u         = emptyPath
+                       | otherwise      = step n (viewl bp)
+  where
+    step _ EmptyL     = emptyPath
+    step d (e :< se)  = let z = segmentLength e in
+                        case compare d z of
+                          GT -> step (d-z) (viewl se)
+                          EQ -> Path (u-n) se
+                          _  -> Path (u-n) (shortenSegL d e <| se)
+
+
+shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
+shortenSegL n (LineSeg  u l) = LineSeg  (u-n) (shortenLineL n l) 
+shortenSegL n (CurveSeg u c) = CurveSeg (u-n) (snd $ subdividet (n/u) c)
+
+shortenLineL :: (Real u, Floating u) => u -> Line u -> Line u
+shortenLineL n (Line p1 p2) = Line (p1 .+^ v) p2
+  where
+    v0 = p2 .-. p1
+    v  = avec (direction v0) n
+    
+--------------------------------------------------------------------------------
+-- shorten from the right ...
+ 
+shortenR :: (Real u, Floating u, Ord u) => u -> Path u -> Path u
+shortenR n (Path u bp) | n >= u         = emptyPath
+                       | otherwise      = step n (viewr bp)
+  where
+    step _ EmptyR     = emptyPath
+    step d (se :> e)  = let z = segmentLength e in
+                        case compare d z of
+                          GT -> step (d-z) (viewr se)
+                          EQ -> Path (u-n) se
+                          _  -> Path (u-n) (se |> shortenSegR d e)
+
+
+
+shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u
+shortenSegR n (LineSeg  u l) = LineSeg  (u-n) (shortenLineR n l) 
+shortenSegR n (CurveSeg u c) = CurveSeg (u-n) (fst $ subdividet ((u-n)/u) c)
+
+
+shortenLineR :: (Real u, Floating u) => u -> Line u -> Line u
+shortenLineR n (Line p1 p2) = Line p1 (p2 .+^ v)
+  where
+    v0 = p1 .-. p2
+    v  = avec (direction v0) n
+
+
+
+--------------------------------------------------------------------------------
+
+-- This should return direction as well...
+--
+midpoint :: (Real u, Floating u) => Path u -> Point2 u
+midpoint (Path u bp) = step (u/2) (viewl bp)
+  where
+    step _ EmptyL    = zeroPt
+    step d (e :< se) = let z = segmentLength e in
+                       case compare d z of
+                         GT -> step (d-z) (viewl se)
+                         EQ -> segmentEnd e
+                         _  -> segmentEnd $ shortenSegR d e 
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- tangents
+
+
+directionL :: (Real u, Floating u) => Path u -> Radian
+directionL (Path _ se) = step $ viewl se
+  where
+    step (LineSeg  _ l :< _) = lineDirectionL l 
+    step (CurveSeg _ c :< _) = curveDirectionL c
+    step _                   = 0
+
+directionR :: (Real u, Floating u) => Path u -> Radian
+directionR (Path _ se) = step $ viewr se
+  where
+    step (_ :> LineSeg  _ l) = lineDirectionR l 
+    step (_ :> CurveSeg _ c) = curveDirectionR c
+    step _                   = 0
+
+
+lineDirectionL :: (Real u, Floating u) => Line u -> Radian
+lineDirectionL (Line p0 p1) = direction (pvec p1 p0)
+
+lineDirectionR :: (Real u, Floating u) => Line u -> Radian
+lineDirectionR (Line p0 p1) = direction (pvec p0 p1)
+
+curveDirectionL :: (Real u, Floating u) => Curve u -> Radian
+curveDirectionL (Curve p0 p1 _ _) = direction $ pvec p1 p0
+
+curveDirectionR :: (Real u, Floating u) => Curve u -> Radian
+curveDirectionR (Curve _ _ p2 p3) = direction $ pvec p2 p3
+ 
diff --git a/src/Wumpus/Basic/Paths/Construction.hs b/src/Wumpus/Basic/Paths/Construction.hs
--- a/src/Wumpus/Basic/Paths/Construction.hs
+++ b/src/Wumpus/Basic/Paths/Construction.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
@@ -21,11 +22,13 @@
 module Wumpus.Basic.Paths.Construction
   ( 
 
-    MPath
-  , CPath
+    PathM
   , runPath
   , execPath
   , lineto
+  , rlineto
+  , vline
+  , hline
   , bezierto
   , curveto
   , verticalHorizontal
@@ -46,61 +49,84 @@
       , path_accum    :: Path u
       }
 
-newtype MPath u a = MPath { getMPath :: PathState u -> (a,PathState u) }
+newtype PathM u a = PathM { getPathM :: PathState u -> (a,PathState u) }
 
-type CPath u = MPath u ()
 
-instance Functor (MPath u) where
-  fmap f mf = MPath $ \s -> let (a,s') = getMPath mf s in (f a,s')
+instance Functor (PathM u) where
+  fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1)
 
 
-instance Applicative (MPath u) where
-  pure a    = MPath $ \s -> (a,s)
-  mf <*> ma = MPath $ \s -> let (f,s')  = getMPath mf s
-                                (a,s'') = getMPath ma s'
-                            in (f a,s'')
+instance Applicative (PathM u) where
+  pure a    = PathM $ \s -> (a,s)
+  mf <*> ma = PathM $ \s -> let (f,s1) = getPathM mf s
+                                (a,s2) = getPathM ma s1
+                            in (f a,s2)
 
-instance Monad (MPath u) where
-  return a  = MPath $ \s -> (a,s)
-  m >>= k   = MPath $ \s -> let (a,s') = getMPath m s in
-                            (getMPath . k) a s'
+instance Monad (PathM u) where
+  return a  = PathM $ \s -> (a,s)
+  m >>= k   = PathM $ \s -> let (a,s1) = getPathM m s in
+                            (getPathM . k) a s1
 
 
-runPath :: Num u => Point2 u -> MPath u a -> (a, Path u)
-runPath start mf = let (a,s') = getMPath mf s in (a, path_accum s')
+-- Design note - it is probably best to follow LRText and have
+-- the path monad isolated from the trace monad. While it would 
+-- be nice to trace arbitrary labels as we go, state changes to the 
+-- DrawingCtx would make things complicated.
+--
+
+{-
+openStrokePathM :: (Num u, TraceM m, DrawingCtxM m, u ~ MonUnit m) 
+                => Point2 u -> PathM u a -> m a
+openStrokePathM pt ma = let (a,p) = runPath pt ma  in 
+    draw (openStroke $ toPrimPathU p) >> return a
+-}
+
+-- Running the path is agnostic to the DrawingCtx.
+
+runPath :: Num u => Point2 u -> PathM u a -> (a, Path u)
+runPath start mf = let (a,s') = getPathM mf s in (a, path_accum s')
   where
     s = PathState { current_point = start
                   , path_accum    = emptyPath
                   }
 
-execPath :: Num u => Point2 u -> MPath u a -> Path u
+execPath :: Num u => Point2 u -> PathM u a -> Path u
 execPath start mf = snd $ runPath start mf
 
 
-exchTip :: Point2 u -> (Point2 u -> Path u -> Path u) -> MPath u ()
+exchTip :: Point2 u -> (Point2 u -> Path u -> Path u) -> PathM u ()
 exchTip new updP = 
-    MPath $ \(PathState old bp) -> ((), PathState new (updP old bp)) 
+    PathM $ \(PathState old bp) -> ((), PathState new (updP old bp)) 
 
-tip :: MPath u (Point2 u)
-tip = MPath $ \s -> (current_point s,s)
+tip :: PathM u (Point2 u)
+tip = PathM $ \s -> (current_point s,s)
 
 
-lineto :: Floating u => Point2 u -> CPath u
+lineto :: Floating u => Point2 u -> PathM u ()
 lineto end = exchTip end upd
   where
     upd start bp = bp `addSegment` pline start end
 
 
+rlineto :: Floating u => Vec2 u -> PathM u ()
+rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy))
 
+hline :: Floating u => u -> PathM u ()
+hline dx = tip >>= \(P2 x y) -> lineto (P2 (x+dx) y)
+
+vline :: Floating u => u -> PathM u ()
+vline dy = tip >>= \(P2 x y) -> lineto (P2 x (y+dy))
+ 
+
 bezierto :: (Floating u, Ord u) 
-         => Point2 u -> Point2 u -> Point2 u -> CPath u
+         => Point2 u -> Point2 u -> Point2 u -> PathM u ()
 bezierto cp1 cp2 end = exchTip end upd 
   where
     upd start bp = bp `addSegment` pcurve start cp1 cp2 end
 
 
 curveto :: (Floating u, Ord u) 
-        => Radian -> Radian -> Point2 u -> CPath u
+        => Radian -> Radian -> Point2 u -> PathM u ()
 curveto cin cout end = exchTip end upd
   where 
     upd start bp = bp `addSegment` pcurveAng start cin cout end
@@ -115,10 +141,10 @@
     v2     = avec cout sz
 
 
-verticalHorizontal :: Floating u => Point2 u -> CPath u
+verticalHorizontal :: Floating u => Point2 u -> PathM u ()
 verticalHorizontal (P2 x y) = 
     tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y)
 
-horizontalVertical :: Floating u => Point2 u -> CPath u
+horizontalVertical :: Floating u => Point2 u -> PathM u ()
 horizontalVertical (P2 x y) = 
     tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y)
diff --git a/src/Wumpus/Basic/Shapes/Base.hs b/src/Wumpus/Basic/Shapes/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Shapes/Base.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Shapes.Base
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Common core for shapes
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Shapes.Base
+  ( 
+
+
+    Shape(..)
+
+  , drawShape
+
+  -- * ShapeCTM 
+  , ShapeCTM(..)
+  , identityCTM
+
+  , ctmDisplace
+  , ctmCenter
+
+  , ShapeLabel
+  , runShapeLabel
+  , nolabel
+  , shapelabel
+
+  ) where
+
+import Wumpus.Basic.Graphic
+
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+import Control.Applicative
+import Data.Monoid
+
+
+data Shape u sh =  Shape 
+      { src_ctm :: ShapeCTM u 
+      , out_fun :: ShapeCTM u -> Image u sh
+      }
+
+type instance DUnit (Shape u sh) = u
+
+
+
+
+
+drawShape :: Shape u sh -> Image u sh
+drawShape (Shape { src_ctm = ctm, out_fun = fn }) = fn ctm 
+
+
+instance (Real u, Floating u) => Rotate (Shape u sh) where
+  rotate r = updateCTM (rotateCTM r)
+
+instance Num u => Scale (Shape u sh) where
+  scale x y = updateCTM (scaleCTM x y)
+
+instance Num u => Translate (Shape u sh) where
+  translate x y = updateCTM (translateCTM x y)
+
+updateCTM :: (ShapeCTM u -> ShapeCTM u) -> Shape u sh -> Shape u sh
+updateCTM fn (Shape ctm out) = Shape (fn ctm) out
+
+--------------------------------------------------------------------------------
+-- CTM
+
+-- Note - all shapes need a location (usually/always the center)
+-- so this needs to be stored in the CTM.
+--
+
+data ShapeCTM u = ShapeCTM 
+      { ctm_trans_x             :: !u
+      , ctm_trans_y             :: !u
+      , ctm_scale_x             :: !u
+      , ctm_scale_y             :: !u
+      , ctm_rotation            :: Radian
+      }
+  deriving (Eq,Show)
+
+type instance DUnit (ShapeCTM u) = u
+
+identityCTM :: Num u => ShapeCTM u
+identityCTM = ShapeCTM { ctm_trans_x  = 0 
+                       , ctm_trans_y  = 0 
+                       , ctm_scale_x  = 1
+                       , ctm_scale_y  = 1
+                       , ctm_rotation = 0 }
+
+
+
+
+
+scaleCTM :: Num u => u -> u -> ShapeCTM u -> ShapeCTM u
+scaleCTM sx sy = 
+    (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy })
+      <*> ctm_scale_x <*> ctm_scale_y
+
+
+rotateCTM :: Radian -> ShapeCTM u -> ShapeCTM u
+rotateCTM ang1 = 
+    (\s ang -> s { ctm_rotation = circularModulo $ ang1+ang })
+      <*> ctm_rotation
+
+
+translateCTM :: Num u => u -> u -> ShapeCTM u -> ShapeCTM u
+translateCTM dx dy = 
+    (\s x y -> s { ctm_trans_x = x+dx, ctm_trans_y = y+dy })
+      <*> ctm_trans_x <*> ctm_trans_y
+
+
+ctmDisplace :: (Real u, Floating u) => Point2 u -> ShapeCTM u -> Point2 u
+ctmDisplace (P2 x y) (ShapeCTM { ctm_trans_x  = dx, ctm_trans_y  = dy 
+                               , ctm_scale_x  = sx, ctm_scale_y  = sy
+                               , ctm_rotation = theta }) = 
+    translate dx dy $ rotate theta $ P2 (sx*x) (sy*y)
+
+
+ctmCenter :: (Real u, Floating u) => ShapeCTM u -> Point2 u
+ctmCenter = ctmDisplace zeroPt
+
+
+newtype ShapeLabel u = ShapeLabel { getShapeLabel :: ShapeCTM u -> Graphic u }
+
+runShapeLabel :: ShapeCTM u -> ShapeLabel u -> Graphic u
+runShapeLabel ctm sl = getShapeLabel sl ctm
+
+nolabel :: ShapeLabel u
+nolabel = ShapeLabel $ \_ -> mempty
+
+-- | No scaling - change font size if needed.
+--
+shapelabel :: (Real u, Floating u, FromPtSize u) 
+             => String -> ShapeLabel u
+shapelabel text = 
+   ShapeLabel $ \(ShapeCTM { ctm_trans_x=dx, ctm_trans_y=dy
+                           , ctm_rotation = ang }) ->
+                   monoVecToCenter text >>= \v -> 
+                   let ctr = P2 dx dy; bl = ctr .-^ v in 
+                   rotTextline ang text (rotateAbout ang ctr bl)
+
+
+rotTextline :: (Real u, Floating u) => Radian -> String -> LocGraphic u
+rotTextline theta ss baseline_left = 
+    withTextAttr $ \rgb attr -> 
+        singleH $ rotatePrim theta $ textlabel rgb attr ss baseline_left
+     
diff --git a/src/Wumpus/Basic/Shapes/Derived.hs b/src/Wumpus/Basic/Shapes/Derived.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Shapes/Derived.hs
@@ -0,0 +1,411 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Shapes.Derived
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Shapes.Derived
+  ( 
+    Rectangle
+  , DRectangle
+  , rectangle
+  , lrectangle
+
+  , Circle
+  , DCircle
+  , circle
+  , lcircle
+
+  , Coordinate
+  , DCoordinate
+  , coordinate
+
+  , Diamond
+  , DDiamond
+  , diamond
+  , ldiamond
+
+  , Ellipse
+  , DEllipse
+  , ellipse
+  , lellipse
+
+  , FreeLabel
+  , DFreeLabel
+  , freelabel
+
+  ) where
+
+import Wumpus.Basic.Anchors
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Shapes.Base
+import Wumpus.Basic.Utils.Intersection
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space 
+
+import Data.Monoid
+
+
+--------------------------------------------------------------------------------
+-- Rectangle
+
+data Rectangle u = Rectangle 
+      { rect_ctm    :: ShapeCTM u
+      , rect_hw     :: !u
+      , rect_hh     :: !u 
+      }
+  deriving (Eq,Show)
+
+type DRectangle = Rectangle Double
+
+type instance DUnit (Rectangle u) = u
+
+
+instance (Real u, Floating u) => CenterAnchor (Rectangle u) where
+  center = ctmCenter . rect_ctm
+
+
+calcRectPoint :: (Real u, Floating u) 
+              => (u -> u -> Point2 u) -> Rectangle u -> Point2 u
+calcRectPoint f (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) =
+    let pt = f hw hh in ctmDisplace pt ctm
+
+instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where
+  north = calcRectPoint $ \ _  hh -> P2 0 hh
+  south = calcRectPoint $ \ _  hh -> P2 0 (-hh)
+  east  = calcRectPoint $ \ hw _  -> P2 hw 0
+  west  = calcRectPoint $ \ hw _  -> P2 (-hw) 0
+
+instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where
+  northeast = calcRectPoint $ \ hw hh -> P2 hw hh
+  southeast = calcRectPoint $ \ hw hh -> P2 hw (-hh)
+  southwest = calcRectPoint $ \ hw hh -> P2 (-hw) (-hh)
+  northwest = calcRectPoint $ \ hw hh -> P2 (-hw) hh
+
+
+instance (Real u, Floating u) => RadialAnchor (Rectangle u) where
+  radialAnchor theta rect@(Rectangle { rect_hw=hw, rect_hh=hh }) = 
+      maybe ctr id $ findIntersect ctr theta $ rectangleLines ctr hw hh 
+    where 
+      ctr = ctmCenter $ rect_ctm rect
+
+rectangle :: (Real u, Floating u) => u -> u -> Shape u (Rectangle u)
+rectangle w h = Shape { src_ctm = identityCTM
+                      , out_fun = outputRect (0.5*w) (0.5*h) nolabel
+                      }
+
+
+lrectangle :: (Real u, Floating u, FromPtSize u) 
+           => u -> u -> String -> Shape u (Rectangle u)
+lrectangle w h ss = Shape { src_ctm = identityCTM
+                          , out_fun = outputRect (0.5*w) (0.5*h) (shapelabel ss)
+                          }
+
+
+outputRect :: (Real u, Floating u) 
+           => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Rectangle u)
+outputRect hw hh shl ctm = intoImage (pureDF a) (drawRect a `mappend` label) 
+  where
+    a     = Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }
+    label = runShapeLabel ctm shl
+
+
+drawRect :: (Real u, Floating u) => Rectangle u -> Graphic u
+drawRect = borderedPath . rectPath
+
+
+rectPath :: (Real u, Floating u) => Rectangle u -> PrimPath u
+rectPath rect = vertexPath [ southwest rect
+                           , southeast rect
+                           , northeast rect
+                           , northwest rect
+                           ]
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- Circle
+
+data Circle u = Circle 
+      { circ_ctm    :: ShapeCTM u
+      , circ_radius :: !u 
+      }
+  deriving (Eq,Show)
+  
+type DCircle = Circle Double
+
+type instance DUnit (Circle u) = u
+
+instance (Real u, Floating u) => CenterAnchor (Circle u) where
+  center = ctmCenter . circ_ctm
+
+
+calcCircPoint :: (Real u, Floating u) 
+              => (u -> Point2 u) -> Circle u -> Point2 u
+calcCircPoint f (Circle { circ_ctm = ctm, circ_radius = rad }) =
+    let pt = f rad in ctmDisplace pt ctm
+
+instance (Real u, Floating u) => CardinalAnchor (Circle u) where
+  north = calcCircPoint $ \ r -> P2 0  r
+  south = calcCircPoint $ \ r -> P2 0 (-r)
+  east  = calcCircPoint $ \ r -> P2 r  0
+  west  = calcCircPoint $ \ r -> P2 (-r) 0
+
+instance (Real u, Floating u) => RadialAnchor (Circle u) where
+  radialAnchor theta = calcCircPoint $ \r -> zeroPt .+^ avec theta r
+
+
+instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where
+  northeast = radialAnchor (0.25*pi)
+  southeast = radialAnchor (1.75*pi)
+  southwest = radialAnchor (1.25*pi)
+  northwest = radialAnchor (0.75*pi)
+
+
+circle :: (Real u, Floating u) => u -> Shape u (Circle u)
+circle radius = Shape { src_ctm = identityCTM
+                      , out_fun = outputCirc radius nolabel
+                      }
+
+
+lcircle :: (Real u, Floating u, FromPtSize u) 
+        => u -> String -> Shape u (Circle u)
+lcircle radius ss = Shape { src_ctm = identityCTM
+                          , out_fun = outputCirc radius (shapelabel ss)
+                          }
+
+outputCirc :: (Real u, Floating u) 
+           => u -> ShapeLabel u -> ShapeCTM u -> Image u (Circle u)
+outputCirc rad shl ctm = intoImage (pureDF a) (drawCirc a `mappend` label) 
+  where
+    a     = Circle { circ_ctm = ctm, circ_radius = rad }
+    label = runShapeLabel ctm shl
+
+
+drawCirc :: (Real u, Floating u) => Circle u -> Graphic u
+drawCirc = borderedPath . circlePath
+
+
+circlePath :: (Real u, Floating u) => Circle u -> PrimPath u
+circlePath = curvedPath . circlePoints 
+
+circlePoints :: (Real u, Floating u) => Circle u -> [Point2 u]
+circlePoints (Circle { circ_ctm=ctm, circ_radius=radius }) = map fn all_points
+  where
+    fn pt       = ctmDisplace pt ctm
+    all_points  = bezierCircle 2 radius zeroPt 
+
+
+--------------------------------------------------------------------------------
+-- | Coordinate
+
+data Coordinate u = Coordinate
+      { coord_ctm   :: ShapeCTM u 
+      }
+
+type DCoordinate = Coordinate Double
+
+type instance DUnit (Coordinate u) = u
+
+instance (Real u, Floating u) => CenterAnchor (Coordinate u) where
+  center = ctmCenter . coord_ctm
+
+
+coordinate :: (Real u, Floating u) => Shape u (Coordinate u)
+coordinate = Shape { src_ctm = identityCTM
+                   , out_fun = outputCoord
+                   }
+
+outputCoord :: (Real u, Floating u) => ShapeCTM u -> Image u (Coordinate u)
+outputCoord ctm = intoImage (pureDF a) (drawCoord a) 
+  where
+    a = Coordinate { coord_ctm = ctm }
+
+
+drawCoord :: (Real u, Floating u) => Coordinate u -> Graphic u
+drawCoord coord = localDF swapColours $ filledEllipse 2 2 (center coord)
+
+--------------------------------------------------------------------------------
+-- Diamond
+
+
+data Diamond u = Diamond 
+      { dia_ctm   :: ShapeCTM u
+      , dia_hw    :: !u
+      , dia_hh    :: !u
+      }
+
+type DDiamond = Diamond Double
+
+type instance DUnit (Diamond u) = u
+
+
+instance (Real u, Floating u) => CenterAnchor (Diamond u) where
+  center = ctmCenter . dia_ctm
+
+
+calcDiaPoint :: (Real u, Floating u) 
+             => (u -> u -> Point2 u) -> Diamond u -> Point2 u
+calcDiaPoint f (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) =
+    let pt = f hw hh in ctmDisplace pt ctm
+
+instance (Real u, Floating u) => CardinalAnchor (Diamond u) where
+  north = calcDiaPoint $ \ _  hh -> P2 0 hh
+  south = calcDiaPoint $ \ _  hh -> P2 0 (-hh)
+  east  = calcDiaPoint $ \ hw _  -> P2 hw 0
+  west  = calcDiaPoint $ \ hw _  -> P2 (-hw) 0
+
+diamond :: (Real u, Floating u) => u -> u -> Shape u (Diamond u)
+diamond hw hh = Shape { src_ctm = identityCTM
+                      , out_fun = outputDia hw hh nolabel
+                      }
+
+
+ldiamond :: (Real u, Floating u, FromPtSize u) 
+         => u -> u -> String -> Shape u (Diamond u)
+ldiamond hw hh ss = Shape { src_ctm = identityCTM
+                          , out_fun = outputDia hw hh (shapelabel ss)
+                          }
+
+
+
+outputDia :: (Real u, Floating u) 
+          => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Diamond u)
+outputDia hw hh shl ctm = intoImage (pureDF a) (drawDia a `mappend` label) 
+  where
+    a     = Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }
+    label = runShapeLabel ctm shl
+
+drawDia :: (Real u, Floating u) => Diamond u -> Graphic u
+drawDia = borderedPath . diamondPath
+
+
+diamondPath :: (Real u, Floating u) => Diamond u -> PrimPath u
+diamondPath dia = vertexPath [ south dia, east dia, north dia, west dia ]
+
+
+--------------------------------------------------------------------------------
+-- Ellipse
+
+
+data Ellipse u = Ellipse
+      { ell_ctm     :: ShapeCTM u 
+      , ell_rx      :: !u
+      , ell_ry      :: !u
+      }
+
+type DEllipse = Ellipse Double
+
+type instance DUnit (Ellipse u) = u
+
+
+
+instance (Real u, Floating u) => CenterAnchor (Ellipse u) where
+  center = ctmCenter . ell_ctm
+
+
+ellipse :: (Real u, Floating u) => u -> u -> Shape u (Ellipse u)
+ellipse rx ry = Shape { src_ctm = identityCTM
+                      , out_fun = outputEll rx ry nolabel
+                      }
+
+lellipse :: (Real u, Floating u, FromPtSize u) 
+         => u -> u -> String -> Shape u (Ellipse u)
+lellipse rx ry ss = Shape { src_ctm = identityCTM
+                          , out_fun = outputEll rx ry (shapelabel ss)
+                          }
+
+
+outputEll :: (Real u, Floating u) 
+          => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Ellipse u)
+outputEll rx ry shl ctm = intoImage (pureDF a) (drawEll a `mappend` label)
+  where
+    a     = Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }
+    label = runShapeLabel ctm shl
+
+
+drawEll :: (Real u, Floating u) => Ellipse u -> Graphic u
+drawEll = borderedPath . ellipsePath
+
+
+ellipsePath :: (Real u, Floating u) => Ellipse u -> PrimPath u
+ellipsePath = curvedPath . ellipsePoints
+
+ellipsePoints :: (Real u, Floating u) => Ellipse u -> [Point2 u]
+ellipsePoints (Ellipse { ell_ctm=ctm, ell_rx=rx, ell_ry=ry }) = 
+    map (ctmDisplace `flip` ctm) all_points
+  where
+    all_points  = map (rescale rx ry) $ bezierCircle 2 rx zeroPt 
+
+
+-- | x_radius is the unit length.
+--
+rescale :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t
+rescale rx ry = scale 1 (ry/rx) 
+
+
+--------------------------------------------------------------------------------
+-- Free label
+
+-- Free label is a rectangle that /is not drawn/, the 
+-- constructor should always create some text.
+
+newtype FreeLabel u = FreeLabel { getFreeLabel :: Rectangle u }
+
+
+type DFreeLabel = FreeLabel Double
+
+type instance DUnit (FreeLabel u) = u
+
+
+instance (Real u, Floating u) => CenterAnchor (FreeLabel u) where
+  center = center . getFreeLabel
+
+
+instance (Real u, Floating u) => CardinalAnchor (FreeLabel u) where
+  north = north . getFreeLabel
+  south = south . getFreeLabel
+  east  = east . getFreeLabel
+  west  = west . getFreeLabel
+
+instance (Real u, Floating u) => CardinalAnchor2 (FreeLabel u) where
+  northeast = northeast . getFreeLabel
+  southeast = southeast . getFreeLabel
+  southwest = southwest . getFreeLabel
+  northwest = northwest . getFreeLabel
+
+instance (Real u, Floating u) => RadialAnchor (FreeLabel u) where
+  radialAnchor theta = radialAnchor theta . getFreeLabel
+
+freelabel :: (Real u, Floating u, FromPtSize u) 
+          => String -> Shape u (FreeLabel u)
+freelabel ss = Shape { src_ctm = identityCTM
+                     , out_fun = outputStringLbl ss
+                     }
+
+outputStringLbl :: (Real u, Floating u, FromPtSize u) 
+                => String -> ShapeCTM u -> Image u (FreeLabel u)
+outputStringLbl ss ctm = 
+    intoImage (monoTextDimensions ss >>= \(w,h) -> return (mkrect w h)) label
+  where
+    mkrect w h = FreeLabel $ Rectangle { rect_ctm = ctm
+                                       , rect_hw  = 0.5*w
+                                       , rect_hh  = 0.5*h }
+    label = runShapeLabel ctm (shapelabel ss)
diff --git a/src/Wumpus/Basic/Text/LRSymbol.hs b/src/Wumpus/Basic/Text/LRSymbol.hs
--- a/src/Wumpus/Basic/Text/LRSymbol.hs
+++ b/src/Wumpus/Basic/Text/LRSymbol.hs
@@ -12,19 +12,53 @@
 --
 -- Named literals from Symbol font, drawn with the LRText monad.
 -- 
--- Note - currently the techinique used here generates adequate
--- PostScript, but very ineficient SVG.
--- 
--- Also uUpsilon is not mapped to the correct character...
+-- Note - Symbol font handling and precise letter placing in SVG 
+-- viewers is mixed. Chrome works well good, Firefox (3.6.3) and 
+-- Safari (5.0.1) are unsatisfactory.
+--  
+--   
 --
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Text.LRSymbol
   ( 
 
+
+  -- * Upper case letters and upper case Greek letters
+    uAlpha
+  , uBeta
+  , uChi
+  , uDelta
+  , uEpsilon
+  , uEta
+  , uEuro
+  , uGamma
+  , uIfraktur
+  , uIota
+  , uKappa
+  , uLambda
+  , uMu
+  , uNu
+  , uOmega
+  , uOmicron
+  , uPhi
+  , uPi
+  , uPsi
+  , uRfraktur
+  , uRho
+  , uSigma
+  , uTau
+  , uTheta
+  , uUpsilon
+  , uUpsilon1
+  , uXi
+  , uZeta
+  
+
+
   -- * Lower case Greek letters
 
-    alpha
+  , alpha
   , beta
   , gamma
   , delta
@@ -48,21 +82,121 @@
   , psi
   , omega
 
-  -- * Upper case Greek letters
-  , uGamma
-  , uDelta
-  , uTheta
-  , uLambda
-  , uXi
-  , uPi
-  , uSigma
-  , uUpsilon
-  , uPhi
-  , uPsi
-  , uOmega
-
-  , otimes
-  , oplus
+  -- * Miscellaneous chars
+  , aleph
+  , ampersand
+  , angle
+  , angleleft
+  , angleright
+  , approxequal
+  , arrowboth
+  , arrowdblboth
+  , arrowdbldown
+  , arrowdblleft
+  , arrowdblright
+  , arrowdblup
+  , arrowdown
+  , arrowleft
+  , arrowright
+  , arrowup
+  , asteriskmath
+  , bar
+  , braceleft
+  , braceright
+  , bracketleft
+  , bracketright
+  , bullet
+  , carriagereturn
+  , circlemultiply
+  , circleplus
+  , club 
+  , colon
+  , comma
+  , congruent
+  , copyrightsans
+  , copyrightserif
+  , degree
+  , diamond
+  , divide
+  , dotmath
+  , eight
+  , element
+  , ellipsis
+  , emptyset
+  , equal
+  , equivalence
+  , exclam
+  , existential
+  , five
+  , florin
+  , four
+  , fraction
+  , gradient
+  , greater
+  , greaterequal
+  , heart
+  , infinity
+  , integral
+  , intersection
+  , less
+  , lessequal
+  , logicaland
+  , logicalnot
+  , logicalor
+  , lozenge
+  , minus
+  , minute
+  , multiply
+  , nine
+  , notelement
+  , notequal
+  , notsubset
+  , numbersign
+  , omega1
+  , omicron
+  , one
+  , parenleft
+  , parenright
+  , partialdiff
+  , percent
+  , period
+  , perpendicular
+  , phi1
+  , plus
+  , plusminus
+  , product
+  , propersubset
+  , propersuperset
+  , proportional
+  , question
+  , radical
+  , radicalex
+  , reflexsubset
+  , reflexsuperset
+  , registersans
+  , registerserif
+  , second
+  , semicolon
+  , seven
+  , sigma1
+  , similar
+  , six
+  , slash
+  , space
+  , spade
+  , suchthat
+  , summation
+  , therefore
+  , theta1
+  , three
+  , trademarksans
+  , trademarkserif
+  , two
+  , underscore
+  , union
+  , universal
+  , weierstrass
+  , zero
 
   ) where
 
@@ -70,144 +204,543 @@
 import Wumpus.Basic.Text.LRText
 
 
-import Prelude hiding ( pi )
+import Prelude hiding ( pi, product )
 
--- Note - due to a optimization in Wumpus-Core, the PostScript
--- generated by the techinique here - writing a 
--- (single-character) label one at a time - isn\'t too bad as 
--- Wumpus-Core only issues a findfont command when the font 
--- changes. 
--- 
--- However for SVG the result is very poor - one text element 
--- including an orientation changing matrix transforming for 
--- each character.
--- 
--- Wumpus-Core\'s SVG rendering will work at some point.
--- 
 
 
 --------------------------------------------------------------------------------
--- lower case
+-- upper case
 
+-- | Note - prints as \'A\'.
+--
+uAlpha          :: Num u => LRText u ()
+uAlpha          = symb 'A'
 
-alpha       :: Num u => TextM u ()
-alpha       = symb 'a'
+-- | Note - prints as \'B\'.
+--
+uBeta           :: Num u => LRText u ()
+uBeta           = symb 'B'
 
-beta        :: Num u => TextM u ()
-beta        = symb 'b'
+-- | Note - prints as \'X\'.
+--
+uChi            :: Num u => LRText u ()
+uChi            = symb 'C'
 
-gamma       :: Num u => TextM u ()
-gamma       = symb 'g'
+uDelta          :: Num u => LRText u ()
+uDelta          = symb 'D'
 
-delta       :: Num u => TextM u ()
-delta       = symb 'd'
+-- | Note - prints as \'E\'.
+--
+uEpsilon        :: Num u => LRText u ()
+uEpsilon        = symb 'E'
 
-epsilon     :: Num u => TextM u ()
-epsilon     = symb 'e'
+-- | Note - prints as \'H\'.
+--
+uEta            :: Num u => LRText u ()
+uEta            = symb 'H'
 
-zeta        :: Num u => TextM u ()
-zeta        = symb 'z'
 
-eta         :: Num u => TextM u ()
-eta         = symb 'h'
+-- | Note - does not appear to print in Chrome.
+--
+uEuro           :: Num u => LRText u ()
+uEuro           = symbEscInt 0o240
 
-theta       :: Num u => TextM u ()
-theta       = symb 'q'
+uGamma          :: Num u => LRText u ()
+uGamma          = symb 'G'
 
-iota        :: Num u => TextM u ()
-iota        = symb 'i'
+uIfraktur       :: Num u => LRText u ()
+uIfraktur       = symbEscInt 0o301
 
-kappa       :: Num u => TextM u ()
-kappa       = symb 'k'
+-- | Note - prints as \'I\'.
+--
+uIota           :: Num u => LRText u ()
+uIota           = symb 'I'
 
-lambda      :: Num u => TextM u ()
-lambda      = symb 'l'
+-- | Note - prints as \'K\'.
+--
+uKappa          :: Num u => LRText u ()
+uKappa          = symb 'K'
 
-mu          :: Num u => TextM u ()
-mu          = symb 'm'
+uLambda         :: Num u => LRText u ()
+uLambda         = symb 'L'
 
-nu          :: Num u => TextM u ()
-nu          = symb 'n'
+-- | Note - prints as \'M\'.
+--
+uMu             :: Num u => LRText u ()
+uMu             = symb 'M'
 
-xi          :: Num u => TextM u ()
-xi          = symb 'x'
+-- | Note - prints as \'N\'.
+--
+uNu             :: Num u => LRText u ()
+uNu             = symb 'N'
 
-pi          :: Num u => TextM u ()
-pi          = symb 'p'
+uOmega          :: Num u => LRText u ()
+uOmega          = symbEscInt 0o127
 
-rho         :: Num u => TextM u ()
-rho         = symb 'r'
+uOmicron        :: Num u => LRText u ()
+uOmicron        = symbEscInt 0o117
 
-sigma       :: Num u => TextM u ()
-sigma       = symb 's'
+uPhi            :: Num u => LRText u ()
+uPhi            = symbEscInt 0o106
 
-tau         :: Num u => TextM u ()
-tau         = symb 't'
+uPi             :: Num u => LRText u ()
+uPi             = symb 'P'
 
-upsilon     :: Num u => TextM u ()
-upsilon     = symb 'u'
+uPsi            :: Num u => LRText u ()
+uPsi            = symbEscInt 0o131
 
-phi         :: Num u => TextM u ()
-phi         = symb 'j'
+uRfraktur       :: Num u => LRText u ()
+uRfraktur       = symbEscInt 0o302
 
-chi         :: Num u => TextM u ()
-chi         = symb 'c'
+uRho            :: Num u => LRText u ()
+uRho            = symbEscInt 0o122
 
-psi         :: Num u => TextM u ()
-psi         = symb 'y'
+uSigma          :: Num u => LRText u ()
+uSigma          = symb 'S'
 
-omega       :: Num u => TextM u ()
-omega       = symb 'w'
+uTau            :: Num u => LRText u ()
+uTau            = symb 'T'
 
 
+uTheta          :: Num u => LRText u ()
+uTheta          = symb 'Q'
+
+-- | Note - prints as \'Y\'.
+--
+uUpsilon        :: Num u => LRText u ()
+uUpsilon        = symbEscInt 0o125
+
+-- | Note - this is the /pretty/ Upsilon.
+--
+uUpsilon1       :: Num u => LRText u ()
+uUpsilon1       = symbEscInt 0o241
+
+uXi             :: Num u => LRText u ()
+uXi             = symb 'X'
+
+uZeta           :: Num u => LRText u ()
+uZeta           = symb 'Z'
+
+
 --------------------------------------------------------------------------------
--- upper case
+-- lower case Greek letters
 
-uGamma      :: Num u => TextM u ()
-uGamma      = symb 'G'
 
-uDelta      :: Num u => TextM u ()
-uDelta      = symb 'D'
+alpha           :: Num u => LRText u ()
+alpha           = symb 'a'
 
-uTheta      :: Num u => TextM u ()
-uTheta      = symb 'Q'
+beta            :: Num u => LRText u ()
+beta            = symb 'b'
 
-uLambda     :: Num u => TextM u ()
-uLambda     = symb 'L'
+gamma           :: Num u => LRText u ()
+gamma           = symb 'g'
 
-uXi         :: Num u => TextM u ()
-uXi         = symb 'X'
+delta           :: Num u => LRText u ()
+delta           = symb 'd'
 
-uPi         :: Num u => TextM u ()
-uPi         = symb 'P'
+epsilon         :: Num u => LRText u ()
+epsilon         = symb 'e'
 
-uSigma      :: Num u => TextM u ()
-uSigma      = symb 'S'
+zeta            :: Num u => LRText u ()
+zeta            = symb 'z'
 
--- | Not working in PostScript, @\&\#161;@ works for SVG but 
--- PostScript needs an encoding table for Symbol-Font not Latin1!
---
--- For PostScript, Latin1 @161@ maps to @exclamdown@ not 
--- @Upsilon1@, extending Wumpus-Core to support this will require 
--- quite some work...
---
-uUpsilon    :: Num u => TextM u ()
-uUpsilon    = symbEscInt 161
+eta             :: Num u => LRText u ()
+eta             = symb 'h'
 
-uPhi        :: Num u => TextM u ()
-uPhi        = symb 'F'
+theta           :: Num u => LRText u ()
+theta           = symb 'q'
 
-uPsi        :: Num u => TextM u ()
-uPsi        = symb 'Y'
+iota            :: Num u => LRText u ()
+iota            = symb 'i'
 
-uOmega      :: Num u => TextM u ()
-uOmega      = symb 'W'
+kappa           :: Num u => LRText u ()
+kappa           = symb 'k'
 
+lambda          :: Num u => LRText u ()
+lambda          = symb 'l'
 
+mu              :: Num u => LRText u ()
+mu              = symb 'm'
+
+nu              :: Num u => LRText u ()
+nu              = symb 'n'
+
+xi              :: Num u => LRText u ()
+xi              = symb 'x'
+
+pi              :: Num u => LRText u ()
+pi              = symb 'p'
+
+rho             :: Num u => LRText u ()
+rho             = symb 'r'
+
+sigma           :: Num u => LRText u ()
+sigma           = symb 's'
+
+tau             :: Num u => LRText u ()
+tau             = symb 't'
+
+upsilon         :: Num u => LRText u ()
+upsilon         = symb 'u'
+
+phi             :: Num u => LRText u ()
+phi             = symb 'j'
+
+chi             :: Num u => LRText u ()
+chi             = symb 'c'
+
+psi             :: Num u => LRText u ()
+psi             = symb 'y'
+
+omega           :: Num u => LRText u ()
+omega           = symb 'w'
+
+
+
 --------------------------------------------------------------------------------
+-- Miscellaneous chars
 
-otimes      :: Num u => TextM u ()
-otimes      = symbi 0xc4
+aleph           :: Num u => LRText u ()
+aleph           = symbEscInt 0o300
 
-oplus       :: Num u => TextM u ()
-oplus       = symbi 0xc5
+ampersand       :: Num u => LRText u ()
+ampersand       = symbEscInt 0o046
+
+angle           :: Num u => LRText u ()
+angle           = symbEscInt 0o320
+
+angleleft       :: Num u => LRText u ()
+angleleft       = symbEscInt 0o341
+
+angleright      :: Num u => LRText u ()
+angleright      = symbEscInt 0o361
+
+approxequal     :: Num u => LRText u ()
+approxequal     = symbEscInt 0o273
+
+arrowboth       :: Num u => LRText u ()
+arrowboth       = symbEscInt 0o253
+
+arrowdblboth    :: Num u => LRText u ()
+arrowdblboth    = symbEscInt 0o333
+
+arrowdbldown    :: Num u => LRText u ()
+arrowdbldown    = symbEscInt 0o337
+
+arrowdblleft    :: Num u => LRText u ()
+arrowdblleft    = symbEscInt 0o334
+
+arrowdblright   :: Num u => LRText u ()
+arrowdblright   = symbEscInt 0o336
+
+arrowdblup      :: Num u => LRText u ()
+arrowdblup      = symbEscInt 0o335
+
+arrowdown       :: Num u => LRText u ()
+arrowdown       = symbEscInt 0o257
+
+arrowleft       :: Num u => LRText u ()
+arrowleft       = symbEscInt 0o254
+
+arrowright      :: Num u => LRText u ()
+arrowright      = symbEscInt 0o256
+
+arrowup         :: Num u => LRText u ()
+arrowup         = symbEscInt 0o255
+
+asteriskmath    :: Num u => LRText u ()
+asteriskmath    = symbEscInt 0o052
+
+bar             :: Num u => LRText u ()
+bar             = symbEscInt 0o174
+
+braceleft       :: Num u => LRText u ()
+braceleft       = symbEscInt 0o173
+
+braceright      :: Num u => LRText u ()
+braceright      = symbEscInt 0o175
+
+bracketleft     :: Num u => LRText u ()
+bracketleft     = symbEscInt 0o133
+
+bracketright    :: Num u => LRText u ()
+bracketright    = symbEscInt 0o135
+
+bullet          :: Num u => LRText u ()
+bullet          = symbEscInt 0o267
+
+carriagereturn  :: Num u => LRText u ()
+carriagereturn  = symbEscInt 0o277
+
+
+circlemultiply  :: Num u => LRText u ()
+circlemultiply  = symbEscInt 0o304
+
+circleplus      :: Num u => LRText u ()
+circleplus      = symbEscInt 0o305
+
+club            :: Num u => LRText u ()
+club            = symbEscInt 0o247
+
+colon           :: Num u => LRText u ()
+colon           = symbEscInt 0o072
+
+comma           :: Num u => LRText u ()
+comma           = symbEscInt 0o054
+
+congruent       :: Num u => LRText u ()
+congruent             = symbEscInt 0o100
+
+copyrightsans   :: Num u => LRText u ()
+copyrightsans   = symbEscInt 0o343
+
+copyrightserif  :: Num u => LRText u ()
+copyrightserif  = symbEscInt 0o323
+
+degree          :: Num u => LRText u ()
+degree          = symbEscInt 0o260
+
+diamond         :: Num u => LRText u ()
+diamond         = symbEscInt 0o250
+
+divide          :: Num u => LRText u ()
+divide          = symbEscInt 0o270
+
+dotmath         :: Num u => LRText u ()
+dotmath         = symbEscInt 0o327
+
+eight           :: Num u => LRText u ()
+eight           = symbEscInt 0o070
+
+element         :: Num u => LRText u ()
+element         = symbEscInt 0o316
+
+ellipsis        :: Num u => LRText u ()
+ellipsis        = symbEscInt 0o274
+
+emptyset        :: Num u => LRText u ()
+emptyset        = symbEscInt 0o306
+
+equal           :: Num u => LRText u ()
+equal           = symbEscInt 0o075
+
+equivalence     :: Num u => LRText u ()
+equivalence     = symbEscInt 0o272
+
+exclam          :: Num u => LRText u ()
+exclam          = symbEscInt 0o041
+
+existential     :: Num u => LRText u ()
+existential     = symbEscInt 0o044
+
+five            :: Num u => LRText u ()
+five            = symbEscInt 0o065
+
+florin          :: Num u => LRText u ()
+florin          = symbEscInt 0o246
+
+four            :: Num u => LRText u ()
+four            = symbEscInt 0o064
+
+fraction        :: Num u => LRText u ()
+fraction        = symbEscInt 0o244
+
+gradient        :: Num u => LRText u ()
+gradient        = symbEscInt 0o321
+
+greater         :: Num u => LRText u ()
+greater         = symbEscInt 0o076
+
+greaterequal    :: Num u => LRText u ()
+greaterequal    = symbEscInt 0o263
+
+heart           :: Num u => LRText u ()
+heart           = symbEscInt 0o251
+
+infinity        :: Num u => LRText u ()
+infinity        = symbEscInt 0o245
+
+integral        :: Num u => LRText u ()
+integral        = symbEscInt 0o362
+
+intersection    :: Num u => LRText u ()
+intersection    = symbEscInt 0o307
+
+less            :: Num u => LRText u ()
+less            = symbEscInt 0o074
+
+lessequal       :: Num u => LRText u ()
+lessequal       = symbEscInt 0o243
+
+logicaland      :: Num u => LRText u ()
+logicaland      = symbEscInt 0o331
+
+logicalnot      :: Num u => LRText u ()
+logicalnot      = symbEscInt 0o330
+
+logicalor       :: Num u => LRText u ()
+logicalor       = symbEscInt 0o332
+
+lozenge         :: Num u => LRText u ()
+lozenge         = symbEscInt 0o340
+
+minus           :: Num u => LRText u ()
+minus           = symbEscInt 0o055
+
+minute          :: Num u => LRText u ()
+minute          = symbEscInt 0o242
+
+multiply        :: Num u => LRText u ()
+multiply        = symbEscInt 0o264
+
+nine            :: Num u => LRText u ()
+nine            = symbEscInt 0o071
+
+notelement      :: Num u => LRText u ()
+notelement      = symbEscInt 0o317
+
+notequal        :: Num u => LRText u ()
+notequal        = symbEscInt 0o271
+
+notsubset       :: Num u => LRText u ()
+notsubset       = symbEscInt 0o313
+
+numbersign      :: Num u => LRText u ()
+numbersign      = symbEscInt 0o043
+
+omega1          :: Num u => LRText u ()
+omega1          = symbEscInt 0o166
+
+omicron         :: Num u => LRText u ()
+omicron         = symbEscInt 0o157
+
+one             :: Num u => LRText u ()
+one             = symbEscInt 0o061
+
+parenleft       :: Num u => LRText u ()
+parenleft       = symbEscInt 0o050
+
+parenright      :: Num u => LRText u ()
+parenright      = symbEscInt 0o051
+
+partialdiff     :: Num u => LRText u ()
+partialdiff     = symbEscInt 0o266
+
+percent         :: Num u => LRText u ()
+percent         = symbEscInt 0o045
+
+period          :: Num u => LRText u ()
+period          = symbEscInt 0o056
+
+perpendicular   :: Num u => LRText u ()
+perpendicular   = symbEscInt 0o136
+
+phi1            :: Num u => LRText u ()
+phi1            = symbEscInt 0o152
+
+plus            :: Num u => LRText u ()
+plus            = symbEscInt 0o053
+
+plusminus       :: Num u => LRText u ()
+plusminus       = symbEscInt 0o261
+
+product         :: Num u => LRText u ()
+product         = symbEscInt 0o325
+
+propersubset    :: Num u => LRText u ()
+propersubset    = symbEscInt 0o314
+
+propersuperset  :: Num u => LRText u ()
+propersuperset  = symbEscInt 0o311
+
+proportional    :: Num u => LRText u ()
+proportional    = symbEscInt 0o265
+
+question        :: Num u => LRText u ()
+question        = symbEscInt 0o077
+
+radical         :: Num u => LRText u ()
+radical         = symbEscInt 0o326
+
+radicalex       :: Num u => LRText u ()
+radicalex       = symbEscInt 0o140
+
+reflexsubset    :: Num u => LRText u ()
+reflexsubset    = symbEscInt 0o315
+
+reflexsuperset  :: Num u => LRText u ()
+reflexsuperset  = symbEscInt 0o312
+
+registersans    :: Num u => LRText u ()
+registersans    = symbEscInt 0o342
+
+registerserif   :: Num u => LRText u ()
+registerserif   = symbEscInt 0o322
+
+second          :: Num u => LRText u ()
+second          = symbEscInt 0o262
+
+semicolon       :: Num u => LRText u ()
+semicolon       = symbEscInt 0o073
+
+seven           :: Num u => LRText u ()
+seven           = symbEscInt 0o067
+
+sigma1          :: Num u => LRText u ()
+sigma1          = symbEscInt 0o126
+
+similar         :: Num u => LRText u ()
+similar         = symbEscInt 0o176
+
+six             :: Num u => LRText u ()
+six             = symbEscInt 0o066
+
+slash           :: Num u => LRText u ()
+slash           = symbEscInt 0o057
+
+space           :: Num u => LRText u ()
+space           = symbEscInt 0o040
+
+spade           :: Num u => LRText u ()
+spade           = symbEscInt 0o252
+
+suchthat        :: Num u => LRText u ()
+suchthat        = symbEscInt 0o047
+
+summation       :: Num u => LRText u ()
+summation       = symbEscInt 0o345
+
+therefore       :: Num u => LRText u ()
+therefore       = symbEscInt 0o134
+
+theta1          :: Num u => LRText u ()
+theta1          = symbEscInt 0o112
+
+three           :: Num u => LRText u ()
+three           = symbEscInt 0o063
+
+trademarksans   :: Num u => LRText u ()
+trademarksans   = symbEscInt 0o344
+
+trademarkserif  :: Num u => LRText u ()
+trademarkserif  = symbEscInt 0o324
+
+two             :: Num u => LRText u ()
+two             = symbEscInt 0o062
+
+underscore      :: Num u => LRText u ()
+underscore      = symbEscInt 0o137
+
+union           :: Num u => LRText u ()
+union           = symbEscInt 0o310
+
+universal       :: Num u => LRText u ()
+universal       = symbEscInt 0o042
+
+weierstrass     :: Num u => LRText u ()
+weierstrass     = symbEscInt 0o303
+
+zero            :: Num u => LRText u ()
+zero            = symbEscInt 0o060
+
+
diff --git a/src/Wumpus/Basic/Text/LRText.hs b/src/Wumpus/Basic/Text/LRText.hs
--- a/src/Wumpus/Basic/Text/LRText.hs
+++ b/src/Wumpus/Basic/Text/LRText.hs
@@ -18,8 +18,8 @@
 -- expected that kerning will need to be added per-letter for
 -- variable width fonts.
 --
--- This module makes precise text spacing \*possible\* - it does 
--- not make it \*easy\*.
+-- This module makes precise horizontal text spacing \*possible\*, 
+-- it does not make it \*easy\*.
 -- 
 --------------------------------------------------------------------------------
 
@@ -27,15 +27,18 @@
   ( 
 
 
-    TextM
-  , runTextM
-  , execTextM
+    LRText
 
+  , runLRText
+  , execLRText
+
   , kern
   , char
+  , escInt
+  , escName
   , symb
-  , symbi
   , symbEscInt
+  , symbEscName
 
   ) where
 
@@ -47,7 +50,6 @@
 
 import Control.Applicative
 import Control.Monad
-import Data.Char ( chr )
 import Data.Monoid
 
 
@@ -59,9 +61,8 @@
 -- Note - if we have font change (e.g. to symbol font) then we 
 -- have to generate more than one hkernline.
 -- 
--- If one wants to be really prissy about optimization, one could
--- generate two simultaneous and overlayed lines - one in regular 
--- font, one in Symbol. 
+-- Apropos /optimization/ we have two two simultaneous and 
+-- overlayed lines - one in the regular font, and one in Symbol. 
 --
 -- Result should be a LocGraphic (so cannot do a trace as we go). 
 --
@@ -92,106 +93,109 @@
 -- can take the initial font size, stroke colour etc.
 --
 
-newtype TextM u a = TextM { getTextM :: Env u -> St u -> (a, St u) }
+newtype LRText u a = LRText { getLRText :: Env u -> St u -> (a, St u) }
 
-type instance MonUnit (TextM u) = u
+type instance MonUnit (LRText u) = u
 
-instance Functor (TextM u) where
-  fmap f mf = TextM $ \r s -> let (a,s') = getTextM mf r s in (f a,s')
+instance Functor (LRText u) where
+  fmap f mf = LRText $ \r s -> let (a,s') = getLRText mf r s in (f a,s')
 
 
-instance Applicative (TextM u) where
-  pure a    = TextM $ \_ s -> (a,s)
-  mf <*> ma = TextM $ \r s -> let (f,s')  = getTextM mf r s
-                                  (a,s'') = getTextM ma r s'
-                              in (f a,s'')
+instance Applicative (LRText u) where
+  pure a    = LRText $ \_ s -> (a,s)
+  mf <*> ma = LRText $ \r s -> let (f,s')  = getLRText mf r s
+                                   (a,s'') = getLRText ma r s'
+                               in (f a,s'')
 
-instance Monad (TextM u) where
-  return a  = TextM $ \_ s -> (a,s)
-  m >>= k   = TextM $ \r s -> let (a,s')  = getTextM m r s 
-                              in (getTextM . k) a r s'
+instance Monad (LRText u) where
+  return a  = LRText $ \_ s -> (a,s)
+  m >>= k   = LRText $ \r s -> let (a,s')  = getLRText m r s 
+                               in (getLRText . k) a r s'
 
-                              
--- Note - post has to displace in the vertical to get the bottom 
--- line at the base line...
 
-runTextM :: (Num u, FromPtSize u, DrawingCtxM m, u ~ MonUnit m) 
-         => TextM u a -> m (a, LocGraphic u)
-runTextM ma = askCtx >>= \ctx -> 
-    let e = runDF ctx envZero in post $ getTextM ma e stZero
-  where
-    post (a,st)  = let sG = updCtxSym $ mkHKern $ toListH $ acc_sym st
-                       cG = mkHKern $ toListH $ acc_chr st
-                   in return (a, sG `lgappend` cG)
 
-    mkHKern []   = const mempty
-    mkHKern xs   = hkernline xs
 
-    updCtxSym lg = localLG (fontface symbol) lg
+runLRText :: (Num u, FromPtSize u) => LRText u a -> LocImage u a
+runLRText ma = \pt -> envZero >>= \e1 -> 
+                   let (a,st) = getLRText ma e1 st_zero 
+                   in mkline pt (acc_chr st) >>= \g1 ->
+                      localDF (fontface symbol) (mkline pt (acc_sym st)) >>= \g2 ->
+                      return (a,g1 `mappend` g2)
+  where
+    mkline pt h = case toListH h of
+                   [] -> return mempty
+                   xs -> hkernline xs pt
 
 
-execTextM :: (Num u, FromPtSize u, DrawingCtxM m, u ~ MonUnit m) 
-          => TextM u a -> m (LocGraphic u)
-execTextM ma = liftM snd $ runTextM ma  
-
+execLRText :: (Num u, FromPtSize u) => LRText u a -> LocGraphic u
+execLRText ma = \pt -> liftM snd (runLRText ma pt) 
 
-stZero :: Num u => St u
-stZero = St { delta_chr       = 0
-            , delta_sym       = 0
-            , acc_chr         = emptyH
-            , acc_sym         = emptyH }
+st_zero :: Num u => St u
+st_zero = St { delta_chr       = 0
+             , delta_sym       = 0
+             , acc_chr         = emptyH
+             , acc_sym         = emptyH }
+ 
 
 envZero :: FromPtSize u => DrawingF (Env u)
 envZero = (\sz -> Env { char_width   = fromPtSize $ charWidth sz
                       , spacer_width = fromPtSize $ spacerWidth sz })
-            <$> asksDF (font_size . font_props)
+            <$> fontSize
 
 
-gets :: (St u -> a) -> TextM u a
-gets fn = TextM $ \_ s -> (fn s, s)
+gets :: (St u -> a) -> LRText u a
+gets fn = LRText $ \_ s -> (fn s, s)
 
-charMove :: Num u => TextM u ()
-charMove = TextM $ \(Env {char_width=cw, spacer_width=sw}) s -> 
+charMove :: Num u => LRText u ()
+charMove = LRText $ \(Env {char_width=cw, spacer_width=sw}) s -> 
              let step_width = cw + sw    
                  d_sym      = (delta_sym s) + step_width
              in ((), s { delta_chr = step_width, delta_sym = d_sym }) 
 
-symbMove :: Num u => TextM u ()
-symbMove = TextM $ \(Env {char_width=cw, spacer_width=sw}) s -> 
+symbMove :: Num u => LRText u ()
+symbMove = LRText $ \(Env {char_width=cw, spacer_width=sw}) s -> 
              let step_width = cw + sw
                  d_chr      = (delta_chr s) + step_width
              in ((), s { delta_chr = d_chr, delta_sym = step_width }) 
 
-snocSymb :: KerningChar u -> TextM u ()
-snocSymb kc = TextM $ \_ s -> ((), upd s)
+snocSymb :: KerningChar u -> LRText u ()
+snocSymb kc = LRText $ \_ s -> ((), upd s)
   where
     upd = (\s a -> s { acc_sym = a `snocH` kc}) <*> acc_sym
 
-snocChar :: KerningChar u -> TextM u ()
-snocChar kc = TextM $ \_ s -> ((), upd s)
+snocChar :: KerningChar u -> LRText u ()
+snocChar kc = LRText $ \_ s -> ((), upd s)
   where
     upd = (\s a -> s { acc_chr = a `snocH` kc}) <*> acc_chr
 
-kern :: Num u => u -> TextM u ()
-kern dx = TextM $ \_ s -> ((), upd s)
+kern :: Num u => u -> LRText u ()
+kern dx = LRText $ \_ s -> ((), upd s)
   where
     upd = (\s a b -> s { delta_chr = a+dx, delta_sym = b+dx}) 
             <*> delta_chr <*> delta_sym
 
-char :: Num u => Char -> TextM u ()
+char :: Num u => Char -> LRText u ()
 char ch = gets delta_chr           >>= \u -> 
           snocChar (kernchar u ch) >> charMove
 
-symb :: Num u => Char -> TextM u ()
-symb sy = gets delta_sym           >>= \u -> 
-          snocSymb (kernchar u sy) >> symbMove
+escInt ::  Num u => Int -> LRText u ()
+escInt i = gets delta_chr            >>= \u -> 
+           snocChar (kernEscInt u i) >> charMove
 
+escName ::  Num u => String -> LRText u ()
+escName s = gets delta_chr             >>= \u -> 
+            snocChar (kernEscName u s) >> charMove
 
-symbi :: Num u => Int -> TextM u ()
-symbi i = symb (chr i) 
 
+symb :: Num u => Char -> LRText u ()
+symb sy = gets delta_sym           >>= \u -> 
+          snocSymb (kernchar u sy) >> symbMove
 
-symbEscInt :: Num u => Int -> TextM u ()
+
+symbEscInt :: Num u => Int -> LRText u ()
 symbEscInt i = gets delta_sym            >>= \u -> 
                snocSymb (kernEscInt u i) >> symbMove
 
+symbEscName :: Num u => String -> LRText u ()
+symbEscName s = gets delta_sym             >>= \u -> 
+                snocSymb (kernEscName u s) >> symbMove
diff --git a/src/Wumpus/Basic/Utils/Intersection.hs b/src/Wumpus/Basic/Utils/Intersection.hs
--- a/src/Wumpus/Basic/Utils/Intersection.hs
+++ b/src/Wumpus/Basic/Utils/Intersection.hs
@@ -81,8 +81,9 @@
 --
 findIntersect :: (Floating u, Real u, Ord u)
                => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u)
-findIntersect ctr theta = step 
+findIntersect ctr ang0 = step 
   where
+    theta       = circularModulo ang0
     eqn         = toLineEqn $ pointSlope ctr theta
     step []     = Nothing
     step (x:xs) = case intersection x eqn of 
diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs
--- a/src/Wumpus/Basic/VersionNumber.hs
+++ b/src/Wumpus/Basic/VersionNumber.hs
@@ -23,7 +23,7 @@
 
 -- | Version number
 --
--- > (0,8,0)
+-- > (0,9,0)
 --
 wumpus_basic_version :: (Int,Int,Int)
-wumpus_basic_version = (0,8,0)
+wumpus_basic_version = (0,9,0)
diff --git a/wumpus-basic.cabal b/wumpus-basic.cabal
--- a/wumpus-basic.cabal
+++ b/wumpus-basic.cabal
@@ -1,5 +1,5 @@
 name:             wumpus-basic
-version:          0.8.0
+version:          0.9.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -21,6 +21,37 @@
   .
   Changelog:
   .
+  0.8.0 to 0.9.0:
+  .
+  * Re-worked @Basic.Text.LRSymbol@ changed the type name and the
+    types of the run functions. Added more symbols and a new demo 
+    @Symbols.hs@.
+  .
+  * @ScalingContext@ added to @Basic.Graphic@. Changed 
+    @monoTextWidth@ to take a character count, the old behaviour 
+    is recreated by the new function @monoTextLength@. 
+  .
+  * @Basic.Graphic.Chain@ removed. It is now superseded by
+    @Basic.Chains@.
+  .
+  * Added new property to @DrawingContext@ for line spacing 
+    scaling factor, and added a new drawing primitive 
+    @textlineMulti@ for multi-line, left justified labels.
+  .
+  * Synthezied attribute /getters/ such as @textDimensions@ moved
+    from @Basic.Graphic.DrawingContext@ to the new module
+    @Basic.Graphic.Query@. The type of all the functions has 
+    changed to DrawingF. @lowerxHeight@ is renamed 
+    @monoLowerxHeight@ emphasizing that the metrics pertain to
+    monospaced Courier font.
+  .
+  * Added Shapes modules.
+  . 
+  * TurtleMonad module - the TurtleDrawing type and run functions
+    have been removed and the internals have been reworked. 
+    Turtle is now run solely as a /local effect/ within the 
+    Drawing monad. 
+  .
   0.7.0 to 0.8.0:
   .
   * Re-introduced LRText and LRSymbol - they now work with 
@@ -53,23 +84,29 @@
   CHANGES,
   LICENSE,
   demo/DotPic.hs,
+  demo/ClipPic.hs,
   demo/ColourCharts.hs,
   demo/ColourDefns.hs,
   demo/FontPic.hs,
-  demo/Picture.hs
+  demo/Picture.hs,
+  demo/Shapes.hs,
+  demo/Symbols.hs
 
 library
   hs-source-dirs:     src
   build-depends:      base            <  5, 
                       containers      >= 0.3     && <= 0.4, 
                       vector-space    >= 0.6,
-                      wumpus-core     == 0.33.0
+                      wumpus-core     == 0.34.0
 
   
   exposed-modules:
     Wumpus.Basic.Anchors,
     Wumpus.Basic.Arrows,
     Wumpus.Basic.Arrows.Tips,
+    Wumpus.Basic.Chains,
+    Wumpus.Basic.Chains.Base,
+    Wumpus.Basic.Chains.Derived,
     Wumpus.Basic.Colour.SVGColours,
     Wumpus.Basic.Colour.X11Colours,
     Wumpus.Basic.Dots,
@@ -77,16 +114,20 @@
     Wumpus.Basic.Graphic,
     Wumpus.Basic.Graphic.BaseClasses,
     Wumpus.Basic.Graphic.BaseTypes,
-    Wumpus.Basic.Graphic.Chain,
     Wumpus.Basic.Graphic.Drawing,
     Wumpus.Basic.Graphic.DrawingContext,
     Wumpus.Basic.Graphic.PrimGraphic,
+    Wumpus.Basic.Graphic.Query,
+    Wumpus.Basic.Graphic.ScalingContext,
     Wumpus.Basic.Monads.TurtleClass,
     Wumpus.Basic.Monads.TurtleMonad,
     Wumpus.Basic.Paths,
     Wumpus.Basic.Paths.Base,
+    Wumpus.Basic.Paths.Connectors,
     Wumpus.Basic.Paths.Construction,
     Wumpus.Basic.SafeFonts,
+    Wumpus.Basic.Shapes.Base,
+    Wumpus.Basic.Shapes.Derived,
     Wumpus.Basic.Text.LRSymbol,
     Wumpus.Basic.Text.LRText,
     Wumpus.Basic.Utils.HList,