diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs
--- a/demo/ColourCharts.hs
+++ b/demo/ColourCharts.hs
@@ -54,7 +54,7 @@
 colourSample (name,rgb) = block `cc` lbl 
   where
     block = filledRectangle rgb  15 10
-    lbl   = text (courier 10) name . (.+^ hvec 18)
+    lbl   = textline (courier 10) name . (.+^ hvec 18)
 
 
 
diff --git a/demo/DotPic.hs b/demo/DotPic.hs
new file mode 100644
--- /dev/null
+++ b/demo/DotPic.hs
@@ -0,0 +1,82 @@
+{-# OPTIONS -Wall #-}
+
+module DotPic where
+
+
+import Wumpus.Basic.Dots
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Graphic.DrawingAttr
+import Wumpus.Basic.SVGColours
+import Wumpus.Basic.Utils.HList
+import Wumpus.Deprecated.PictureLanguage
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import System.Directory
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    demo01
+
+pt2 :: Point2 Double
+pt2 = P2 100 10
+
+
+demo01 :: IO ()
+demo01 = do 
+    writeEPS_latin1 "./out/dots01.eps" pic
+    writeSVG_latin1 "./out/dots01.svg" pic
+  where 
+    pic :: Picture Double
+    pic = extendBoundary 10 10 $ 
+          uniformScale 2       $ 
+            vsepA VLeft 10 p1 [p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14
+                              ,p15,p16,p17]
+    
+    p1  = makeDotPic dotHLine       points
+    p2  = makeDotPic dotVLine       points
+    p3  = makeDotPic dotX           points
+    p4  = makeDotPic dotPlus        points   
+    p5  = makeDotPic dotCross       points
+    p6  = makeDotPic dotDiamond     points
+    p7  = makeDotPic dotDisk        points
+    p8  = makeDotPic dotSquare      points
+    p9  = makeDotPic dotCircle      points
+    p10 = makeDotPic dotPentagon    points
+    p11 = makeDotPic dotStar        points
+    p12 = makeDotPic dotAsterisk    points
+    p13 = makeDotPic dotOPlus       points
+    p14 = makeDotPic dotOCross      points
+    p15 = makeDotPic dotFOCross     points
+    p16 = makeDotPic dotFDiamond    points
+    p17 = makeDotPic (dotText "AA") points
+ 
+std_attr :: DrawingAttr
+std_attr = standardAttr 12
+
+points :: [Point2 Double]
+points = [P2 0 0, P2 32 10, P2 64 0, P2 96 10]
+
+makeDotPic :: (Real u, Floating u) 
+           => (DrawingAttr -> GraphicF u) -> [Point2 u] -> Picture u
+makeDotPic fn xs = drawGraphicU $ veloH (fn std_attr) xs . dashline
+  where
+    dashline = wrapG $ ostroke attr $ vertexPath xs
+    attr     = (cadetBlue, DashPattern $ evenDashes 1)
+
+
+errK :: a
+errK = error "no picture"
+
+
+
+-- Should these produce a DashPattern or a StrokeAttr?
+
+evenDashes :: Int -> DashPattern 
+evenDashes n = Dash 0 [(n,n)]
+
+dashOffset :: Int -> DashPattern -> DashPattern
+dashOffset _ Solid       = Solid
+dashOffset n (Dash _ xs) = Dash n xs
+
diff --git a/demo/FontPic.hs b/demo/FontPic.hs
--- a/demo/FontPic.hs
+++ b/demo/FontPic.hs
@@ -2,13 +2,14 @@
 
 module FontPic where
 
-import Wumpus.Core
-import Wumpus.Extra.PictureLanguage
 import Wumpus.Basic.SafeFonts
 import Wumpus.Basic.SVGColours ( steelBlue )
 import Wumpus.Basic.X11Colours ( indianRed1 )
+import Wumpus.Deprecated.PictureLanguage
 
-import Data.AffineSpace
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
 import Data.VectorSpace
 
 import Data.List ( unfoldr )
diff --git a/demo/Picture.hs b/demo/Picture.hs
new file mode 100644
--- /dev/null
+++ b/demo/Picture.hs
@@ -0,0 +1,207 @@
+{-# OPTIONS -Wall #-}
+
+module Picture where
+
+import Wumpus.Core
+import Wumpus.Deprecated.PictureLanguage
+
+import System.Directory
+
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    sequence_  [ demo01, demo02, demo03, demo04, demo05
+               , demo06, demo07, demo08, demo09, demo10
+               , demo11, demo12, demo13, demo14 ]
+
+peru :: PSRgb
+peru = RGB3 0.804  0.522  0.247
+
+plum :: PSRgb
+plum = RGB3 0.867  0.627  0.867
+
+black :: PSRgb
+black = RGB3 0 0 0 
+
+
+square :: DPicture 
+square = frame $ cstroke () $ vertexPath
+  [ P2 0 0, P2 40 0, P2 40 40, P2 0 40 ]
+
+funnyshape :: DPicture
+funnyshape = frame $ cstroke () $ vertexPath
+  [ P2 0 0, P2 20 0, P2 20 10, P2 30 10, P2 30 20, P2 0 20 ]
+
+
+demo01 :: IO ()
+demo01 = do 
+  writePS_latin1  "./out/picture01.ps"    [funnyshape ->- square]
+  writeSVG_latin1 "./out/picture01.svg" $ funnyshape ->- square
+
+
+pic1 :: Picture Double
+pic1 = square ->- (funnyshape ->- funnyshape) ->- square
+
+squares :: Picture Double
+squares = square ->- square ->- square
+
+demo02 :: IO ()
+demo02 = do 
+   writePS_latin1  "./out/picture02.ps"  [squares]
+   writeSVG_latin1 "./out/picture02.svg" squares 
+    
+
+demo03 :: IO ()
+demo03 = do 
+    writeEPS_latin1 "./out/picture03.eps" p1 
+    writeSVG_latin1 "./out/picture03.svg" p1
+  where     
+    p1 = square ->- (rotate45About (center squares) squares) ->- square
+
+
+demo04 :: IO ()
+demo04 = do 
+    writeEPS_latin1 "./out/picture04.eps" p1
+    writeSVG_latin1 "./out/picture04.svg" p1
+  where
+    p1 = square -//- squares
+   
+
+demo05 :: IO ()
+demo05 = do 
+    writeEPS_latin1 "./out/picture05.eps" p1
+    writeSVG_latin1 "./out/picture05.svg" p1
+  where
+    p1 = square `over` (rotate (pi/4) squares)
+   
+
+demo06 :: IO ()
+demo06 = do 
+    writeEPS_latin1 "./out/picture06.eps" p1
+    writeSVG_latin1 "./out/picture06.svg" p1
+  where
+    p1 = square `over` (rotate45 square)
+
+
+-- Note the move via @at@ is not apparent when SVG file is 
+-- viewed with Mozilla or Chrome - check picture7a.svg
+-- We only see that the move has /worked/ when we compose
+-- with with `over` a square at the origin. 
+
+demo07 :: IO ()
+demo07 = do 
+    writeEPS_latin1 "./out/picture07.eps" p1
+    writeSVG_latin1 "./out/picture07.svg" p1
+    writeSVG_latin1 "./out/picture07a.svg" p2
+  where
+    p1 = square `over` p2
+    p2 = (square `at` (P2 100 30))  -@- (rotate45 square)
+
+
+demo08 :: IO ()
+demo08 = do 
+    writeEPS_latin1 "./out/picture08.eps" p1
+    writeSVG_latin1 "./out/picture08.svg" p1
+  where
+    p1 = hspace 20 square square
+
+mkFilledSquare :: (PSColour c, Fill c) => c -> Double -> DPicture 
+mkFilledSquare col n = frame $ fill col $ vertexPath
+  [ P2 0 0, P2 n 0, P2 n n, P2 0 n ]
+
+
+demo09 :: IO ()
+demo09 = do 
+    writeEPS_latin1 "./out/picture09.eps" p1
+    writeSVG_latin1 "./out/picture09.svg" p1
+  where
+    p1 = (alignH HTop s1 s2) `op` s3
+    s1 = uniformScale 1.5  $ mkFilledSquare plum 40
+    s2 = uniformScale 1.75 $ mkFilledSquare peru 40
+    s3 = scale 3 1.5       $ mkFilledSquare black 40
+    op = alignH HBottom
+ 
+
+demo10 :: IO ()
+demo10 = do 
+    writeEPS_latin1 "./out/picture10.eps" p1
+    writeSVG_latin1 "./out/picture10.svg" p1
+  where
+    p1 = vsepA VRight 5 s1 [s2,s3]
+    s1 = uniformScale 1.5  $ mkFilledSquare plum 40
+    s2 = uniformScale 1.75 $ mkFilledSquare peru 40
+    s3 = scale 3 1.5       $ mkFilledSquare black 40
+ 
+
+
+-- Stroked ellipe problem under scaling...
+demo11 :: IO ()
+demo11 = do 
+    writeEPS_latin1 "./out/picture11.eps" pic
+    writeSVG_latin1 "./out/picture11.svg" pic
+  where
+    pic :: Picture Double
+    pic = p1 -//- p2
+    p1 = scale 6 12 $ frame $ ellipse (plum, LineWidth 2) 4 6 zeroPt
+    p2 = scale 6 12 $ frame $ ellipse (peru, LineWidth 2) 6 6 zeroPt
+
+
+-- Note the movement of the plum square won't be regarded by 
+-- Firefox as it crops whitespace automatically.
+demo12 :: IO ()
+demo12 = do 
+    writeEPS_latin1 "./out/picture12.eps" pic
+    writeSVG_latin1 "./out/picture12.svg" pic
+  where
+    pic :: Picture Double
+    pic = p1 -//- p2 -//- p3 -//- p4
+    p1 = small_black -@- large_plum     -- moves black
+    p2 = large_plum  -@- small_black    -- moves plum
+    p3 = small_black ->- large_plum     -- moves plum
+    p4 = small_black -<- large_plum     -- moves black
+
+    small_black = mkFilledSquare black 10 `at` P2 30 0
+    large_plum  = mkFilledSquare plum  40 `at` P2 100 0
+
+
+demo13 :: IO ()
+demo13 = do 
+    writeEPS_latin1 "./out/picture13.eps" pic
+    writeSVG_latin1 "./out/picture13.svg" pic
+  where
+    pic :: Picture Double
+    pic = (p1 `at` P2 20 20) ->- (p2 `at` P2 60 20) 
+
+    p1 = small_black `below` small_peru   -- moves small black
+    p2 = small_black `above` small_plum   -- moves small black
+
+    small_black = mkFilledSquare black 10 `at` P2 50 0
+    small_plum  = mkFilledSquare plum  10 `at` P2 50 0
+    small_peru  = mkFilledSquare peru  10 `at` P2 50 0
+
+demo14 :: IO ()
+demo14 = do 
+    writeEPS_latin1 "./out/picture14.eps" pic
+    writeSVG_latin1 "./out/picture14.svg" pic
+  where
+    pic :: Picture Double
+    pic = hsep 40 p1 [p2,p3,p4,p5,p6]
+
+    p1 = alignH HTop    small_black mid_peru
+    p2 = alignH HBottom small_black mid_plum
+    p3 = alignH HCenter small_black mid_peru
+
+    p4 = alignV VLeft   mid_black small_peru
+    p5 = alignV VRight  mid_black small_plum
+    p6 = alignV VCenter mid_black small_peru
+
+    small_black = mkFilledSquare black 10 `at` P2 10 0
+    mid_plum    = mkFilledSquare plum  25 `at` P2 50 0
+    mid_peru    = mkFilledSquare peru  25 `at` P2 50 0
+
+    mid_black   = mkFilledSquare black 25 `at` P2 10 10
+    small_plum  = mkFilledSquare plum  10 `at` P2 10 50
+    small_peru  = mkFilledSquare peru  10 `at` P2 10 50
+
+
diff --git a/src/Wumpus/Basic/AnchorDots.hs b/src/Wumpus/Basic/AnchorDots.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/AnchorDots.hs
@@ -0,0 +1,178 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.AnchorDots
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC with TypeFamilies, GADTs and more
+--
+-- Dots with anchors.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.AnchorDots
+  ( 
+
+  -- * Existential anchor type
+    DotAnchor
+
+  -- * Dots with anchor points
+  , dotCircle
+  , dotDisk
+  , dotSquare
+  , dotChar
+  , dotText
+
+  ) where
+
+import Wumpus.Basic.Anchors
+import qualified Wumpus.Basic.Dots              as BD
+import Wumpus.Basic.Monads.Drawing
+import Wumpus.Basic.Monads.DrawingCtxClass
+import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Utils.Intersection
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+
+-- An existential thing that supports anchors.
+-- This means any dot can retun the same (opaque) structure
+--
+-- But it does mean that which anchor class are supported is 
+-- fixed - the datatype needs a field for each one.
+-- Supporting north, southeast etc. will also be tedious...
+--
+data DotAnchor u = forall s.  
+                    DotAnchor { center_anchor   :: Point2 u
+                              , radial_anchor   :: Radian   -> Point2 u
+                              , cardinal_anchor :: Cardinal -> Point2 u }
+
+data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW
+  deriving (Eq,Show) 
+
+type instance DUnit (DotAnchor u) = u
+
+instance CenterAnchor (DotAnchor u) where
+  center (DotAnchor ca _ _) = ca
+
+instance RadialAnchor (DotAnchor u) where
+   radialAnchor theta (DotAnchor _ ra _) = ra theta
+
+instance CardinalAnchor (DotAnchor u) where
+   north (DotAnchor _ _ c1) = c1 NN
+   south (DotAnchor _ _ c1) = c1 SS
+   east  (DotAnchor _ _ c1) = c1 EE
+   west  (DotAnchor _ _ c1) = c1 WW
+
+
+
+instance CardinalAnchor2 (DotAnchor u) where
+   northeast (DotAnchor _ _ c1) = c1 NE
+   southeast (DotAnchor _ _ c1) = c1 SE
+   southwest (DotAnchor _ _ c1) = c1 SW
+   northwest (DotAnchor _ _ c1) = c1 NW
+
+
+circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u
+circleAnchor rad ctr = DotAnchor ctr 
+                                 (\theta -> ctr .+^ (avec theta rad))
+                                 (radialCardinal rad ctr)
+
+
+
+
+radialCardinal :: Floating u => u -> Point2 u ->  Cardinal -> Point2 u
+radialCardinal rad ctr NN = ctr .+^ (avec (pi/2)     rad) 
+radialCardinal rad ctr NE = ctr .+^ (avec (pi/4)     rad) 
+radialCardinal rad ctr EE = ctr .+^ (avec  0         rad) 
+radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) 
+radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) 
+radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) 
+radialCardinal rad ctr WW = ctr .+^ (avec  pi        rad) 
+radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad) 
+
+
+-- Rectangle cardinal points are at \"middles and corners\".
+--
+
+rectCardinal :: Floating u => u ->  u -> Point2 u -> Cardinal -> Point2 u
+rectCardinal _  hh ctr NN = ctr .+^ (vvec hh) 
+rectCardinal hw hh ctr NE = ctr .+^ (vec  hw     hh) 
+rectCardinal hw _  ctr EE = ctr .+^ (hvec hw) 
+rectCardinal hw hh ctr SE = ctr .+^ (vec  hw    (-hh)) 
+rectCardinal _  hh ctr SS = ctr .+^ (vvec (-hh)) 
+rectCardinal hw hh ctr SW = ctr .+^ (vec  (-hw) (-hh) )
+rectCardinal hw _  ctr WW = ctr .+^ (hvec (-hw)) 
+rectCardinal hw hh ctr NW = ctr .+^ (vec  (-hw)  hh) 
+
+
+rectangleAnchor :: (Real u, Floating u) =>  u -> u -> Point2 u -> DotAnchor u
+rectangleAnchor hw hh ctr = 
+    DotAnchor { center_anchor   = ctr
+              , radial_anchor   = fn  
+              , cardinal_anchor = rectCardinal hw hh ctr }
+  where
+    fn theta =  maybe ctr id $ findIntersect ctr theta 
+                             $ rectangleLines ctr hw hh
+
+
+
+
+-- This draws to the trace then returns an opaque thing
+-- (a Circle) that supports anchors
+
+dotCircle :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m
+             , Floating u) 
+          => MGraphicF m u (DotAnchor u)
+dotCircle = \pt -> askDrawingCtx                    >>= \attr -> 
+                   markHeight                       >>= \h    ->
+                   trace (BD.dotCircle attr pt)     >> 
+                   return (circleAnchor (0.5*h) pt)
+
+
+dotDisk :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m
+           , Floating u) 
+        => MGraphicF m u (DotAnchor u)
+dotDisk = \pt -> askDrawingCtx                    >>= \attr -> 
+                 markHeight                       >>= \h    ->
+                 trace (BD.dotDisk attr pt)       >> 
+                 return (circleAnchor (0.5*h) pt)
+
+
+
+dotSquare :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m
+             , Real u, Floating u) 
+          => MGraphicF m u (DotAnchor u)
+dotSquare = \pt -> askDrawingCtx                >>= \attr -> 
+                   markHeight                   >>= \h    ->
+                   trace (BD.dotSquare attr pt) >> 
+                   return (rectangleAnchor (0.5*h) (0.5*h) pt)
+
+
+
+
+
+dotChar :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m
+           , Real u, Floating u) 
+          => Char -> MGraphicF m u (DotAnchor u)
+dotChar ch = dotText [ch]
+
+dotText :: ( Monad m, TraceM m (Primitive u), DrawingCtxM m
+           , Real u, Floating u) 
+          => String -> MGraphicF m u (DotAnchor u)
+dotText str = \pt -> askDrawingCtx                  >>= \attr  -> 
+                     textDimensions str             >>= \(w,h) ->
+                     trace (BD.dotText str attr pt) >>
+                     return (rectangleAnchor (0.5*w) (0.5*h) pt)
+
+
diff --git a/src/Wumpus/Basic/Anchors.hs b/src/Wumpus/Basic/Anchors.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Anchors.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Anchors
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC with TypeFamilies and more
+--
+-- Anchor points on \"shapes\".
+--
+-- ** WARNING ** this module is highly experimental, and may 
+-- change significantly or even be dropped from future revisions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Anchors
+  ( 
+
+  -- * Anchors
+    CenterAnchor(..)
+  , CardinalAnchor(..)
+  , CardinalAnchor2(..)
+  , TextAnchor(..)
+  , RadialAnchor(..)
+
+  ) where
+
+import Wumpus.Core                      -- package: wumpus-core
+
+
+class CenterAnchor t where
+  center :: DUnit t ~ u => t -> Point2 u
+
+-- Note - in TikZ cardinal anchors are not necessarily at the
+-- equivalent radial position, for instance reactangle north-east
+-- is the top-right corner whether or not this is incident at 
+-- 45deg.
+--
+
+class CardinalAnchor t where
+  north :: DUnit t ~ u => t -> Point2 u
+  south :: DUnit t ~ u => t -> Point2 u
+  east  :: DUnit t ~ u => t -> Point2 u
+  west  :: DUnit t ~ u => t -> Point2 u
+
+class CardinalAnchor2 t where
+  northeast :: DUnit t ~ u => t -> Point2 u
+  southeast :: DUnit t ~ u => t -> Point2 u
+  southwest :: DUnit t ~ u => t -> Point2 u
+  northwest :: DUnit t ~ u => t -> Point2 u
+
+-- | 'textAnchor' is the Bottom left corner 
+-- on the baseline.
+--
+class TextAnchor t where
+  textAnchor :: DUnit t ~ u => t -> Point2 u
+
+
+-- | Anchor on a border that can be identified with and angle.
+--
+class RadialAnchor t where
+  radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u
+
diff --git a/src/Wumpus/Basic/Dots.hs b/src/Wumpus/Basic/Dots.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Dots.hs
@@ -0,0 +1,201 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Dots
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC with TypeFamilies and more
+--
+-- Dots
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Dots
+  ( 
+
+
+  -- * Dots
+    dotChar
+  , dotText
+  , dotHLine
+  , dotVLine
+  , dotX
+  , dotPlus
+  , dotCross
+  , dotDiamond
+  , dotFDiamond
+  , dotDisk
+  , dotSquare
+  , dotCircle
+  , dotPentagon
+  , dotStar
+  , dotAsterisk
+  , dotOPlus
+  , dotOCross
+  , dotFOCross
+
+  ) where
+
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Graphic.DrawingAttr
+import Wumpus.Basic.Graphic.PointSupply
+import Wumpus.Basic.Utils.HList
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import Data.AffineSpace                 -- package: vector-space
+import Data.VectorSpace
+
+-- Marks should be the height of a lower-case letter...
+
+-- NOTES
+--
+-- Affine transforming Points, LineSegments etc. before
+-- they become pictures is _GOOD_! The calculations are done in 
+-- Wumpus and so don't cause extra (gsave... grestore) in 
+-- PostScript.
+--
+
+dotChar :: Fractional u => Char -> DrawingAttr -> GraphicF u
+dotChar ch = dotText [ch]
+
+dotText :: Fractional u => String -> DrawingAttr -> GraphicF u
+dotText str attr = \ctr -> let pt = disp (-hw) (-hh) ctr in
+    wrapG $ textlabel (textAttr attr) str pt
+  where
+    sz = font_size $ font_props attr
+    hh = 0.5 * numeralHeight sz
+    hw = 0.5 * textWidth sz (length str) 
+
+-- | Supplied point is the center.
+--
+axialLine :: (Stroke t, Fractional u) => t -> Vec2 u -> GraphicF u
+axialLine t v = \ctr -> let pt = ctr .-^ (0.5 *^ v) in
+    wrapG $ ostroke t $ path pt [lineTo $ pt .+^ v]
+ 
+
+
+
+
+-- Better would be a version of straightLine where the point is 
+-- the center not the start...
+-- 
+dotHLine :: Fractional u => DrawingAttr -> GraphicF u 
+dotHLine attr = let w = markHeight attr in 
+    axialLine (strokeAttr attr) (hvec w)
+    
+
+dotVLine :: Fractional u => DrawingAttr -> GraphicF u 
+dotVLine attr = let h = markHeight attr in 
+    axialLine (strokeAttr attr) (vvec h)
+
+
+dotX :: Fractional u => DrawingAttr -> GraphicF u
+dotX attr = ls1 `cc` ls2
+  where
+    h        = markHeight attr
+    w        = 0.75 * h
+    ls1      = axialLine (strokeAttr attr) (vec w    h)
+    ls2      = axialLine (strokeAttr attr) (vec (-w) h)
+
+
+dotPlus :: Fractional u => DrawingAttr -> GraphicF u
+dotPlus attr = dotVLine attr `cc` dotHLine attr
+
+
+dotCross :: Floating u => DrawingAttr -> GraphicF u
+dotCross attr = ls1 `cc` ls2
+  where
+    z        = markHeight attr
+    ls1      = axialLine (strokeAttr attr) (avec (pi*0.25)    z)
+    ls2      = axialLine (strokeAttr attr) (avec (negate $ pi*0.25) z)
+
+
+-- needs horizontal pinch...
+
+pathDiamond :: Fractional u => DrawingAttr -> PathF u
+pathDiamond attr = vertexPath . sequence [dvs,dve,dvn,dvw]
+  where
+    hh    = 0.66  * markHeight attr
+    hw    = 0.5   * markHeight attr
+    dvs   = (.+^ vvec (-hh))
+    dve   = (.+^ hvec hw)
+    dvn   = (.+^ vvec hh)
+    dvw   = (.+^ hvec (-hw))
+
+type PathF u = Point2 u -> Path u
+
+dotDiamond :: Fractional u => DrawingAttr -> GraphicF u
+dotDiamond attr = 
+    wrapG . cstroke (strokeAttr attr) . pathDiamond attr
+
+dotFDiamond :: Fractional u => DrawingAttr -> GraphicF u
+dotFDiamond attr = dotDiamond attr `cc` filled 
+  where
+    filled = wrapG . fill (fillAttr attr) . pathDiamond attr
+
+
+
+-- | Note disk is filled.
+--
+dotDisk :: Fractional u => DrawingAttr -> GraphicF u
+dotDisk attr = disk (fill_colour attr) (0.5*markHeight attr) 
+
+
+dotSquare :: Fractional u => DrawingAttr -> GraphicF u
+dotSquare attr = let u = markHeight attr in
+     strokedRectangle (strokeAttr attr) u u 
+    
+
+
+dotCircle :: Fractional u => DrawingAttr -> GraphicF u
+dotCircle attr = disk (strokeAttr attr) (0.5*markHeight attr) 
+
+
+dotPentagon :: Floating u => DrawingAttr -> GraphicF u
+dotPentagon attr = 
+    wrapG . cstroke (strokeAttr attr) . vertexPath . polygonPointsV 5 hh
+  where
+    hh      = 0.5 * markHeight attr
+
+ 
+
+dotStar :: Floating u => DrawingAttr -> GraphicF u 
+dotStar attr = \pt -> veloH (fn pt) $ polygonPointsV 5 hh pt
+  where
+    hh        = 0.5 * markHeight attr
+    fn pt pt' = wrapG $ cstroke (strokeAttr attr) $ path pt [lineTo pt'] 
+
+
+
+
+dotAsterisk :: Floating u => DrawingAttr -> GraphicF u
+dotAsterisk attr = ls1 `cc` ls2 `cc` ls3
+  where
+    z        = markHeight attr
+    props    = strokeAttr attr
+    ang      = two_pi / 6
+    ls1      = axialLine props (vvec z)
+    ls2      = axialLine props (avec (half_pi + ang)    z)
+    ls3      = axialLine props (avec (half_pi + ang + ang) z)
+
+
+dotOPlus :: Fractional u
+         => DrawingAttr -> GraphicF u
+dotOPlus attr = dotCircle attr `cc` dotPlus attr
+
+
+dotOCross :: Floating u => DrawingAttr -> GraphicF u
+dotOCross attr = dotCircle attr `cc` dotCross attr
+
+
+dotFOCross :: Floating u => DrawingAttr -> GraphicF u
+dotFOCross attr = dotCircle attr `cc` dotCross attr `cc` bkCircle attr 
+
+bkCircle :: Fractional u => DrawingAttr -> GraphicF u
+bkCircle attr = disk (fillAttr attr) (0.5*markHeight attr) 
diff --git a/src/Wumpus/Basic/Graphic.hs b/src/Wumpus/Basic/Graphic.hs
--- a/src/Wumpus/Basic/Graphic.hs
+++ b/src/Wumpus/Basic/Graphic.hs
@@ -7,13 +7,14 @@
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
+-- Stability   :  highly unstable
 -- Portability :  GHC 
 --
 -- Graphic type and opertations
 --
--- ** WARNING ** this module is highly experimental, and may 
--- change significantly or even be dropped from future revisions.
+-- \*\* WARNING \*\* - this module is highly experimental, and 
+-- may change significantly or even be dropped from future 
+-- revisions.
 --
 --
 --------------------------------------------------------------------------------
@@ -27,49 +28,89 @@
   , GraphicF
   , DGraphicF
 
-  -- * New Bird..
+  -- * General combinators
   , cc
+  , supply
 
   -- * Operations
   , drawGraphic
+  , drawGraphicU
+
   , wrapG
+  , emptyG 
 
-  , text
+  -- * Graphic primitives
+  , textline
   , straightLine
   , strokedRectangle
   , filledRectangle
-  , circle
+  , rectanglePath
+  , strokedCircle
+  , filledCircle
+  , disk
 
-  ) where
+  -- * Displacement
+  , Point2T
+  , DPoint2T 
+  , positionWith
+  , disp
+  , vdisp
+  , hdisp
 
+  -- * Grid
+  , Rectangle(..)
+  , DRectangle
+  , grid
+  , border
 
+  , RectangleLoc
+  , DRectangleLoc
+  , withinRectangleLoc
 
-import Wumpus.Core                      -- package: wumpus-core
+  ) where
+
+import Wumpus.Basic.Graphic.PointSupply
 import Wumpus.Basic.Utils.HList
 
+import Wumpus.Core                      -- package: wumpus-core
+
 import Data.AffineSpace                 -- package: vector-space
 
+import Data.Maybe
+
+
+
 -- | Note - this representation allows for zero, one or more
 -- Primitives to be collected together.
 --
-type Graphic u = H (Primitive u)
+type Graphic u          = H (Primitive u)
 
-type DGraphic  = Graphic Double
+type DGraphic           = Graphic Double
 
-type GraphicF u = Point2 u -> Graphic u
+type GraphicF u         = Point2 u -> Graphic u
 
-type DGraphicF = GraphicF Double
+type DGraphicF          = GraphicF Double
 
 
 --------------------------------------------------------------------------------
--- Wow a new bird combinator...
+-- Combinators...
 
 infixr 9 `cc`
 
+-- | Composition operator...
+--
+-- > cc f g = \x y -> f x (g x y)
+--
 cc :: (r1 -> a -> ans) -> (r1 -> r2 -> a) -> r1 -> r2 -> ans
 cc f g = \x y -> f x (g x y)
 
 
+-- | Reverse application.
+--
+supply :: u -> (u -> a) -> a 
+supply u f = f u
+
+
 --------------------------------------------------------------------------------
 
 -- | Note - a Picture cannot be empty whereas a Graphic can.
@@ -82,40 +123,167 @@
     post xs = Just $ frameMulti $ xs 
 
 
+-- | /Unsafe/ version of 'drawGraphic' - this function throws 
+-- an error when the graphic is empty.
+--
+drawGraphicU :: (Real u, Floating u) => Graphic u -> Picture u
+drawGraphicU = fromMaybe errK . drawGraphic
+  where
+    errK = error "drawGraphic - empty Graphic."
+
+
 -- | Lift a Primitive to a Graphic
 --
 wrapG :: Primitive u -> Graphic u
 wrapG = wrapH 
 
+-- | The empty graphic.
+--
+emptyG :: Graphic u
+emptyG = emptyH
 
 --------------------------------------------------------------------------------
 
-text :: (TextLabel t, Num u) => t -> String -> GraphicF u
-text t ss = wrapG . textlabel t ss 
+-- | Text should not contain newlines.
+--
+-- Note the supplied point is the \'left-baseline\'.
+--
+textline :: (TextLabel t, Num u) => t -> String -> GraphicF u
+textline t ss = wrapG . textlabel t ss 
 
-straightLine :: (Stroke t, Num u) => t -> Vec2 u -> GraphicF u
-straightLine t v = \pt -> wrapG $ ostroke t $ path pt [lineTo $ pt .+^ v]
 
+-- | Vector is applied to the point.
+--
+straightLine :: (Stroke t, Fractional u) => t -> Vec2 u -> GraphicF u
+straightLine t v = \pt -> wrapG $ ostroke t $ path pt [lineTo $ pt .+^ v]
+ 
 
--- | Point is bottom-left.
+-- | Supplied point is center.
 --
-strokedRectangle :: (Stroke t, Num u) => t -> u -> u -> GraphicF u
+strokedRectangle :: (Stroke t, Fractional u) => t -> u -> u -> GraphicF u
 strokedRectangle t w h = wrapG . cstroke t . rectangle w h
 
--- | Point is bottom-left.
+-- | Supplied point is center.
 --
-filledRectangle :: (Fill t, Num u) => t -> u -> u -> GraphicF u
+filledRectangle :: (Fill t, Fractional u) => t -> u -> u -> GraphicF u
 filledRectangle t w h = wrapG . fill t . rectangle w h
 
+rectangle :: Fractional u => u -> u -> Point2 u -> Path u
+rectangle w h ctr = rectanglePath w h (ctr .-^ vec (0.5*w) (0.5*h))
 
-rectangle :: Num u => u -> u -> Point2 u -> Path u
-rectangle w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]
+-- | Supplied point is /bottom-left/.
+--
+rectanglePath :: Num u => u -> u -> Point2 u -> Path u
+rectanglePath w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]
   where
     br = bl .+^ hvec w
     tr = br .+^ vvec h
     tl = bl .+^ vvec h 
 
 
+-- | 'strokedCircle' : @ stroked_props * num_subs * radius -> GraphicF @
+--
+-- Draw a stroked circle made from Bezier curves. @num_subs@ is 
+-- the number of subdivisions per quadrant.
+--
+-- The result is a HOF (GraphicF :: Point -> Graphic) where the 
+-- point is the center. 
+-- 
+strokedCircle :: (Stroke t, Floating u) => t -> Int -> u -> GraphicF u
+strokedCircle t n r = wrapG . cstroke t . curvedPath . bezierCircle n r
 
-circle :: (Ellipse t, Fractional u) => t -> u -> GraphicF u
-circle t radius = wrapG . ellipse t radius radius 
+
+-- | 'filledCircle' : @ fill_props * num_subs * radius -> GraphicF @
+--
+-- Draw a filled circle made from Bezier curves. @num_subs@ is 
+-- the number of subdivisions per quadrant.
+--
+-- The result is a HOF (GraphicF :: Point -> Graphic) where the 
+-- point is the center. 
+--
+filledCircle :: (Fill t, Floating u) => t -> Int -> u -> GraphicF u
+filledCircle t n r = wrapG . fill t . curvedPath . bezierCircle n r
+
+
+
+-- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive.
+--
+-- This is a efficient representation of circles using 
+-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
+-- output. However, stroked-circles do not draw well after 
+-- non-uniform scaling - the line width is scaled as well as 
+-- the shape.
+--
+-- For stroked circles that can be scaled, consider making the 
+-- circle from Bezier curves.
+--
+disk :: (Ellipse t, Fractional u) => t -> u -> GraphicF u
+disk t radius = wrapG . ellipse t radius radius 
+
+
+--------------------------------------------------------------------------------
+-- Transforming points...
+
+
+type Point2T    u = Point2 u -> Point2 u
+
+type DPoint2T     = Point2T Double
+
+positionWith :: Point2T u -> (Point2 u -> a) -> (Point2 u -> a)
+positionWith displacer gf  = gf . displacer 
+
+
+disp :: Num u => u -> u -> Point2T u
+disp x y = (.+^ V2 x y)
+
+hdisp :: Num u => u -> Point2T u
+hdisp x = disp x 0
+
+vdisp :: Num u => u -> Point2T u
+vdisp y = disp 0 y
+
+--------------------------------------------------------------------------------
+-- need a border / frame abstraction...
+
+data Rectangle u = Rectangle 
+      { rect_width     :: !u
+      , rect_height    :: !u 
+      }  
+  deriving (Eq,Ord,Show)
+
+type DRectangle = Rectangle Double
+
+-- | 'grid' : @ stroke_props * xstep * ystep * boundary_rect -> GraphicF @
+--
+-- The result is a HOF (GraphicF :: Point -> Graphic) where the 
+-- point is bottom-left. 
+--
+grid :: (Stroke t, RealFrac u) => t -> u -> u -> Rectangle u -> GraphicF u 
+grid t xstep ystep (Rectangle w h) = \pt ->
+    vlines pt . hlines pt
+  where
+    vlines (P2 x y) = veloH (straightLine t (vvec h)) $ hpoints y xstep (x,x+w)
+    hlines (P2 x y) = veloH (straightLine t (hvec w)) $ vpoints x ystep (y,y+h)
+    
+
+-- | 'border' : @ stroke_props * boundary_rect -> GraphicF @
+--
+-- The result is a HOF (GraphicF :: Point -> Graphic) where the 
+-- point is bottom-left. 
+--
+border :: (Stroke t, Num u) => t -> Rectangle u -> GraphicF u
+border t (Rectangle w h) = wrapG . cstroke t . rectanglePath w h
+
+
+
+type RectangleLoc u = (Rectangle u, Point2 u)
+
+type DRectangleLoc = RectangleLoc Double
+
+
+withinRectangleLoc :: (Num u, Ord u) => Point2 u -> RectangleLoc u -> Bool
+withinRectangleLoc (P2 x y) (Rectangle w h, P2 ox oy) = 
+   ox <= x && x <= (ox+w) && oy <= y && y <= (oy+h)
+
+
+
diff --git a/src/Wumpus/Basic/Graphic/DrawingAttr.hs b/src/Wumpus/Basic/Graphic/DrawingAttr.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Graphic/DrawingAttr.hs
@@ -0,0 +1,79 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.DrawingAttr
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC with TypeFamilies and more
+--
+-- Drawing attributes
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Graphic.DrawingAttr
+  ( 
+
+  -- * Drawing attributes
+    DrawingAttr(..)
+
+  , standardAttr
+  , strokeAttr   
+  , fillAttr
+  , textAttr
+  , markHeight
+
+  , textDimensions
+
+  ) where
+
+
+import Wumpus.Basic.SafeFonts
+import Wumpus.Basic.SVGColours
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import Control.Applicative
+
+data DrawingAttr = DrawingAttr 
+      { line_width         :: Double
+      , font_props         :: FontAttr
+      , stroke_colour      :: DRGB
+      , fill_colour        :: DRGB
+      }
+  deriving (Eq,Show)
+
+standardAttr :: FontSize -> DrawingAttr
+standardAttr sz = DrawingAttr { line_width         = 1.0
+                              , font_props         = courier sz
+                              , stroke_colour      = black
+                              , fill_colour        = gold  }
+
+ 
+strokeAttr :: DrawingAttr -> (DRGB, StrokeAttr)
+strokeAttr = liftA2 (,) stroke_colour (LineWidth . line_width)
+
+fillAttr :: DrawingAttr -> DRGB
+fillAttr = fill_colour
+
+textAttr :: DrawingAttr -> (DRGB,FontAttr)
+textAttr = liftA2 (,) stroke_colour font_props
+
+-- | A Mark is consider to be the height of a lowercase letter
+-- in the current font.
+--
+markHeight :: Fractional u => DrawingAttr -> u
+markHeight = xcharHeight . font_size . font_props
+
+
+-- | textDimensions : text -> DrawingAttr -> (width,height)
+--
+textDimensions :: Fractional u => String -> DrawingAttr -> (u,u)
+textDimensions str attr = (w,h)
+  where
+    sz = font_size  $ font_props attr
+    w  = textWidth  sz (1 + length str) 
+    h  = textHeight sz
diff --git a/src/Wumpus/Basic/Graphic/PointSupply.hs b/src/Wumpus/Basic/Graphic/PointSupply.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Graphic/PointSupply.hs
@@ -0,0 +1,109 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Graphic.PointSupply
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- 
+-- \*\* WARNING \*\* - function names likely to change.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Graphic.PointSupply
+  (
+    -- * Constants (might move from this module)
+    two_pi
+  , half_pi
+  
+  -- * Generate points.
+  , polygonPointsV
+  , hpoints
+  , vpoints
+  
+  ) where
+  
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import Data.AffineSpace                 -- package: vector-space
+
+import Data.List
+
+two_pi :: Radian
+two_pi = 2.0 * pi
+
+half_pi :: Radian
+half_pi = 0.5 * pi
+
+
+-- | 'polygonPointsV' : @ num_points * radius * center -> [point] @ 
+--
+polygonPointsV :: Floating u => Int -> u -> Point2 u -> [Point2 u]
+polygonPointsV n radius = sequence vecs
+  where
+    theta = two_pi / fromIntegral n
+    vecs  = unfoldr phi (0,half_pi)
+    
+    phi (i,ang) | i < n     = Just ((.+^ avec ang radius), (i+1,ang+theta))
+                | otherwise = Nothing
+
+
+   
+-- | 'hpoints' : @ ypos * step * (x0,x1) -> [point] @
+-- 
+-- Generate points in a horizontal line between x0 and x1.
+--
+-- Note - the step increment is w.r.t. 0 rather than x0. x0 and 
+-- x1 are just the range. An example:
+-- 
+-- > hpoints 0 10 (5,35)
+--
+-- > [P2 10 0, P2 20 0, P2 30 0]
+--
+hpoints :: RealFrac u => u -> u -> (u,u) -> [Point2 u]
+hpoints y step (x0,x1) = unfoldr phi start
+  where
+    start              = initial step x0
+    phi st | st < x1   = Just (P2 st y, st+step)  
+           | otherwise = Nothing
+
+
+-- | 'vpoints' : @ xpos * step * (y0,y1) -> [point] @
+-- 
+-- Generate points in a vertical line between y0 and y1.
+--
+-- Note - the step increment is w.r.t. 0 rather than y0. y0 and 
+-- y1 are just the range. An example:
+-- 
+-- > vpoints 5 100 (50,500)
+--
+-- > [P2 5 100, P2 5 200, P2 5 300, P2 5 400]
+--
+vpoints :: RealFrac u => u -> u -> (u,u) -> [Point2 u]
+vpoints x step (y0,y1) = unfoldr phi start
+  where
+    start              = initial step y0
+    phi st | st < y1   = Just (P2 x st, st+step)  
+           | otherwise = Nothing
+
+
+
+initial :: RealFrac a => a -> a -> a 
+initial step minval = step * (fn $ minval / step)
+  where
+    fn x | x < 0     = fromIntegral $ ceilingi x
+         | otherwise = fromIntegral $ 1 + floori x
+
+
+
+ceilingi  :: RealFrac a => a -> Integer
+ceilingi  = ceiling
+
+floori    :: RealFrac a => a -> Integer
+floori    = floor
diff --git a/src/Wumpus/Basic/Monads/ConsDrawing.hs b/src/Wumpus/Basic/Monads/ConsDrawing.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/ConsDrawing.hs
@@ -0,0 +1,178 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.ConsDrawing
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Trace plus DrawingCtx plus Turtle...
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.ConsDrawing
+  (
+    ConsDrawing
+  , ConsDrawingT
+
+  , runConsDrawing
+  , runConsDrawingT
+  , execConsDrawing
+  , execConsDrawingT
+
+  -- * Re-exports
+  , module Wumpus.Basic.Monads.Drawing
+  , module Wumpus.Basic.Monads.DrawingCtxClass
+  , module Wumpus.Basic.Monads.TraceClass
+  , module Wumpus.Basic.Monads.TurtleClass 
+
+  ) where
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Monads.Drawing
+import Wumpus.Basic.Monads.DrawingCtxClass
+import Wumpus.Basic.Monads.DrawingCtxMonad
+import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Monads.TraceMonad
+import Wumpus.Basic.Monads.TurtleClass
+import Wumpus.Basic.Monads.TurtleMonad
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import MonadLib ( MonadT(..) )          -- package: monadLib
+
+import Control.Applicative
+import Control.Monad
+
+
+newtype ConsDrawing u a = ConsDrawing { 
+          getConsDrawing  :: TurtleT          u
+                           ( DrawingCtxT
+                           ( Trace (Primitive u))) a }
+
+newtype ConsDrawingT u m a = ConsDrawingT { 
+          getConsDrawingT :: TurtleT           u
+                           ( DrawingCtxT
+                           ( TraceT (Primitive u) m)) a }
+
+
+-- Functor
+
+instance Functor (ConsDrawing u) where
+  fmap f = ConsDrawing . fmap f . getConsDrawing
+
+instance Monad m => Functor (ConsDrawingT u m) where
+  fmap f = ConsDrawingT . fmap f . getConsDrawingT
+
+
+-- Applicative 
+instance Applicative (ConsDrawing u) where
+  pure a    = ConsDrawing $ pure a
+  mf <*> ma = ConsDrawing $ getConsDrawing mf <*> getConsDrawing ma
+                   
+
+
+instance Monad m => Applicative (ConsDrawingT u m) where
+  pure a    = ConsDrawingT $ pure a
+  mf <*> ma = ConsDrawingT $ getConsDrawingT mf <*> getConsDrawingT ma
+
+
+-- Monad 
+
+instance Monad (ConsDrawing u) where
+  return a = ConsDrawing $ return a
+  m >>= k  = ConsDrawing $ getConsDrawing m >>= (getConsDrawing . k)
+
+
+instance Monad m => Monad (ConsDrawingT u m) where
+  return a = ConsDrawingT $ return a
+  m >>= k  = ConsDrawingT $ getConsDrawingT m >>= (getConsDrawingT . k)
+
+
+instance MonadT (ConsDrawingT u) where
+  lift m = ConsDrawingT $ lift $ lift $ lift m
+
+
+instance TurtleM (ConsDrawing u) where
+  getLoc      = ConsDrawing $ getLoc
+  setLoc c    = ConsDrawing $ setLoc c
+  getOrigin   = ConsDrawing $ getOrigin
+  setOrigin o = ConsDrawing $ setOrigin o
+
+instance TurtleScaleM (ConsDrawing u) u where
+  xStep    = ConsDrawing $ xStep
+  yStep    = ConsDrawing $ yStep
+
+
+instance Monad m => TurtleM (ConsDrawingT u m) where
+  getLoc      = ConsDrawingT $ getLoc
+  setLoc c    = ConsDrawingT $ setLoc c
+  getOrigin   = ConsDrawingT $ getOrigin
+  setOrigin o = ConsDrawingT $ setOrigin o
+
+
+instance Monad m => TurtleScaleM (ConsDrawingT u m) u where
+  xStep    = ConsDrawingT $ xStep
+  yStep    = ConsDrawingT $ yStep
+
+
+instance DrawingCtxM (ConsDrawing u) where
+  askDrawingCtx   = ConsDrawing $ lift askDrawingCtx
+  localCtx ctx ma = ConsDrawing $ localCtx ctx (getConsDrawing ma)
+  
+
+instance Monad m => DrawingCtxM (ConsDrawingT u m) where
+  askDrawingCtx   = ConsDrawingT $ lift askDrawingCtx
+  localCtx ctx ma = ConsDrawingT $ localCtx ctx (getConsDrawingT ma)
+
+instance TraceM (ConsDrawing u) (Primitive u) where
+  trace  a = ConsDrawing $ lift $ lift $ trace a
+  trace1 a = ConsDrawing $ lift $ lift $ trace1 a
+
+instance Monad m => TraceM (ConsDrawingT u m) (Primitive u) where
+  trace  a = ConsDrawingT $ lift $ lift $ trace a
+  trace1 a = ConsDrawingT $ lift $ lift $ trace1 a
+
+runConsDrawing :: Num u 
+               => TurtleConfig u 
+               -> (Int,Int)
+               -> DrawingAttr 
+               -> ConsDrawing u a 
+               -> (a, Graphic u)
+runConsDrawing cfg ogin attr mf = runTrace 
+                                ( runDrawingCtxT attr
+                                ( runTurtleT cfg ogin $ getConsDrawing mf ))
+
+
+runConsDrawingT :: (Monad m, Num u) 
+                => TurtleConfig u 
+                -> (Int,Int)
+                -> DrawingAttr 
+                -> ConsDrawingT u m a 
+                -> m (a, Graphic u)
+runConsDrawingT cfg ogin attr mf = runTraceT 
+                                 ( runDrawingCtxT attr
+                                 ( runTurtleT cfg ogin $ getConsDrawingT mf ))
+
+execConsDrawing :: Num u 
+                => TurtleConfig u
+                -> (Int,Int) 
+                -> DrawingAttr 
+                -> ConsDrawing u a 
+                -> Graphic u
+execConsDrawing cfg ogin attr mf = snd $ runConsDrawing cfg ogin attr mf
+
+
+execConsDrawingT :: (Monad m, Num u)
+                 => TurtleConfig u 
+                 -> (Int,Int)
+                 -> DrawingAttr 
+                 -> ConsDrawingT u m a 
+                 -> m (Graphic u)
+execConsDrawingT cfg ogin attr mf = liftM snd $ runConsDrawingT cfg ogin attr mf
diff --git a/src/Wumpus/Basic/Monads/Drawing.hs b/src/Wumpus/Basic/Monads/Drawing.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/Drawing.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.Drawing
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Drawing operations
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.Drawing
+  (
+    
+    MGraphicF 
+  , traceG
+  , node
+  , at
+  ) where
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Monads.TurtleClass
+
+import Wumpus.Core                              -- package: wumpus-core
+
+
+type MGraphicF m u a = Point2 u -> m a
+
+traceG :: (Monad m, TraceM m (Primitive u)) => GraphicF u -> MGraphicF m u ()
+traceG fn = \pt -> trace (fn pt)
+
+-- MGraphic functions will have to trace themselves...
+
+node :: (TraceM m (Primitive u), TurtleScaleM m u, Num u) 
+     => MGraphicF m u a -> m a 
+node mgF = getPos >>= \pt -> mgF pt
+
+
+infixr 6 `at` 
+
+at :: (Num u, TraceM m (Primitive u), TurtleScaleM m u) 
+   => MGraphicF m u a -> (Int,Int) -> m a
+at mgF coord = scaleCoord coord >>= \pt -> mgF pt
+
diff --git a/src/Wumpus/Basic/Monads/DrawingCtxClass.hs b/src/Wumpus/Basic/Monads/DrawingCtxClass.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/DrawingCtxClass.hs
@@ -0,0 +1,74 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.DrawingCtxClass
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Class.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.DrawingCtxClass
+  (
+
+  -- * Re-exports from Wumpus.Basic.Graphic.DrawingAttr
+    DrawingAttr(..)
+  , standardAttr
+
+  -- * DrawingCtx class
+
+  , DrawingCtxM(..)
+  , withinModifiedCtx
+
+  , strokeAttr
+  , fillAttr
+  , textAttr
+  , markHeight
+
+  , textDimensions
+  
+  ) where
+
+import Wumpus.Basic.Graphic.DrawingAttr ( DrawingAttr(..), standardAttr )
+import qualified Wumpus.Basic.Graphic.DrawingAttr as DA
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import Control.Monad
+
+
+-- local to add? or new class...
+
+class Monad m => DrawingCtxM m where
+  askDrawingCtx :: m DrawingAttr
+  localCtx      :: DrawingAttr -> m a -> m a
+
+
+
+withinModifiedCtx :: DrawingCtxM m 
+                  => (DrawingAttr -> DrawingAttr) -> m a -> m a
+withinModifiedCtx upd ma = askDrawingCtx >>= \ctx -> localCtx (upd ctx) ma
+
+
+strokeAttr  :: DrawingCtxM m => m (DRGB, StrokeAttr)
+strokeAttr  = liftM DA.strokeAttr askDrawingCtx
+
+
+fillAttr    :: DrawingCtxM m => m DRGB
+fillAttr    = liftM DA.fillAttr askDrawingCtx
+
+textAttr    :: DrawingCtxM m => m  (DRGB, FontAttr)
+textAttr    = liftM DA.textAttr askDrawingCtx
+
+markHeight  :: (Fractional u, DrawingCtxM m) => m u
+markHeight  = liftM DA.markHeight askDrawingCtx
+
+textDimensions :: (Fractional u, DrawingCtxM m) => String -> m (u,u)
+textDimensions str = liftM (DA.textDimensions str) askDrawingCtx
+
diff --git a/src/Wumpus/Basic/Monads/DrawingCtxMonad.hs b/src/Wumpus/Basic/Monads/DrawingCtxMonad.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/DrawingCtxMonad.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.DrawingCtxMonad
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Reader (enviroment) monad for common drawing attributes.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.DrawingCtxMonad
+  (
+
+
+  -- * DrawingCtx monads
+    DrawingCtx
+  , DrawingCtxT     
+
+  , runDrawingCtx
+  , runDrawingCtxT
+
+  
+  ) where
+
+import Wumpus.Basic.Monads.DrawingCtxClass
+import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Monads.TurtleClass
+
+import MonadLib ( MonadT(..) )          -- package: monadLib
+
+import Control.Applicative
+import Control.Monad
+
+
+newtype DrawingCtx a = DrawingCtx  { getDrawingCtx  :: DrawingAttr -> a } 
+
+newtype DrawingCtxT m a = DrawingCtxT { getDrawingCtxT :: DrawingAttr -> m a }
+
+
+-- Functor
+
+instance Functor DrawingCtx where
+  fmap f m = DrawingCtx $ \r -> let a = getDrawingCtx m r in f a
+
+instance Monad m => Functor (DrawingCtxT m) where
+  fmap f m = DrawingCtxT $ \r -> getDrawingCtxT m r >>= \a ->
+                                 return (f a)
+
+-- Applicative 
+instance Applicative DrawingCtx where
+  pure a    = DrawingCtx $ \_ -> a
+  mf <*> ma = DrawingCtx $ \r -> let f = getDrawingCtx mf r
+                                     a = getDrawingCtx ma r
+                                 in f a 
+
+
+instance Monad m => Applicative (DrawingCtxT m) where
+  pure a    = DrawingCtxT $ \_ -> return a
+  mf <*> ma = DrawingCtxT $ \r -> getDrawingCtxT mf r  >>= \f ->
+                                  getDrawingCtxT ma r  >>= \a ->
+                                  return (f a) 
+
+
+-- Monad 
+
+instance Monad DrawingCtx where
+  return a = DrawingCtx $ \_ -> a
+  m >>= k  = DrawingCtx $ \r -> let a = getDrawingCtx m r
+                                in (getDrawingCtx . k) a r
+
+instance Monad m => Monad (DrawingCtxT m) where
+  return a = DrawingCtxT $ \_ -> return a
+  m >>= k  = DrawingCtxT $ \r -> getDrawingCtxT m r       >>= \a  ->
+                                 (getDrawingCtxT . k) a r 
+
+
+instance MonadT DrawingCtxT where
+  lift m = DrawingCtxT $ \_ -> m >>= \a -> return a
+
+
+
+instance DrawingCtxM DrawingCtx where
+  askDrawingCtx    = DrawingCtx id
+  localCtx ctx ma  = DrawingCtx $ \_ -> getDrawingCtx ma ctx  
+
+instance Monad m => DrawingCtxM (DrawingCtxT m) where
+  askDrawingCtx    = DrawingCtxT return
+  localCtx ctx ma  = DrawingCtxT $ \_ -> getDrawingCtxT ma ctx  
+
+
+runDrawingCtx :: DrawingAttr -> DrawingCtx a -> a
+runDrawingCtx cfg mf = getDrawingCtx mf cfg
+
+runDrawingCtxT :: Monad m => DrawingAttr -> DrawingCtxT m a -> m a
+runDrawingCtxT cfg mf = getDrawingCtxT mf cfg
+
+--------------------------------------------------------------------------------
+--- Cross instances
+
+instance (Monad m, TraceM m i) => TraceM (DrawingCtxT m) i where
+  trace a  = DrawingCtxT $ \_ -> trace a
+  trace1 a = DrawingCtxT $ \_ -> trace1 a
+
+instance TurtleM m => TurtleM (DrawingCtxT m) where
+  getLoc          = DrawingCtxT $ \_ -> getLoc
+  setLoc c        = DrawingCtxT $ \_ -> setLoc c
+  getOrigin       = DrawingCtxT $ \_ -> getOrigin
+  setOrigin o     = DrawingCtxT $ \_ -> setOrigin o
+
+instance TurtleScaleM m u => TurtleScaleM (DrawingCtxT m) u where
+  xStep           = DrawingCtxT $ \_ -> xStep
+  yStep           = DrawingCtxT $ \_ -> yStep
diff --git a/src/Wumpus/Basic/Monads/STraceMonad.hs b/src/Wumpus/Basic/Monads/STraceMonad.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/STraceMonad.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.STraceMonad
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Snoc tracing monad
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.STraceMonad
+  (
+
+    STrace
+  , STraceT
+
+  , runSTrace
+  , runSTraceT
+ 
+  ) where
+
+import Wumpus.Basic.Monads.DrawingCtxClass
+import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Monads.TurtleClass
+
+import Wumpus.Basic.Utils.HList
+
+import MonadLib ( MonadT(..) )          -- package: monadLib
+
+import Control.Applicative
+
+
+
+newtype STrace  i   a = STrace  { getSTrace  :: H i -> (a, H i) }
+
+newtype STraceT i m a = STraceT { getSTraceT :: H i -> m (a, H i) }
+
+-- Functor
+
+instance Functor (STrace i) where
+  fmap f m = STrace $ \w -> let (a,w') = getSTrace m w in (f a, w')
+
+instance Monad m => Functor (STraceT i m) where
+  fmap f m = STraceT $ \w -> getSTraceT m w >>= \(a,w') ->
+                             return (f a, w')
+
+-- Applicative
+
+instance Applicative (STrace i) where
+  pure a    = STrace $ \w -> (a,w)
+  mf <*> ma = STrace $ \w -> let (f,w')  = getSTrace mf w 
+                                 (a,w'') = getSTrace ma w'
+                             in (f a,w'')
+
+
+instance Monad m => Applicative (STraceT i m) where
+  pure a    = STraceT $ \w -> return (a,w)
+  mf <*> ma = STraceT $ \w -> getSTraceT mf w  >>= \(f,w')  ->
+                              getSTraceT ma w' >>= \(a,w'') ->
+                              return (f a,w'') 
+
+-- Monad
+
+instance Monad (STrace i) where
+  return a = STrace $ \w -> (a,w)
+  m >>= k  = STrace $ \w -> let (a,w') = getSTrace m w
+                            in (getSTrace . k) a w'
+     
+
+
+instance Monad m => Monad (STraceT i m) where
+  return a = STraceT $ \w -> return (a,w)
+  m >>= k  = STraceT $ \w -> getSTraceT m w        >>= \(a,w')  ->
+                             (getSTraceT . k) a w' >>= \(b,w'') ->
+                             return (b,w'')
+
+
+
+
+instance MonadT (STraceT i) where 
+  lift m = STraceT $ \w -> m >>= \ a -> return (a,w)
+
+
+instance TraceM (STrace i) i where
+  trace  h = STrace $ \w -> ((), w . h)  
+  trace1 i = STrace $ \w -> ((), w `snocH` i)  
+
+instance Monad m => TraceM (STraceT i m) i where
+  trace  h = STraceT $ \w -> return ((), w . h)  
+  trace1 i = STraceT $ \w -> return ((), w `snocH` i)  
+
+
+
+runSTrace :: STrace i a -> (a,H i)
+runSTrace mf = getSTrace mf id 
+
+runSTraceT :: Monad m => STraceT i m a -> m (a,H i)
+runSTraceT mf = getSTraceT mf id >>= \(a,w) -> return (a,w)
+
+
+
+--------------------------------------------------------------------------------
+-- Cross instances
+
+instance DrawingCtxM m => DrawingCtxM (STraceT i m) where
+  askDrawingCtx   = STraceT $ \w -> askDrawingCtx >>= \ctx -> return (ctx,w)
+  localCtx ctx mf = STraceT $ \w -> localCtx ctx (getSTraceT mf w)
+
+
+instance TurtleM m => TurtleM (STraceT i m) where
+  getLoc          = STraceT $ \w -> getLoc >>= \a -> return (a,w)
+  setLoc c        = STraceT $ \w -> setLoc c >> return ((),w)
+  getOrigin       = STraceT $ \w -> getOrigin >>= \a -> return (a,w)
+  setOrigin o     = STraceT $ \w -> setOrigin o >> return ((),w)
+
+instance TurtleScaleM m u => TurtleScaleM (STraceT i m) u where
+  xStep           = STraceT $ \w -> xStep >>= \a -> return (a,w)
+  yStep           = STraceT $ \w -> yStep >>= \a -> return (a,w)
diff --git a/src/Wumpus/Basic/Monads/SnocDrawing.hs b/src/Wumpus/Basic/Monads/SnocDrawing.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/SnocDrawing.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.SnocDrawing
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- STrace plus DrawingCtx plus Turtle...
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.SnocDrawing
+  (
+    SnocDrawing
+  , SnocDrawingT
+
+  , runSnocDrawing
+  , runSnocDrawingT
+  , execSnocDrawing
+  , execSnocDrawingT
+
+  -- * Re-exports
+  , module Wumpus.Basic.Monads.Drawing
+  , module Wumpus.Basic.Monads.DrawingCtxClass
+  , module Wumpus.Basic.Monads.TraceClass
+  , module Wumpus.Basic.Monads.TurtleClass 
+
+  ) where
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Monads.Drawing
+import Wumpus.Basic.Monads.DrawingCtxClass
+import Wumpus.Basic.Monads.DrawingCtxMonad
+import Wumpus.Basic.Monads.STraceMonad
+import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Monads.TurtleClass
+import Wumpus.Basic.Monads.TurtleMonad
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import MonadLib ( MonadT(..) )          -- package: monadLib
+
+import Control.Applicative
+import Control.Monad
+
+
+newtype SnocDrawing u a = SnocDrawing { 
+          getSnocDrawing  :: TurtleT           u
+                           ( DrawingCtxT 
+                           ( STrace (Primitive u))) a }
+
+newtype SnocDrawingT u m a = SnocDrawingT { 
+          getSnocDrawingT :: TurtleT            u
+                           ( DrawingCtxT 
+                           ( STraceT (Primitive u) m)) a }
+
+
+-- Functor
+
+instance Functor (SnocDrawing u) where
+  fmap f = SnocDrawing . fmap f . getSnocDrawing
+
+instance Monad m => Functor (SnocDrawingT u m) where
+  fmap f = SnocDrawingT . fmap f . getSnocDrawingT
+
+
+-- Applicative 
+instance Applicative (SnocDrawing u) where
+  pure a    = SnocDrawing $ pure a
+  mf <*> ma = SnocDrawing $ getSnocDrawing mf <*> getSnocDrawing ma
+                   
+
+
+instance Monad m => Applicative (SnocDrawingT u m) where
+  pure a    = SnocDrawingT $ pure a
+  mf <*> ma = SnocDrawingT $ getSnocDrawingT mf <*> getSnocDrawingT ma
+
+
+-- Monad 
+
+instance Monad (SnocDrawing u) where
+  return a = SnocDrawing $ return a
+  m >>= k  = SnocDrawing $ getSnocDrawing m >>= (getSnocDrawing . k)
+
+
+instance Monad m => Monad (SnocDrawingT u m) where
+  return a = SnocDrawingT $ return a
+  m >>= k  = SnocDrawingT $ getSnocDrawingT m >>= (getSnocDrawingT . k)
+
+
+instance MonadT (SnocDrawingT u) where
+  lift m = SnocDrawingT $ lift $ lift $ lift m
+
+
+instance TurtleM (SnocDrawing u) where
+  getLoc      = SnocDrawing $ getLoc
+  setLoc c    = SnocDrawing $ setLoc c
+  getOrigin   = SnocDrawing $ getOrigin
+  setOrigin o = SnocDrawing $ setOrigin o
+
+instance TurtleScaleM (SnocDrawing u) u where
+  xStep    = SnocDrawing $ xStep
+  yStep    = SnocDrawing $ yStep
+
+instance Monad m => TurtleM (SnocDrawingT u m) where
+  getLoc      = SnocDrawingT $ getLoc
+  setLoc c    = SnocDrawingT $ setLoc c
+  getOrigin   = SnocDrawingT $ getOrigin
+  setOrigin o = SnocDrawingT $ setOrigin o
+
+
+instance Monad m => TurtleScaleM (SnocDrawingT u m) u where
+  xStep    = SnocDrawingT $ xStep
+  yStep    = SnocDrawingT $ yStep
+
+instance DrawingCtxM (SnocDrawing u) where
+  askDrawingCtx   = SnocDrawing $ askDrawingCtx
+  localCtx ctx ma = SnocDrawing $ localCtx ctx (getSnocDrawing ma)
+
+instance Monad m => DrawingCtxM (SnocDrawingT u m) where
+  askDrawingCtx   = SnocDrawingT $ askDrawingCtx
+  localCtx ctx ma = SnocDrawingT $ localCtx ctx (getSnocDrawingT ma)
+
+instance TraceM (SnocDrawing u) (Primitive u) where
+  trace  a = SnocDrawing $ lift $ lift $ trace a
+  trace1 a = SnocDrawing $ lift $ lift $ trace1 a
+
+instance Monad m => TraceM (SnocDrawingT u m) (Primitive u) where
+  trace  a = SnocDrawingT $ lift $ lift $ trace a
+  trace1 a = SnocDrawingT $ lift $ lift $ trace1 a
+
+runSnocDrawing :: Num u 
+               => TurtleConfig u 
+               -> (Int,Int)
+               -> DrawingAttr 
+               -> SnocDrawing u a 
+               -> (a, Graphic u)
+runSnocDrawing cfg ogin attr mf = runSTrace 
+                                ( runDrawingCtxT attr
+                                ( runTurtleT cfg ogin $ getSnocDrawing mf ))
+
+
+runSnocDrawingT :: (Monad m, Num u) 
+                => TurtleConfig u
+                -> (Int,Int) 
+                -> DrawingAttr 
+                -> SnocDrawingT u m a 
+                -> m (a, Graphic u)
+runSnocDrawingT cfg ogin attr mf = runSTraceT 
+                                 ( runDrawingCtxT attr
+                                 ( runTurtleT cfg ogin $ getSnocDrawingT mf ))
+
+execSnocDrawing :: Num u 
+                => TurtleConfig u 
+                -> (Int,Int)
+                -> DrawingAttr 
+                -> SnocDrawing u a 
+                -> Graphic u
+execSnocDrawing cfg ogin attr mf = snd $ runSnocDrawing cfg ogin attr mf
+
+
+execSnocDrawingT :: (Monad m, Num u)
+                 => TurtleConfig u 
+                 -> (Int,Int)
+                 -> DrawingAttr 
+                 -> SnocDrawingT u m a 
+                 -> m (Graphic u)
+execSnocDrawingT cfg ogin attr mf = liftM snd $ runSnocDrawingT cfg ogin attr mf
diff --git a/src/Wumpus/Basic/Monads/TraceClass.hs b/src/Wumpus/Basic/Monads/TraceClass.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/TraceClass.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FunctionalDependencies     #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.TraceClass
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Tracing class covers both cons and snoc tracing
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.TraceClass
+  (
+
+    TraceM(..)
+
+ 
+  ) where
+
+
+import Wumpus.Basic.Utils.HList
+
+
+class TraceM  m i | m -> i where
+  trace  :: H i -> m ()
+  trace1 :: i -> m ()
+
diff --git a/src/Wumpus/Basic/Monads/TraceMonad.hs b/src/Wumpus/Basic/Monads/TraceMonad.hs
--- a/src/Wumpus/Basic/Monads/TraceMonad.hs
+++ b/src/Wumpus/Basic/Monads/TraceMonad.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE FunctionalDependencies     #-}
+{-# LANGUAGE UndecidableInstances       #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE TypeSynonymInstances       #-}
 {-# OPTIONS -Wall #-}
@@ -32,17 +32,20 @@
 
     Trace
   , TraceT
-  , TraceM(..)
 
   , runTrace
   , runTraceT
  
   ) where
 
-import MonadLib ( MonadT(..) )          -- package: monadLib
-
+import Wumpus.Basic.Monads.DrawingCtxClass
+import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Monads.TurtleClass
 import Wumpus.Basic.Utils.HList
 
+
+import MonadLib ( MonadT(..) )          -- package: monadLib
+
 import Control.Applicative
 
 
@@ -96,11 +99,7 @@
 instance MonadT (TraceT i) where 
   lift m = TraceT $ \w -> m >>= \ a -> return (a,w)
 
-class TraceM  m i | m -> i where
-  trace  :: H i -> m ()
-  trace1 :: i -> m ()
 
-
 instance TraceM (Trace i) i where
   trace  h = Trace $ \w -> ((), h . w)  
   trace1 i = Trace $ \w -> ((), i `consH` w)  
@@ -118,6 +117,22 @@
 runTraceT mf = getTraceT mf id >>= \(a,w) -> return (a,w)
 
 
+--------------------------------------------------------------------------------
+-- Cross instances
 
+instance DrawingCtxM m => DrawingCtxM (TraceT i m) where
+  askDrawingCtx   = TraceT $ \w -> askDrawingCtx >>= \ ctx -> return (ctx,w)
+  localCtx ctx mf = TraceT $ \w -> localCtx ctx (getTraceT mf w)
+
+
+instance TurtleM m => TurtleM (TraceT i m) where
+  getLoc          = TraceT $ \w -> getLoc >>= \a -> return (a,w)
+  setLoc c        = TraceT $ \w -> setLoc c >> return ((),w)
+  getOrigin       = TraceT $ \w -> getOrigin >>= \a -> return (a,w)
+  setOrigin o     = TraceT $ \w -> setOrigin o >> return ((),w)
+
+instance TurtleScaleM m u => TurtleScaleM (TraceT i m) u where
+  xStep           = TraceT $ \w -> xStep >>= \a -> return (a,w)
+  yStep           = TraceT $ \w -> yStep >>= \a -> return (a,w)
  
 
diff --git a/src/Wumpus/Basic/Monads/TurtleClass.hs b/src/Wumpus/Basic/Monads/TurtleClass.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/TurtleClass.hs
@@ -0,0 +1,130 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FunctionalDependencies     #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.TurtleClass
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Turtle monad and monad transformer.
+--
+-- The Turtle monad embodies the LOGO style of imperative 
+-- drawing - sending commands to update the a cursor.
+--
+-- While Wumpus generally aims for a more compositional,
+-- \"coordinate-free\" style of drawing, some types of 
+-- diagram are more easily expressed in the LOGO style.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.TurtleClass
+  (
+
+    Coord
+  , TurtleConfig(..)
+  , regularConfig 
+
+  , TurtleM(..)
+  , TurtleScaleM(..)
+
+  , askSteps
+  , setsLoc
+  , setsLoc_
+
+  -- * movement
+  , resetLoc
+  , moveLeft
+  , moveRight
+  , moveUp
+  , 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
+
+setsLoc_ :: TurtleM m => (Coord -> Coord) -> m ()
+setsLoc_ f = getLoc     >>= \coord ->  setLoc (f coord)
+
+
+
+resetLoc    :: TurtleM m => m ()
+resetLoc    = getOrigin >>= setLoc
+
+
+moveRight   :: TurtleM m => m ()
+moveRight   = setsLoc_ $ \(x,y)-> (x+1, y)
+
+
+moveLeft    :: TurtleM m => m ()
+moveLeft    = setsLoc_ $ \(x,y) -> (x-1,y)
+
+moveUp      :: TurtleM m => m ()
+moveUp      = setsLoc_ $ \(x,y) -> (x,y+1)
+
+moveDown    :: TurtleM m => m ()
+moveDown    = setsLoc_ $ \(x,y) -> (x ,y-1)
+
+
+nextLine    :: TurtleM m => m ()
+nextLine    = getOrigin >>= \(ox,_) ->
+              setsLoc_ $ \(_,y) -> (ox,y-1)
+
+
+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
@@ -1,5 +1,7 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE UndecidableInstances       #-}
 {-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -19,147 +21,141 @@
 --
 -- While Wumpus generally aims for a more compositional,
 -- \"coordinate-free\" style of drawing, some types of 
--- diagram are very easily expressed in the LOGO style.
+-- diagram are more easily expressed in the LOGO style.
 --
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Monads.TurtleMonad
   (
-    Coord(..)
 
-  , Turtle
-  , TurtleT
 
-  , TurtleM(..)
+    Turtle
+  , TurtleT
 
   , runTurtle
   , runTurtleT
 
-  , setsLoc
-  , setsLoc_
-
-  -- * movement
-  , reset
-  , moveLeft
-  , moveRight
-  , moveUp
-  , moveDown
-  , nextLine
-
-  , wander
  
   ) where
 
+import Wumpus.Basic.Monads.DrawingCtxClass
+import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Monads.TurtleClass
 
+
 import MonadLib ( MonadT(..) )          -- package: monadLib
 
 import Control.Applicative
+import Control.Monad
 
 
-data Coord = Coord !Int !Int
-
-instance Show Coord where
-  showsPrec i (Coord x y) = showsPrec i (x,y)
+-- Turtle is a Reader / State monad
+-- 
+-- The env is the horizontal and vertical move distances.
+-- 
+-- The state is the current coordinate and the origin.
+--
 
+data TurtleState = TurtleState 
+      { _turtle_origin   :: (Int,Int)
+      , _current_coord   :: (Int,Int)
+      }
 
-newtype Turtle    a = Turtle  { getTurtle  :: Coord -> (a, Coord) } 
+newtype Turtle u a = Turtle  { 
+          getTurtle  :: TurtleConfig u -> TurtleState -> (a, TurtleState) } 
 
-newtype TurtleT m a = TurtleT { getTurtleT :: Coord -> m (a, Coord) }
+newtype TurtleT u m a = TurtleT { 
+          getTurtleT :: TurtleConfig u -> TurtleState -> m (a, TurtleState) }
 
 
 -- Functor
 
-instance Functor Turtle where
-  fmap f m = Turtle $ \st -> let (a,st') = getTurtle m st in (f a, st')                   
+instance Functor (Turtle u) where
+  fmap f m = Turtle $ \r s -> let (a,s') = getTurtle m r s in (f a, s')
 
-instance Monad m => Functor (TurtleT m) where
-  fmap f m = TurtleT $ \st -> getTurtleT m st >>= \(a,st') ->
-                              return (f a, st')
+instance Monad m => Functor (TurtleT u m) where
+  fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->
+                               return (f a, s')
 
 -- Applicative 
-instance Applicative Turtle where
-  pure a    = Turtle $ \st -> (a,st)
-  mf <*> ma = Turtle $ \st -> let (f,st')  = getTurtle mf st 
-                                  (a,st'') = getTurtle ma st'
-                              in (f a,st'') 
+instance Applicative (Turtle u) where
+  pure a    = Turtle $ \_ s -> (a,s)
+  mf <*> ma = Turtle $ \r s -> let (f,s')  = getTurtle mf r s 
+                                   (a,s'') = getTurtle ma r s'
+                                in (f a,s'') 
 
 
-instance Monad m => Applicative (TurtleT m) where
-  pure a    = TurtleT $ \st -> return (a,st)
-  mf <*> ma = TurtleT $ \st -> getTurtleT mf st  >>= \(f,st')  ->
-                               getTurtleT ma st' >>= \(a,st'') ->
-                               return (f a,st'') 
+instance Monad m => Applicative (TurtleT u m) where
+  pure a    = TurtleT $ \_ s -> return (a,s)
+  mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s  >>= \(f,s')  ->
+                                getTurtleT ma r s' >>= \(a,s'') ->
+                                return (f a,s'') 
 
 
 -- Monad 
 
-instance Monad Turtle where
-  return a = Turtle $ \st -> (a,st)
-  m >>= k  = Turtle $ \st -> let (a,st') = getTurtle m st
-                             in (getTurtle . k) a st'
+instance Monad (Turtle u) where
+  return a = Turtle $ \_ s -> (a,s)
+  m >>= k  = Turtle $ \r s -> let (a,s') = getTurtle m r s
+                              in (getTurtle . k) a r s'
 
-instance Monad m => Monad (TurtleT m) where
-  return a = TurtleT $ \st -> return (a,st)
-  m >>= k  = TurtleT $ \st -> getTurtleT m st        >>= \(a,st')  ->
-                              (getTurtleT . k) a st' >>= \(b,st'') ->
-                              return (b,st'')
+instance Monad m => Monad (TurtleT u m) where
+  return a = TurtleT $ \_ s -> return (a,s)
+  m >>= k  = TurtleT $ \r s -> getTurtleT m r s        >>= \(a,s')  ->
+                               (getTurtleT . k) a r s' >>= \(b,s'') ->
+                               return (b,s'')
 
-instance MonadT TurtleT where
-  lift m = TurtleT $ \st -> m >>= \a -> return (a,st)
+instance MonadT (TurtleT u) where
+  lift m = TurtleT $ \_ s -> m >>= \a -> return (a,s)
 
-class Monad m => TurtleM m where
-  getLoc :: m Coord
-  setLoc :: Coord -> m ()
 
-instance TurtleM Turtle where
-  getLoc   = Turtle $ \st -> (st,st)
-  setLoc c = Turtle $ \_  -> ((),c)
-  
 
-instance Monad m => TurtleM (TurtleT m) where
-  getLoc   = TurtleT $ \st -> return (st,st)
-  setLoc c = TurtleT $ \_  -> return ((),c)
+instance TurtleM (Turtle u) where
+  getLoc      = Turtle $ \_ s@(TurtleState _ c) -> (c,s)
+  setLoc c    = Turtle $ \_   (TurtleState o _) -> ((),TurtleState o c)
+  getOrigin   = Turtle $ \_ s@(TurtleState o _) -> (o,s)
+  setOrigin o = Turtle $ \_   (TurtleState _ c) -> ((),TurtleState o c)
 
+instance TurtleScaleM (Turtle u) u where
+  xStep    = Turtle $ \r s -> (xstep r,s)
+  yStep    = Turtle $ \r s -> (ystep r,s)
 
-runTurtle :: Turtle a -> (a,(Int,Int))
-runTurtle mf = post $ getTurtle mf (Coord 0 0) 
-  where
-    post (a, Coord x y) = (a,(x,y))
 
-runTurtleT :: Monad m => TurtleT m a -> m (a,(Int,Int))
-runTurtleT mf = getTurtleT mf (Coord 0 0) >>= \(a, Coord x y) -> return (a,(x,y))
+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)
 
-setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a
-setsLoc f = getLoc >>= \st -> let (a,st') = f st in setLoc st' >> return a
 
-setsLoc_ :: TurtleM m => (Coord -> Coord) -> m ()
-setsLoc_ f = getLoc >>= \st -> let st' = f st in setLoc st'
+-- Run functions discard the state...
 
-reset       :: TurtleM m => m ()
-reset       = setLoc (Coord 0 0)
+runTurtle :: Num u => TurtleConfig u -> (Int,Int) -> Turtle u a -> a
+runTurtle cfg ogin mf = fst $ getTurtle mf cfg (TurtleState ogin ogin)
+ 
+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)
 
-moveRight   :: TurtleM m => m ()
-moveRight   = setsLoc_ $ \(Coord x y) -> Coord (x+1) y
 
-moveLeft    :: TurtleM m => m ()
-moveLeft    = setsLoc_ $ \(Coord x y) -> Coord (x-1) y
 
-moveUp      :: TurtleM m => m ()
-moveUp      = setsLoc_ $ \(Coord x y) -> Coord x (y-1)
+----------------------------------------------------------------------------------
+-- Cross instances
 
-moveDown    :: TurtleM m => m ()
-moveDown    = setsLoc_ $ \(Coord x y) -> Coord x (y+1)
+instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where
+  askDrawingCtx   = TurtleT $ \_ s -> askDrawingCtx >>= \ ctx -> return (ctx,s)
+  localCtx ctx mf = TurtleT $ \r s -> localCtx ctx (getTurtleT mf r s)
 
-nextLine    :: TurtleM m => m ()
-nextLine    = setsLoc_ $ \(Coord _ y) -> Coord 0 (y-1)
 
+-- This needs undecidable instances...
 
--- | No longer sure about this combinator...
---
-wander :: TurtleM m => m a -> m (a,Coord,Coord)
-wander ma = getLoc >>= \start ->
-            ma     >>= \ans   ->
-            getLoc >>= \end   ->
-            return (ans,start,end)
+instance (Monad m, TraceM m i) => TraceM (TurtleT u m) i where
+  trace a  = TurtleT $ \_ s -> trace a >> return ((),s)
+  trace1 a = TurtleT $ \_ s -> trace1 a >> return ((),s)
+
+
 
diff --git a/src/Wumpus/Basic/Utils/Intersection.hs b/src/Wumpus/Basic/Utils/Intersection.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Utils/Intersection.hs
@@ -0,0 +1,133 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Utils.Intersection
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC with TypeFamilies and more
+--
+-- Intersection of line to line and line to plane
+-- 
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Utils.Intersection
+  ( 
+    LineSegment(..)
+  , PointSlope
+  , pointSlope
+  , LineEqn
+  , lineEqn
+  , toLineEqn
+  , findIntersect
+  , intersection
+
+  , rectangleLines
+
+  ) 
+  where
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+data LineSegment u = LS (Point2 u) (Point2 u)
+  deriving (Eq,Ord,Show)
+
+
+data PointSlope u = PointSlope 
+      { _point_slope_point :: Point2 u
+      , _point_slope_slope :: u
+      }
+  deriving (Eq,Show)
+
+pointSlope :: Fractional u => Point2 u -> Radian -> PointSlope u 
+pointSlope pt theta = PointSlope pt (fromRadian $ tan theta)
+
+
+-- | Line in equational form, i.e. @Ax + By + C = 0@.
+data LineEqn u = LineEqn 
+      { _line_eqn_A :: !u
+      , _line_eqn_B :: !u
+      , _line_eqn_C :: !u 
+      }
+  deriving (Eq,Show)
+
+lineEqn :: Num u => Point2 u -> Point2 u -> LineEqn u
+lineEqn (P2 x1 y1) (P2 x2 y2) = LineEqn a b c 
+  where
+    a = y1 - y2
+    b = x2 - x1
+    c = (x1*y2) - (x2*y1)
+
+
+toLineEqn :: Num u => PointSlope u -> LineEqn u
+toLineEqn (PointSlope (P2 x0 y0) m) = LineEqn m (-1) ((-m) * x0 + y0)
+
+
+
+
+data IntersectionResult u = Intersects u u | Contained | NoIntersect
+  deriving (Eq,Show)
+
+
+-- Note the uses a /plane/ so is susceptible to picking the 
+-- wrong quadrant...
+--
+findIntersect :: (Floating u, Real u, Ord u)
+               => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u)
+findIntersect ctr theta = step 
+  where
+    eqn         = toLineEqn $ pointSlope ctr theta
+    step []     = Nothing
+    step (x:xs) = case intersection x eqn of 
+                     Just pt | quadrantCheck theta ctr pt -> Just pt
+                     _       -> step xs
+
+
+quadrantCheck :: (Real u, Floating u) 
+              => Radian -> Point2 u -> Point2 u -> Bool
+quadrantCheck theta ctr pt = theta `req` langle ctr pt
+
+intersection :: (Fractional u, Ord u) 
+             => LineSegment u -> LineEqn u -> Maybe (Point2 u)
+intersection ls@(LS p q) eqn = case intersect1 ls eqn of
+    Intersects fp fq -> let t = fp / (fp-fq) in Just $ affineComb p q t 
+    Contained        -> Just p
+    NoIntersect      -> Nothing
+
+
+
+intersect1 :: (Num u, Ord u) 
+           => LineSegment u -> LineEqn u -> IntersectionResult u
+intersect1 (LS p q) eqn = 
+     if inters fp fq then Intersects fp fq
+        else if contained fp fq then Contained else NoIntersect
+  where
+    inters a b    = (a < 0 && b >= 0) || (a > 0 && b <= 0)
+    contained a b = a == 0 && b == 0
+    fp            = lineF p eqn
+    fq            = lineF q eqn
+ 
+lineF :: Num u => Point2 u -> LineEqn u -> u
+lineF (P2 x y) (LineEqn a b c) = a*x + b*y + c
+
+affineComb :: Num u => Point2 u -> Point2 u -> u -> Point2 u
+affineComb p q t = p .+^ t *^ (q .-. p)
+
+
+
+
+
+rectangleLines :: Num u => Point2 u -> u -> u -> [LineSegment u]
+rectangleLines ctr hw hh = [LS br tr, LS tr tl, LS tl bl, LS bl br]
+  where
+    br = ctr .+^ (vec hw    (-hh))
+    tr = ctr .+^ (vec hw    hh)
+    tl = ctr .+^ (vec (-hw) hh)
+    bl = ctr .+^ (vec (-hw) (-hh))
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
@@ -8,7 +8,7 @@
 --
 -- Maintainer  :  stephen.tetley@gmail.com
 -- Stability   :  unstable
--- Portability :  GHC with TypeFamilies and more
+-- Portability :  GHC
 --
 -- Version number
 --
@@ -21,5 +21,9 @@
   ) where
 
 
+-- | Version number
+--
+-- > (0,3,0)
+--
 wumpus_basic_version :: (Int,Int,Int)
-wumpus_basic_version = (0,2,0)
+wumpus_basic_version = (0,3,0)
diff --git a/src/Wumpus/Deprecated/PictureLanguage.hs b/src/Wumpus/Deprecated/PictureLanguage.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Deprecated/PictureLanguage.hs
@@ -0,0 +1,543 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Deprecated.PictureLanguage
+-- Copyright   :  (c) Stephen Tetley 2009-2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC with TypeFamilies and more
+--
+-- Type classes and derived functions to compose 2D /pictures/.
+--
+-- WARNING - this module is deprecated.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Deprecated.PictureLanguage 
+  (
+  -- * Data types for alignment 
+    HAlign(..)
+  , VAlign(..)
+
+  -- * Type family and classes
+  , PUnit 
+  , Horizontal(..)
+  , Vertical(..)
+  , Composite(..)
+  , Move(..)
+  , Blank(..)
+
+  -- * Bounds
+  -- $boundsdoc
+  , center
+  , topleft
+  , topright
+  , bottomleft
+  , bottomright
+
+  -- * Composition
+  , ( -@- )
+  , ( ->- )
+  , ( -<- )
+  , ( -//- )
+  , above
+  , below
+  , at
+  , centeredAt
+  , stackOnto
+  , hcat 
+  , vcat
+  , stackOntoCenter
+
+  , hspace
+  , vspace
+  , hsep
+  , vsep
+ 
+  -- * Compose with alignment
+  , alignH
+  , alignV
+  , hcatA
+  , vcatA
+  , hsepA
+  , vsepA
+
+  -- * Special function for text
+  , multilabel
+
+
+  ) where
+
+import Wumpus.Core
+
+import Data.AffineSpace
+
+import Data.List ( foldl' )
+
+
+--------------------------------------------------------------------------------
+-- Data types
+
+-- Alignment
+
+-- | Horizontal alignment - align to the top, center or bottom.
+data HAlign = HTop | HCenter | HBottom
+  deriving (Eq,Show)
+
+-- | Vertical alignment - align to the left, center or bottom.
+data VAlign = VLeft | VCenter | VRight
+  deriving (Eq,Show)
+
+
+
+
+--------------------------------------------------------------------------------
+-- Type family and classes
+
+
+-- | The type of /points/ within a Picture.
+type family PUnit a
+
+
+-- | > a `over` b
+-- 
+-- Place \'picture\' a over b. The idea of @over@ here is the same
+-- as z-ordering in 2D design programs. Implementations of this 
+-- class should \'draw\' picture a over b but move neither.
+-- 
+-- Similarly @beneath@ should \'draw\' the first picture behind 
+-- the second but move neither.
+--
+-- Beneath has a default definition:
+--
+-- > beneath = flip over
+--
+class Composite a where
+  over    :: a -> a -> a
+  beneath :: a -> a -> a
+
+  beneath = flip over
+
+
+-- | Create a /picture/ that has no content but occupies space 
+-- (i.e. it has a bounding box).
+class Blank a where
+  blank :: PUnit a -> PUnit a -> a
+
+
+-- | Move horizontally.
+class Horizontal a where
+  moveH      :: PUnit a -> a -> a
+  leftBound  :: a -> PUnit a
+  rightBound :: a -> PUnit a
+
+-- | Move vertically.
+class Vertical a where
+  moveV       :: PUnit a -> a -> a
+  topBound    :: a -> PUnit a
+  bottomBound :: a -> PUnit a
+
+
+  
+-- | Move in both the horizontal and vertical.
+class Move a where
+  move :: PUnit a -> PUnit a -> a -> a
+
+
+
+
+--------------------------------------------------------------------------------
+
+-- Operations on bounds
+
+-- $boundsdoc
+-- Corresponding operations are available on bounding boxes - the 
+-- definitions here have different type class obligations.
+
+-- | The center of a picture.
+center :: (Horizontal a, Vertical a, Fractional u, u ~ PUnit a) => a -> Point2 u
+center a = P2 hcenter vcenter where  
+    hcenter = leftBound a   + 0.5 * (rightBound a - leftBound a)
+    vcenter = bottomBound a + 0.5 * (topBound a   - bottomBound a)
+
+-- | Extract the top-left corner.
+topleft       :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
+topleft a     = P2 (leftBound a)  (topBound a)
+
+-- | Extract the top-right corner.
+topright      :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
+topright a    = P2 (rightBound a) (topBound a)
+
+-- | Extract the bottom-left corner.
+bottomleft    :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
+bottomleft a  = P2 (leftBound a)  (bottomBound a)
+
+-- | Extract the bottom-right corner.
+bottomright   :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
+bottomright a = P2 (rightBound a) (bottomBound a)
+
+--------------------------------------------------------------------------------
+-- Internal helpers
+
+leftmid       :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) 
+              => a -> Point2 u
+leftmid a     = P2 (leftBound a) (midpt (bottomBound a) (topBound a))
+
+rightmid      :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) 
+              => a -> Point2 u
+rightmid a    = P2 (rightBound a) (midpt (bottomBound a) (topBound a))
+
+
+topmid        :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) 
+              => a -> Point2 u
+topmid a      = P2 (midpt (leftBound a) (rightBound a)) (topBound a)
+
+bottommid     :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a) 
+              => a -> Point2 u
+bottommid a   = P2 (midpt (leftBound a) (rightBound a)) (bottomBound a)
+
+
+midpt :: Fractional a => a -> a -> a
+midpt a b = a + 0.5*(b-a)
+
+--------------------------------------------------------------------------------
+-- Composition
+
+infixr 5 -//-, `above`, `below`
+infixr 6 ->-, -@-
+
+
+-- | > a -@- b
+-- 
+-- Center @a@ on top of @b@, @a@ is potentially moved and drawn 
+-- 'over' @b@.
+--
+(-@-) :: (Horizontal a, Vertical a, Composite a, Move a, Fractional u, 
+             u ~ PUnit a)
+         => a -> a -> a
+p1 -@- p2 = (move x y p1) `over` p2 where V2 x y = center p2 .-. center p1
+
+
+-- | > a ->- b
+-- 
+-- Horizontal composition - move @b@, placing it to the right 
+-- of @a@.
+-- 
+(->-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+a ->- b = a `over` (moveH disp b) where disp = rightBound a - leftBound b 
+
+-- | > a -<- b
+-- 
+-- Horizontal composition - move @a@, placing it to the left 
+-- of @b@.
+--
+(-<-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+a -<- b = (moveH disp a) `over` b where disp = leftBound b - rightBound a
+
+
+-- | > a -//- b
+--
+-- Vertical composition - move @b@, placing it below @a@.
+--
+(-//-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+a -//- b = a `over` (moveV disp b) where disp = bottomBound a - topBound b 
+
+
+-- | > a `below` b
+-- 
+-- Vertical composition - move @a@, placing it below @b@
+--
+below :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+a `below` b = (moveV disp a) `over` b where disp = bottomBound a - topBound b
+
+
+
+-- | > a `above` b
+-- 
+-- Vertical composition - move @a@, placing it above @b@.
+--
+above :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
+a `above` b = (moveV disp a) `over` b where disp = topBound b - bottomBound a 
+
+
+-- | Place the picture at the supplied point.
+-- 
+at :: (Move a, u ~ PUnit a) => a -> Point2 u  -> a
+p `at` (P2 x y) = move x y p
+
+-- | Center the picture at the supplied point.
+--
+centeredAt :: (Horizontal a, Vertical a, Move a, Composite a, Blank a, 
+               Fractional u, u ~ PUnit a) 
+           => a -> Point2 u -> a
+centeredAt p pt = p -@- (blank 0 0 `at` pt) 
+
+
+
+-- | > xs `stackOnto` a
+-- 
+-- Stack the list of pictures @xs@ 'over' @a@.
+--
+-- Note, the first picture in the list is drawn at the top, the
+-- last picture is draw 'over' @a@.
+--
+stackOnto :: (Composite a) => [a] -> a -> a
+stackOnto = flip (foldr over)
+
+-- | > x ->- xs
+-- 
+-- Concatenate the list pictures @xs@ horizontally with @(->-)@ 
+-- starting at @x@.
+-- 
+hcat :: (Horizontal a, Composite a, Num u, u ~ PUnit a)
+     => a -> [a] -> a
+hcat = foldl' (->-)
+
+-- | > x -//- xs
+-- 
+-- Concatenate the list of pictures @xs@ vertically with @(-\/\/-)@ 
+-- starting at @x@.
+--
+vcat :: (Vertical a, Composite a, Num u, u ~ PUnit a)
+     => a -> [a] -> a
+vcat = foldl' (-//-)
+
+
+
+-- | Stack pictures centered ontop of each other - the first 
+-- picture in the list is drawn at the top, last picture is on 
+-- drawn at the bottom.
+stackOntoCenter :: (Horizontal a, Vertical a, Composite a, 
+                Move a, Fractional u,
+                u ~ PUnit a)
+            => [a] -> a -> a
+stackOntoCenter = flip $ foldr (-@-)
+
+
+
+--------------------------------------------------------------------------------
+
+-- Helpers
+blankH  :: (Num u, Blank a, u ~ PUnit a) => u -> a
+blankH = blank `flip` 0
+
+blankV  :: (Num u, Blank a, u ~ PUnit a) => u -> a
+blankV = blank 0
+
+
+-- NOTE
+-- The following simple definition of hspace is invalid:
+--
+-- > hspace n a b = a ->- (moveH n b)
+-- 
+-- The movement due to @moveH n@ is annulled by the @->-@ 
+-- operator which moves relative to the bounding box.
+-- 
+-- The almost as simple definition below, seems to justify 
+-- including Blank as a Picture constructor.
+--
+
+
+-- | > hspace n a b
+--
+-- Concatenate the pictures @a@ and @b@ with @(->-)@ - injecting 
+-- a space of @n@ units to separate the pictures.
+--
+hspace :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) 
+       => u -> a -> a -> a
+hspace n a b = a ->- blankH n ->- b
+
+-- | > vspace n a b
+--
+-- Concatenate the pictures @a@ and @b@ with @(-\/\/-)@ - injecting 
+-- a space of @n@ units to separate the pictures.
+--
+vspace :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) 
+       => u -> a -> a -> a
+vspace n a b = a -//- blankV n -//-  b
+
+
+
+-- | > hsep n x xs
+--
+-- Concatenate the list of pictures @xs@ horizontally with 
+-- @hspace@ starting at @x@. The pictures are interspersed with 
+-- spaces of @n@ units.
+--
+hsep :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a) 
+       => u -> a -> [a] -> a
+hsep n = foldl' (hspace n)
+
+
+
+-- | > vsep n x xs
+--
+-- Concatenate the list of pictures @xs@ vertically with 
+-- @vspace@ starting at @x@. The pictures are interspersed with 
+-- spaces of @n@ units.
+--
+vsep :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a) 
+       => u -> a -> [a] -> a
+vsep n = foldl' (vspace n)
+
+
+--------------------------------------------------------------------------------
+-- Aligning pictures
+
+
+-- | > alignH z a b
+--
+-- Move picture @b@ up or down to be horizontally aligned along a 
+-- line from the top, center or bottom of picture @a@
+-- 
+alignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
+          , u ~ PUnit a ) 
+       => HAlign -> a -> a -> a
+alignH HTop    p1 p2 = vecMove p1 p2 (vvec $ topBound p1 - topBound p2)
+alignH HBottom p1 p2 = vecMove p1 p2 (vvec $ bottomBound p1 - bottomBound p2)
+alignH HCenter p1 p2 = vecMove p1 p2 (vvec v)
+  where V2 _ v = rightmid p1    .-. leftmid p2
+
+
+-- | > alignV z a b
+--
+-- Move picture @b@ left or right to be vertically aligned along a 
+-- line from the left side, center or right side of picture @a@
+-- 
+alignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
+          , u ~ PUnit a ) 
+       => VAlign -> a -> a -> a
+alignV VLeft   p1 p2 = vecMove p1 p2 (hvec $ leftBound p1 - leftBound p2) 
+alignV VRight  p1 p2 = vecMove p1 p2 (hvec $ rightBound p1 - rightBound p2)
+alignV VCenter p1 p2 = vecMove p1 p2 (hvec h) 
+  where V2 h _ = bottommid p1   .-. topmid p2
+
+
+-- Helpers
+
+vecMove :: (Composite a, Move a, u ~ PUnit a) => a -> a -> (Vec2 u) -> a 
+vecMove a b (V2 x y) = a `over` (move x y) b 
+
+-- Unlike alignH this function \"moves and concatenates\".
+moveAlignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
+          , u ~ PUnit a ) 
+       => HAlign -> a -> a -> a
+moveAlignH HTop    p1 p2 = vecMove p1 p2 (topright p1    .-. topleft p2)
+moveAlignH HCenter p1 p2 = vecMove p1 p2 (rightmid p1    .-. leftmid p2)
+moveAlignH HBottom p1 p2 = vecMove p1 p2 (bottomright p1 .-. bottomleft p2)
+
+
+-- Unlike alignV this function \"moves and concatenates\".
+moveAlignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
+          , u ~ PUnit a ) 
+       => VAlign -> a -> a -> a
+moveAlignV VLeft   p1 p2 = vecMove p1 p2 (bottomleft p1  .-. topleft p2)
+moveAlignV VCenter p1 p2 = vecMove p1 p2 (bottommid p1   .-. topmid p2)
+moveAlignV VRight  p1 p2 = vecMove p1 p2 (bottomright p1 .-. topright p2)
+
+
+-- | Variant of 'hcat' that aligns the pictures as well as
+-- concatenating them.
+hcatA :: ( Fractional u, Horizontal a, Vertical a
+         , Composite a, Move a, u ~ PUnit a)
+     => HAlign -> a -> [a] -> a
+hcatA ha = foldl' (moveAlignH ha)
+
+-- | Variant of 'vcat' that aligns the pictures as well as
+-- concatenating them.
+vcatA :: ( Fractional u, Horizontal a, Vertical a
+         , Composite a, Move a, u ~ PUnit a)
+     => VAlign -> a -> [a] -> a
+vcatA va = foldl' (moveAlignV va)
+
+
+-- | Variant of @hsep@ that aligns the pictures as well as
+-- concatenating and spacing them.
+hsepA :: ( Fractional u, Horizontal a, Vertical a
+         , Composite a, Move a, Blank a, u ~ PUnit a)
+     => HAlign -> u -> a -> [a] -> a
+hsepA ha n = foldl' op where 
+   a `op` b = moveAlignH ha (moveAlignH ha a (blankH n)) b 
+
+-- | Variant of @vsep@ that aligns the pictures as well as
+-- concatenating and spacing them.
+vsepA :: ( Fractional u, Horizontal a, Vertical a
+         , Composite a, Move a, Blank a, u ~ PUnit a)
+     => VAlign -> u -> a -> [a] -> a
+vsepA va n = foldl' op where 
+   a `op` b = moveAlignV va (moveAlignV va a (blankV n)) b 
+
+--------------------------------------------------------------------------------
+
+-- TO DETERMINE
+-- What should leftBound and rightBound be for an empty picture?
+
+type instance PUnit (Picture u) = u
+
+instance (Num u, Ord u) => Horizontal (Picture u) where
+  moveH a p  = p `picMoveBy` (hvec a) 
+  leftBound  = leftPlane . boundary
+  rightBound = rightPlane . boundary
+
+instance (Num u, Ord u) => Vertical (Picture u) where
+  moveV a p   = p `picMoveBy` (vvec a) 
+  topBound    = upperPlane . boundary
+  bottomBound = lowerPlane . boundary
+
+-- Note - picture is a binary tree and drawing is depth-first,
+-- left-to-right so pictures in the right of the tree potentially
+-- are drawn on top of pictures on the left.
+--
+-- So to print picture a _over_ picture b we form this node:
+--
+-- >  locale 
+-- >    /\
+-- >   /  \
+-- >  b    a
+--
+-- Hence `over` flips b and a
+
+
+instance (Num u, Ord u) => Composite (Picture u) where
+  over = picOver       
+
+instance (Num u, Ord u) => Move (Picture u) where
+  move x y p = p `picMoveBy` (V2 x y)
+
+
+instance (Num u, Ord u) => Blank (Picture u) where
+  blank w h = blankPicture (bbox zeroPt (P2 w h))
+
+
+
+--------------------------------------------------------------------------------
+-- 
+
+
+-- | Create multiple lines of text.
+--
+-- The dimension argument is the linespacing, measured as the
+-- distance between the upper lines descender and the lower 
+-- lines ascender.
+--
+-- An error is throw if the list of strings is empty
+-- 
+multilabel :: (Real u, Floating u, TextLabel t) 
+           => t -> u -> VAlign -> [String] -> Point2 u -> Picture u
+multilabel _    _ _  []     _  = error $ 
+    "Wumpus.Core.PictureLanguage.multilabel - empty list."
+
+multilabel attr n va (x:xs) pt = 
+    moveAll $ vsepA va n line1 (map mkPic xs)
+  where
+    line1     = mkPic x
+    mkPic s   = frame $ textlabel attr s zeroPt
+    vdelta p  = boundaryHeight (boundary p) - boundaryHeight (boundary line1)
+    moveAll p = moveV (vdelta p) $ p `at` pt
+
+
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.2.0
+version:          0.3.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -9,10 +9,30 @@
 synopsis:         Common drawing utilities built on wumpus-core.
 description:
   .
-  Very preliminary release...
+  \*\* WARNING \*\* - this package is sub-alpha. It is only on 
+  Hackage to support other packages (Wumpus-Tree, 
+  Wumpus-Microprint) that are slighly more stable.
   .
+  A few of the modules (SafeFonts, SVGColours, X11Colours) are
+  fairly stable others simply aren\'t and may even disappear in
+  subsequent updates.
+  .
+  .
   Changelog:
   .
+  0.2.0 to 0.3.0 :
+  . 
+  * Added the anchors, monads, drawingAttrs...
+  .
+  * Added the module @PictureLanguage@ from Wumpus-Core.
+    It is located with the path prefix @Wumpus.Deprecated@.
+    At some point it will be replaced...
+  .
+  * Basic.Graphic - rectangles and lines now take the supplied
+    point to be the center rather than the bottom-left corner.
+    Name changes - @circle@ changed to @disk@, @text@ changed to 
+    @textline@.
+  .
   0.1.1 to 0.2.0:
   .
   * Added the module @Wumpus.Basic.Graphic@.
@@ -30,28 +50,44 @@
 extra-source-files:
   CHANGES,
   LICENSE,
+  demo/DotPic.hs,
   demo/FontPic.hs,
   demo/ColourCharts.hs,
-  demo/ColourDefns.hs
-
+  demo/ColourDefns.hs,
+  demo/Picture.hs
 
 library
   hs-source-dirs:     src
   build-depends:      base            <  5, 
                       vector-space    >= 0.6,
                       monadLib        >= 3.6,
-                      wumpus-core     >= 0.20.0
+                      wumpus-core     >= 0.21.0
 
   
   exposed-modules:
+    Wumpus.Basic.Anchors,
+    Wumpus.Basic.AnchorDots,
+    Wumpus.Basic.Dots,
     Wumpus.Basic.Graphic,
+    Wumpus.Basic.Graphic.DrawingAttr,
+    Wumpus.Basic.Graphic.PointSupply,
+    Wumpus.Basic.Monads.ConsDrawing,
+    Wumpus.Basic.Monads.Drawing,
+    Wumpus.Basic.Monads.DrawingCtxClass,
+    Wumpus.Basic.Monads.DrawingCtxMonad,
+    Wumpus.Basic.Monads.STraceMonad,
+    Wumpus.Basic.Monads.SnocDrawing,
+    Wumpus.Basic.Monads.TraceClass,
     Wumpus.Basic.Monads.TraceMonad,
+    Wumpus.Basic.Monads.TurtleClass,
     Wumpus.Basic.Monads.TurtleMonad,
     Wumpus.Basic.SafeFonts,
     Wumpus.Basic.SVGColours,
     Wumpus.Basic.X11Colours,
     Wumpus.Basic.Utils.HList,
-    Wumpus.Basic.VersionNumber
+    Wumpus.Basic.Utils.Intersection,
+    Wumpus.Basic.VersionNumber,
+    Wumpus.Deprecated.PictureLanguage
 
   other-modules: