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   = textline (courier 10) name . (.+^ hvec 18)
+    lbl   = textline (FontAttr 10 courier) name . (.+^ hvec 18)
 
 
 
diff --git a/demo/DotPic.hs b/demo/DotPic.hs
--- a/demo/DotPic.hs
+++ b/demo/DotPic.hs
@@ -3,7 +3,7 @@
 module DotPic where
 
 
-import Wumpus.Basic.Dots
+import Wumpus.Basic.Dots.Base
 import Wumpus.Basic.Graphic
 import Wumpus.Basic.Graphic.DrawingAttr
 import Wumpus.Basic.SVGColours
@@ -58,7 +58,7 @@
 points :: [Point2 Double]
 points = [P2 0 0, P2 32 10, P2 64 0, P2 96 10]
 
-makeDotPic :: (Real u, Floating u) 
+makeDotPic :: (Real u, Floating u, FromPtSize u) 
            => (DrawingAttr -> GraphicF u) -> [Point2 u] -> Picture u
 makeDotPic fn xs = drawGraphicU $ veloH (fn std_attr) xs . dashline
   where
diff --git a/demo/FontPic.hs b/demo/FontPic.hs
--- a/demo/FontPic.hs
+++ b/demo/FontPic.hs
@@ -32,13 +32,13 @@
 makeFontLabel :: DRGB -> FontAttr -> DPoint2 -> DPrimitive
 makeFontLabel c fa = textlabel (c,fa) msg
   where
-    msg = unwords [ font_name fa, (show $ font_size fa) ++ "pt"]
+    msg = unwords [ font_name $ font_face fa, (show $ font_size fa) ++ "pt"]
 
-blueLabel :: (Int -> FontAttr) -> Int -> DPoint2 -> DPrimitive
-blueLabel f i = makeFontLabel steelBlue (f i)
+blueLabel :: FontFace -> Int -> DPoint2 -> DPrimitive
+blueLabel ff i = makeFontLabel steelBlue (FontAttr i ff)
 
-redLabel :: (Int -> FontAttr) -> Int -> DPoint2 -> DPrimitive
-redLabel f i = makeFontLabel indianRed1 (f i)
+redLabel :: FontFace -> Int -> DPoint2 -> DPrimitive
+redLabel ff i = makeFontLabel indianRed1 (FontAttr i ff)
 
 
 point_sizes :: [Int]
diff --git a/src/Wumpus/Basic/AnchorDots.hs b/src/Wumpus/Basic/AnchorDots.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/AnchorDots.hs
+++ /dev/null
@@ -1,178 +0,0 @@
-{-# 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
--- a/src/Wumpus/Basic/Anchors.hs
+++ b/src/Wumpus/Basic/Anchors.hs
@@ -11,9 +11,9 @@
 -- Stability   :  highly unstable
 -- Portability :  GHC with TypeFamilies and more
 --
--- Anchor points on \"shapes\".
+-- Anchor points on shapes.
 --
--- ** WARNING ** this module is highly experimental, and may 
+-- \*\* WARNING \*\* this module is an experiment, and may 
 -- change significantly or even be dropped from future revisions.
 -- 
 --------------------------------------------------------------------------------
@@ -58,7 +58,7 @@
 -- on the baseline.
 --
 class TextAnchor t where
-  textAnchor :: DUnit t ~ u => t -> Point2 u
+  baselineSW :: DUnit t ~ u => t -> Point2 u
 
 
 -- | Anchor on a border that can be identified with and angle.
diff --git a/src/Wumpus/Basic/Arrows.hs b/src/Wumpus/Basic/Arrows.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Arrows.hs
@@ -0,0 +1,160 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Arrows
+-- 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 an experiment, and may 
+-- change significantly or even be dropped from future revisions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Arrows
+  ( 
+    line
+
+  , arrowTri90
+  , arrowTri60
+  , arrowTri45
+  , arrowOTri90
+  , arrowOTri60
+  , arrowOTri45
+
+  , arrowBarb90
+  , arrowBarb60
+  , arrowBarb45
+    
+  , arrowPerp
+
+  ) where
+
+import Wumpus.Basic.Arrows.Tips
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Graphic.DrawingAttr
+import Wumpus.Basic.Monads.Drawing
+import Wumpus.Basic.Paths
+import Wumpus.Basic.Paths.Base
+
+import Wumpus.Core                      -- package: wumpus-core
+
+
+
+
+arrowWidth :: FromPtSize u => DrawingAttr -> u 
+arrowWidth = fromPtSize . xcharHeight . font_size . font_props
+
+
+line :: Num u => BPathF u -> AConnector u (BPath u)
+line pathF p0 p1 = AGraphic df mf
+  where
+    df attr () = pathGraphic (pathF p0 p1) attr
+    mf _    () = pathF p0 p1
+
+
+
+
+arrowTri90 :: (Real u, Floating u, FromPtSize u) 
+           => BPathF u -> AConnector u (BPath u)
+arrowTri90 pathF = \p0 p1 -> 
+    AGraphic (\attr () -> triTipRight pathF tri90 p0 p1 attr) 
+             (\_    () -> pathF p0 p1)
+
+arrowTri60 :: (Real u, Floating u, FromPtSize u) 
+           => BPathF u -> AConnector u (BPath u)
+arrowTri60 pathF = \p0 p1 ->
+    AGraphic (\attr () -> triTipRight pathF tri60 p0 p1 attr) 
+             (\_    () -> pathF p0 p1)
+ 
+arrowTri45 :: (Real u, Floating u, FromPtSize u) 
+           => BPathF u -> AConnector u (BPath u)
+arrowTri45 pathF = \p0 p1 ->
+    AGraphic (\attr () -> triTipRight pathF tri45 p0 p1 attr) 
+             (\_    () -> pathF p0 p1)
+
+arrowOTri90 :: (Real u, Floating u, FromPtSize u) 
+            => BPathF u -> AConnector u (BPath u)
+arrowOTri90 pathF = \p0 p1 ->
+    AGraphic (\attr () -> triTipRight pathF otri90 p0 p1 attr) 
+             (\_    () -> pathF p0 p1)
+
+arrowOTri60 :: (Real u, Floating u, FromPtSize u) 
+            => BPathF u -> AConnector u (BPath u)
+arrowOTri60 pathF = \p0 p1 -> 
+    AGraphic (\attr () -> triTipRight pathF otri60 p0 p1 attr) 
+             (\_    () -> pathF p0 p1)
+
+
+arrowOTri45 :: (Real u, Floating u, FromPtSize u) 
+            => BPathF u -> AConnector u (BPath u)
+arrowOTri45 pathF = \p0 p1 ->
+    AGraphic (\attr () -> triTipRight pathF otri45 p0 p1 attr)
+             (\_    () -> pathF p0 p1)
+
+
+arrowBarb90 :: (Real u, Floating u, FromPtSize u) 
+            => BPathF u -> AConnector u (BPath u)
+arrowBarb90 pathF = \p0 p1 ->
+    AGraphic (\attr () -> barbTipRight pathF barb90 p0 p1 attr)
+             (\_    () -> pathF p0 p1)
+
+arrowBarb60 :: (Real u, Floating u, FromPtSize u) 
+            => BPathF u -> AConnector u (BPath u)
+arrowBarb60 pathF = \p0 p1 ->
+    AGraphic (\attr () -> barbTipRight pathF barb60 p0 p1 attr)
+             (\_    () -> pathF p0 p1)
+
+arrowBarb45 :: (Real u, Floating u, FromPtSize u) 
+            => BPathF u -> AConnector u (BPath u)
+arrowBarb45 pathF = \p0 p1 ->
+    AGraphic (\attr () -> barbTipRight pathF barb45 p0 p1 attr)
+             (\_    () -> pathF p0 p1)
+
+
+
+triTipRight :: (Real u, Floating u, FromPtSize u) 
+            => BPathF u 
+            -> (Radian -> DrawingAttr -> GraphicF u)
+            -> Point2 u -> Point2 u -> DrawingAttr 
+            -> Graphic u 
+triTipRight pathF tipF p0 p1 attr = 
+    pathGraphic short_path attr . tipF theta attr p1
+  where
+    sz              = arrowWidth attr
+    line_unit       = realToFrac $ (line_width attr)
+    long_path       = pathF p0 p1
+    short_path      = shortenR (sz+line_unit) long_path
+    mid_short_path  = shortenR (0.5*sz) long_path
+    theta           = directionR mid_short_path
+                     
+
+
+barbTipRight :: (Real u, Floating u, FromPtSize u) 
+             => BPathF u 
+             -> (Radian -> DrawingAttr -> GraphicF u)
+             -> Point2 u -> Point2 u -> DrawingAttr 
+             -> Graphic u 
+barbTipRight pathF tipF p0 p1 attr = 
+    pathGraphic long_path attr . tipF theta attr p1
+  where
+    sz              = arrowWidth attr
+    long_path       = pathF p0 p1
+    mid_short_path  = shortenR (0.5*sz) long_path
+    theta           = directionR mid_short_path
+                     
+
+arrowPerp :: (Real u, Floating u, FromPtSize u) 
+          => BPathF u -> AConnector u (BPath u)
+arrowPerp pathF p0 p1 = AGraphic df mf
+  where
+    df attr () = let theta = langle p0 p1  in
+                 pathGraphic (pathF p0 p1) attr . perp theta attr p1
+    mf _    () = pathF p0 p1
+
diff --git a/src/Wumpus/Basic/Arrows/Tips.hs b/src/Wumpus/Basic/Arrows/Tips.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Arrows/Tips.hs
@@ -0,0 +1,130 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Arrows.Tips
+-- 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 an experiment, and may 
+-- change significantly or even be dropped from future revisions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Arrows.Tips
+  ( 
+
+    tri90
+  , tri60
+  , tri45
+  , otri90
+  , otri60
+  , otri45
+
+  , barb90
+  , barb60
+  , barb45
+
+  , perp
+
+  ) where
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Graphic.DrawingAttr
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import Data.AffineSpace                 -- package: vector-space
+
+
+tripoints :: Floating u
+          => Radian -> u -> Radian -> Point2 u -> (Point2 u, Point2 u)
+tripoints triang xchar_height theta tip = (tip .-^ v1, tip .-^ v2)
+  where
+    halfang = 0.5 * triang
+    d       = xchar_height / (fromRadian $ cos halfang)
+    v1      = avec (theta + halfang) d
+    v2      = avec (theta - halfang) d
+
+
+
+-- width = xchar_height
+-- filled with stroke colour!
+
+triAng :: (Floating u, Real u, FromPtSize u)
+      => Radian 
+      -> (Path u -> DrawingAttr -> Primitive u) 
+      -> Radian -> DrawingAttr -> GraphicF u
+triAng ang fn theta attr pt = wrapG $ fn (vertexPath [pt,u,v]) attr
+  where
+    sz    = fromPtSize $ xcharHeight $ font_size $ font_props attr
+    (u,v) = tripoints ang sz theta  pt
+
+
+-- The arg order should be:
+-- Radian -> DrawingAttr -> GraphicF u
+
+-- as DrawingAttr is a 'static' arg.
+
+tri90 :: (Floating u, Real u, FromPtSize u)
+      => Radian -> DrawingAttr -> GraphicF u
+tri90 = triAng (pi/2) (\p a -> fill (stroke_colour a) p)
+
+
+tri60 :: (Floating u, Real u, FromPtSize u)
+      => Radian -> DrawingAttr -> GraphicF u
+tri60 = triAng (pi/3) (\p a -> fill (stroke_colour a) p)
+
+tri45 :: (Floating u, Real u, FromPtSize u)
+      => Radian -> DrawingAttr -> GraphicF u
+tri45 = triAng (pi/4) (\p a -> fill (stroke_colour a) p)
+
+
+otri90 :: (Floating u, Real u, FromPtSize u)
+      => Radian -> DrawingAttr -> GraphicF u
+otri90 = triAng (pi/2) (\p a -> cstroke (strokeAttr a) p)
+
+otri60 :: (Floating u, Real u, FromPtSize u)
+      => Radian -> DrawingAttr -> GraphicF u
+otri60 = triAng (pi/3) (\p a -> cstroke (strokeAttr a) p)
+
+otri45 :: (Floating u, Real u, FromPtSize u)
+      => Radian -> DrawingAttr -> GraphicF u
+otri45 = triAng (pi/4) (\p a -> cstroke (strokeAttr a) p)
+
+
+barbAng :: (Floating u, Real u, FromPtSize u)
+      => Radian -> Radian -> DrawingAttr -> GraphicF u
+barbAng ang theta attr pt = 
+    wrapG $ ostroke (strokeAttr attr) $ vertexPath [u,pt,v]
+  where
+    sz    = fromPtSize $ xcharHeight $ font_size $ font_props attr
+    (u,v) = tripoints ang sz theta  pt
+
+
+barb90 :: (Floating u, Real u, FromPtSize u) 
+       => Radian -> DrawingAttr -> GraphicF u
+barb90 = barbAng (pi/2)
+
+barb60 :: (Floating u, Real u, FromPtSize u) 
+       => Radian -> DrawingAttr -> GraphicF u
+barb60 = barbAng (pi/3)
+
+barb45 :: (Floating u, Real u, FromPtSize u) 
+       => Radian -> DrawingAttr -> GraphicF u
+barb45 = barbAng (pi/4)
+
+
+
+perp :: (Floating u, FromPtSize u) => Radian -> DrawingAttr -> GraphicF u
+perp theta attr = \pt -> 
+    wrapG $ ostroke (strokeAttr attr) $ vertexPath [ pt .+^ v, pt .-^ v]
+  where
+    half_sz = 0.5 * (fromPtSize $ xcharHeight $ font_size $ font_props attr)
+    v       = avec (theta + pi/2) half_sz
diff --git a/src/Wumpus/Basic/Dots.hs b/src/Wumpus/Basic/Dots.hs
--- a/src/Wumpus/Basic/Dots.hs
+++ b/src/Wumpus/Basic/Dots.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# OPTIONS -Wall #-}
 
 --------------------------------------------------------------------------------
@@ -8,194 +11,149 @@
 --
 -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
 -- Stability   :  highly unstable
--- Portability :  GHC with TypeFamilies and more
+-- Portability :  GHC with TypeFamilies, GADTs and more
 --
--- Dots
--- 
+-- Dots with anchors.
+--
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Dots
   ( 
 
+  -- * Existential anchor type
+    DotAnchor
 
-  -- * Dots
-    dotChar
-  , dotText
-  , dotHLine
-  , dotVLine
-  , dotX
-  , dotPlus
-  , dotCross
-  , dotDiamond
-  , dotFDiamond
+  -- * Dots with anchor points
+  , dotCircle
   , dotDisk
   , dotSquare
-  , dotCircle
-  , dotPentagon
-  , dotStar
-  , dotAsterisk
-  , dotOPlus
-  , dotOCross
-  , dotFOCross
+  , dotChar
+  , dotText
 
   ) where
 
-
-import Wumpus.Basic.Graphic
+import Wumpus.Basic.Anchors
+import qualified Wumpus.Basic.Dots.Base         as BD
 import Wumpus.Basic.Graphic.DrawingAttr
-import Wumpus.Basic.Graphic.PointSupply
-import Wumpus.Basic.Utils.HList
+import Wumpus.Basic.Monads.Drawing
+import Wumpus.Basic.Utils.Intersection
 
-import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                 -- package: vector-space
-import Data.VectorSpace
+import Data.AffineSpace                         -- package: vector-space
 
--- Marks should be the height of a lower-case letter...
 
--- NOTES
+
+-- An existential thing that supports anchors.
+-- This means any dot can retun the same (opaque) structure
 --
--- 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.
+-- 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 }
 
-dotChar :: Fractional u => Char -> DrawingAttr -> GraphicF u
-dotChar ch = dotText [ch]
+data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW
+  deriving (Eq,Show) 
 
-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) 
+type instance DUnit (DotAnchor u) = u
 
--- | 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]
- 
+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
 
 
--- 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)
+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
 
 
-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)
+circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u
+circleAnchor rad ctr = DotAnchor ctr 
+                                 (\theta -> ctr .+^ (avec theta rad))
+                                 (radialCardinal rad ctr)
 
 
-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)
+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) 
 
 
--- needs horizontal pinch...
+-- Rectangle cardinal points are at \"middles and corners\".
+--
 
-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))
+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) 
 
-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 
+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
-    filled = wrapG . fill (fillAttr attr) . pathDiamond attr
+    fn theta =  maybe ctr id $ findIntersect ctr theta 
+                             $ rectangleLines ctr hw hh
 
 
 
--- | 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
+dotCircle :: (Floating u, FromPtSize u) => ANode u (DotAnchor u)
+dotCircle = AGraphic (BD.dotCircle) mkF
   where
-    hh      = 0.5 * markHeight attr
+    mkF attr pt = circleAnchor (0.5 * markHeight attr) pt
 
- 
 
-dotStar :: Floating u => DrawingAttr -> GraphicF u 
-dotStar attr = \pt -> veloH (fn pt) $ polygonPointsV 5 hh pt
+dotDisk :: (Floating u, FromPtSize u) => ANode u (DotAnchor u)
+dotDisk = AGraphic (BD.dotDisk) mkF
   where
-    hh        = 0.5 * markHeight attr
-    fn pt pt' = wrapG $ cstroke (strokeAttr attr) $ path pt [lineTo pt'] 
-
-
+    mkF attr pt = circleAnchor (0.5 * markHeight attr) pt
 
 
-dotAsterisk :: Floating u => DrawingAttr -> GraphicF u
-dotAsterisk attr = ls1 `cc` ls2 `cc` ls3
+dotSquare :: (Floating u, Real u, FromPtSize u) => ANode u (DotAnchor u)
+dotSquare = AGraphic (BD.dotSquare) mkF
   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)
+    mkF attr pt = let h = markHeight attr in
+                  rectangleAnchor (0.5*h) (0.5*h) pt
 
 
-dotOPlus :: Fractional u
-         => DrawingAttr -> GraphicF u
-dotOPlus attr = dotCircle attr `cc` dotPlus attr
-
+dotChar :: (Floating u, Real u, FromPtSize u) 
+        => Char -> ANode u (DotAnchor u)
+dotChar ch = dotText [ch]
 
-dotOCross :: Floating u => DrawingAttr -> GraphicF u
-dotOCross attr = dotCircle attr `cc` dotCross attr
+dotText :: (Floating u, Real u, FromPtSize u) 
+        => String -> ANode u (DotAnchor u) 
+dotText str = AGraphic (BD.dotText str) mkF
+  where
+    mkF attr pt = let (w,h) = textDimensions str attr in
+                  rectangleAnchor (0.5*w) (0.5*h) pt
 
 
-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/Dots/Base.hs b/src/Wumpus/Basic/Dots/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Dots/Base.hs
@@ -0,0 +1,200 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Dots.Base
+-- 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.Base
+  ( 
+
+
+  -- * 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, FromPtSize u) => Char -> DrawingAttr -> GraphicF u
+dotChar ch = dotText [ch]
+
+dotText :: (Fractional u, FromPtSize 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 = fromPtSize $ 0.5 * numeralHeight sz
+    hw = fromPtSize $ 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, FromPtSize u) => DrawingAttr -> GraphicF u 
+dotHLine attr = let w = markHeight attr in 
+    axialLine (strokeAttr attr) (hvec w)
+    
+
+dotVLine :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u 
+dotVLine attr = let h = markHeight attr in 
+    axialLine (strokeAttr attr) (vvec h)
+
+
+dotX :: (Fractional u, FromPtSize 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, FromPtSize u) => DrawingAttr -> GraphicF u
+dotPlus attr = dotVLine attr `cc` dotHLine attr
+
+
+dotCross :: (Floating u, FromPtSize 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, FromPtSize 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, FromPtSize u) => DrawingAttr -> GraphicF u
+dotDiamond attr = 
+    wrapG . cstroke (strokeAttr attr) . pathDiamond attr
+
+dotFDiamond :: (Fractional u, FromPtSize 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, FromPtSize u) => DrawingAttr -> GraphicF u
+dotDisk attr = disk (fill_colour attr) (0.5*markHeight attr) 
+
+
+dotSquare :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u
+dotSquare attr = let u = markHeight attr in
+     strokedRectangle (strokeAttr attr) u u 
+    
+
+
+dotCircle :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u
+dotCircle attr = disk (strokeAttr attr) (0.5*markHeight attr) 
+
+
+dotPentagon :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u
+dotPentagon attr = 
+    wrapG . cstroke (strokeAttr attr) . vertexPath . polygonPointsV 5 hh
+  where
+    hh      = 0.5 * markHeight attr
+
+ 
+
+dotStar :: (Floating u, FromPtSize 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, FromPtSize 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, FromPtSize u) => DrawingAttr -> GraphicF u
+dotOPlus attr = dotCircle attr `cc` dotPlus attr
+
+
+dotOCross :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u
+dotOCross attr = dotCircle attr `cc` dotCross attr
+
+
+dotFOCross :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u
+dotFOCross attr = dotCircle attr `cc` dotCross attr `cc` bkCircle attr 
+
+bkCircle :: (Fractional u, FromPtSize 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
@@ -28,6 +28,7 @@
   , GraphicF
   , DGraphicF
 
+
   -- * General combinators
   , cc
   , supply
@@ -116,7 +117,8 @@
 -- | Note - a Picture cannot be empty whereas a Graphic can.
 -- Hence this function returns via Maybe.
 --
-drawGraphic :: (Real u, Floating u) => Graphic u -> Maybe (Picture u)
+drawGraphic :: (Real u, Floating u, FromPtSize u) 
+            => Graphic u -> Maybe (Picture u)
 drawGraphic f = post $ f []
   where
     post [] = Nothing
@@ -126,7 +128,7 @@
 -- | /Unsafe/ version of 'drawGraphic' - this function throws 
 -- an error when the graphic is empty.
 --
-drawGraphicU :: (Real u, Floating u) => Graphic u -> Picture u
+drawGraphicU :: (Real u, Floating u, FromPtSize u) => Graphic u -> Picture u
 drawGraphicU = fromMaybe errK . drawGraphic
   where
     errK = error "drawGraphic - empty Graphic."
diff --git a/src/Wumpus/Basic/Graphic/DrawingAttr.hs b/src/Wumpus/Basic/Graphic/DrawingAttr.hs
--- a/src/Wumpus/Basic/Graphic/DrawingAttr.hs
+++ b/src/Wumpus/Basic/Graphic/DrawingAttr.hs
@@ -28,11 +28,21 @@
 
   , textDimensions
 
+  -- * Line widths
+  , thick
+  , ultrathick
+  , thin
+
+  -- * Font properties
+  , fontsize
+  , fontface
+
   ) where
 
 
 import Wumpus.Basic.SafeFonts
 import Wumpus.Basic.SVGColours
+import Wumpus.Basic.Utils.Combinators
 
 import Wumpus.Core                      -- package: wumpus-core
 
@@ -47,8 +57,8 @@
   deriving (Eq,Show)
 
 standardAttr :: FontSize -> DrawingAttr
-standardAttr sz = DrawingAttr { line_width         = 1.0
-                              , font_props         = courier sz
+standardAttr sz = DrawingAttr { line_width         = std_line_width
+                              , font_props         = FontAttr sz courier
                               , stroke_colour      = black
                               , fill_colour        = gold  }
 
@@ -65,15 +75,55 @@
 -- | 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
+markHeight :: FromPtSize u => DrawingAttr -> u
+markHeight = fromPtSize . xcharHeight . font_size . font_props
 
 
 -- | textDimensions : text -> DrawingAttr -> (width,height)
 --
-textDimensions :: Fractional u => String -> DrawingAttr -> (u,u)
+textDimensions :: FromPtSize 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
+    w  = fromPtSize $ textWidth  sz (1 + length str) 
+    h  = fromPtSize $ textHeight sz
+
+
+
+--------------------------------------------------------------------------------
+-- line widths
+
+-- Note - some care might be needed if we ever define other unit 
+-- types...
+
+std_line_width      :: Double
+std_line_width      = 1.0
+
+thick_line          :: Double
+thick_line          = 2.0
+
+ultra_thick_line    :: Double
+ultra_thick_line    = 4.0
+
+thin_line           :: Double
+thin_line           = 0.5
+
+thick               :: DrawingAttr -> DrawingAttr
+thick attr          = attr { line_width = thick_line }
+
+ultrathick          :: DrawingAttr -> DrawingAttr
+ultrathick attr     = attr { line_width = ultra_thick_line }
+
+thin                :: DrawingAttr -> DrawingAttr
+thin attr           = attr { line_width = thin_line }
+
+
+fontface            :: FontFace -> DrawingAttr -> DrawingAttr
+fontface ff         = star (\s i -> s { font_props = upd i }) font_props
+  where
+    upd (FontAttr sz _) = FontAttr sz ff
+
+fontsize            :: Int -> DrawingAttr -> DrawingAttr
+fontsize sz         = star (\s i -> s { font_props = upd i }) font_props
+  where
+    upd (FontAttr _ ff) = FontAttr sz ff
diff --git a/src/Wumpus/Basic/Monads/ConsDrawing.hs b/src/Wumpus/Basic/Monads/ConsDrawing.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Monads/ConsDrawing.hs
+++ /dev/null
@@ -1,178 +0,0 @@
-{-# 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
--- a/src/Wumpus/Basic/Monads/Drawing.hs
+++ b/src/Wumpus/Basic/Monads/Drawing.hs
@@ -12,41 +12,147 @@
 -- Stability   :  unstable
 -- Portability :  GHC 
 --
--- Drawing operations
+-- Graphic types and lifters...
 --
+--
+--
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Monads.Drawing
   (
     
-    MGraphicF 
-  , traceG
+    AGraphic(..)
+  , ANode
+  , AFreeGraphic
+  , AConnector
+
   , node
+  , nodeAt
   , at
+  , liftAFG
+  , connect
+  , connect_
+  , props
+
+  -- doodle
+  , thick
+
   ) where
 
 import Wumpus.Basic.Graphic
+import Wumpus.Basic.Graphic.DrawingAttr
+import Wumpus.Basic.Monads.DrawingCtxClass
 import Wumpus.Basic.Monads.TraceClass
 import Wumpus.Basic.Monads.TurtleClass
 
 import Wumpus.Core                              -- package: wumpus-core
 
+import Control.Applicative
 
-type MGraphicF m u a = Point2 u -> m a
+-- | AGraphic 
+-- 
+-- param typically @Point2 u@ or @()@
+--
+-- If the param is a point it will be supplied by the drawing 
+-- mode / drawing monad (e.g. the Turtle monad which supplies
+-- the current point).
+--
+data AGraphic param u a = AGraphic 
+       { agDrawF    :: DrawingAttr -> param -> Graphic u
+       , agMakeF    :: DrawingAttr -> param -> 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...
+-- | ANode is drawn a a point supplied by the drawing 
+-- (e.g. current node of Turtle).
+--
+type ANode u a = AGraphic (Point2 u) u a
 
-node :: (TraceM m (Primitive u), TurtleScaleM m u, Num u) 
-     => MGraphicF m u a -> m a 
-node mgF = getPos >>= \pt -> mgF pt
+-- /Free/ graphic
+--
+type AFreeGraphic u a = AGraphic () u a
 
+type AConnector u a = Point2 u -> Point2 u -> AFreeGraphic u a
 
-infixr 6 `at` 
+instance Functor (AGraphic pm u) where
+  fmap f (AGraphic df mf) = AGraphic df (\pt attr -> f $ mf pt attr)
 
-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
+instance Applicative (AGraphic pm u) where
+  pure a = AGraphic (\_ _ -> id) (\_ _ -> a)
+  (AGraphic df1 mf1) <*> (AGraphic df2 mf2) = AGraphic df mf
+      where
+        df attr pt   = df2 attr pt . df1 attr pt
+        mf attr pt   = mf1 attr pt $ mf2 attr pt
+
+
+-- This doesn't work like at on MGraphicF, as the point is not 
+-- scaled w.r.t. TurtleScaleM ...
+--
+at :: ANode u a -> Point2 u -> ANode u a
+at (AGraphic df mf) pt = AGraphic (\attr _ -> df attr pt)
+                                  (\attr _ -> mf attr pt)
+
+
+
+-- getPos should be a class method outside of Turtle
+-- those Bivariate context from PSC could implement it...
+
+node :: (Num u, TraceM m u, DrawingCtxM m, TurtleScaleM m u) 
+     => ANode u a -> m a
+node (AGraphic df mf) = 
+    askDrawingCtx >>= \attr ->
+    getPos        >>= \pt   ->
+    trace (df attr pt) >> return (mf attr pt)
+
+nodeAt :: (Num u, TraceM m u, DrawingCtxM m) 
+       => ANode u a -> Point2 u -> m a
+nodeAt (AGraphic df mf) pt = 
+    askDrawingCtx >>= \attr ->
+    trace (df attr pt) >> return (mf attr pt)
+
+
+liftAFG :: (Num u, TraceM m u, DrawingCtxM m) 
+        => AFreeGraphic u a -> m a
+liftAFG (AGraphic df mf) = 
+    askDrawingCtx >>= \attr -> trace (df attr ()) >> return (mf attr ())
+
+
+
+connect :: (Num u, TraceM m u, DrawingCtxM m) 
+        => AConnector u a -> Point2 u -> Point2 u -> m a
+connect conn p1 p2 = let (AGraphic df mf) = conn p1 p2 in  
+    askDrawingCtx >>= \attr -> trace (df attr ()) >> return (mf attr ())
+
+
+-- This is a bit unfortunate - with a connector we can\'t touch
+-- the drawingAttr inside the AGraphic becase a connecter  is
+--
+-- > pt -> pt -> AGraphic
+--
+-- and not
+--
+-- > AGraphic
+--
+--
+-- Maybe AGraphic shouldn\'t have the agAttrF field?
+--
+--
+--
+connect_ :: (Num u, TraceM m u, DrawingCtxM m) 
+         => (DrawingAttr -> DrawingAttr) 
+         -> AConnector u a -> Point2 u -> Point2 u -> m a
+connect_ fn conn p1 p2 = let (AGraphic df mf) = conn p1 p2 in  
+    askDrawingCtx >>= \a0 ->
+    let attr = fn $ a0 in trace (df attr ()) >> return (mf attr ())
+
+
+
+
+infixr 7 `props`
+
+props :: AGraphic pm u a -> (DrawingAttr -> DrawingAttr) -> AGraphic pm u a
+props (AGraphic df mf) upd = AGraphic (\attr p -> df (upd attr) p) 
+                                      (\attr p -> mf (upd attr) p)
+
+
 
diff --git a/src/Wumpus/Basic/Monads/DrawingCtxClass.hs b/src/Wumpus/Basic/Monads/DrawingCtxClass.hs
--- a/src/Wumpus/Basic/Monads/DrawingCtxClass.hs
+++ b/src/Wumpus/Basic/Monads/DrawingCtxClass.hs
@@ -17,34 +17,17 @@
 module Wumpus.Basic.Monads.DrawingCtxClass
   (
 
-  -- * Re-exports from Wumpus.Basic.Graphic.DrawingAttr
-    DrawingAttr(..)
-  , standardAttr
 
   -- * DrawingCtx class
 
-  , DrawingCtxM(..)
+    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
+import Wumpus.Basic.Graphic.DrawingAttr
 
 
--- local to add? or new class...
-
 class Monad m => DrawingCtxM m where
   askDrawingCtx :: m DrawingAttr
   localCtx      :: DrawingAttr -> m a -> m a
@@ -55,20 +38,4 @@
                   => (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
deleted file mode 100644
--- a/src/Wumpus/Basic/Monads/DrawingCtxMonad.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-{-# 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/DrawingMonad.hs b/src/Wumpus/Basic/Monads/DrawingMonad.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Monads/DrawingMonad.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FunctionalDependencies     #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Monads.DrawingMonad
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  unstable
+-- Portability :  GHC 
+--
+-- Drawing with trace and drawing context (i.e. reader monad
+-- of attributes - fill_colour etc.).
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Monads.DrawingMonad
+  (
+    
+    Drawing
+  , DrawingT
+  , runDrawing
+  , execDrawing
+  , runDrawingT
+  , execDrawingT
+
+  , module Wumpus.Basic.Graphic.DrawingAttr
+  , module Wumpus.Basic.Monads.DrawingCtxClass
+  , module Wumpus.Basic.Monads.TraceClass
+
+  ) where
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Graphic.DrawingAttr
+import Wumpus.Basic.Monads.DrawingCtxClass
+import Wumpus.Basic.Monads.TraceClass
+
+
+-- import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+import Control.Monad
+
+
+
+newtype Drawing  u a   = Drawing { 
+          getDrawing :: DrawingAttr -> (a, Graphic u) }
+
+newtype DrawingT u m a = DrawingT { 
+          getDrawingT :: DrawingAttr -> m (a, Graphic u) }
+
+-- Functor
+
+instance Functor (Drawing u) where
+  fmap f ma = Drawing $ \attr -> 
+                let (a,w) = getDrawing ma attr in (f a,w)
+
+
+instance Monad m => Functor (DrawingT u m) where
+  fmap f ma = DrawingT $ \attr -> 
+                getDrawingT ma attr >>= \(a,w) -> return (f a,w)
+
+-- Applicative
+
+instance Applicative (Drawing u) where
+  pure a    = Drawing $ \_    -> (a, emptyG)
+  mf <*> ma = Drawing $ \attr -> let (f,w1) = getDrawing mf attr 
+                                     (a,w2) = getDrawing ma attr
+                                 in (f a, w2 . w1)
+
+instance Monad m => Applicative (DrawingT u m) where
+  pure a    = DrawingT $ \_    -> return (a, emptyG)
+  mf <*> ma = DrawingT $ \attr -> getDrawingT mf attr >>= \(f,w1) ->
+                                  getDrawingT ma attr >>= \(a,w2) ->
+                                  return (f a, w2 . w1)
+
+-- Monad
+
+instance Monad (Drawing u) where
+  return a  = Drawing $ \_    -> (a, emptyG)
+  ma >>= k  = Drawing $ \attr -> let (a,w1) = getDrawing ma attr 
+                                     (b,w2) = (getDrawing . k) a attr
+                                 in (b, w2 . w1)
+
+
+
+instance Monad m => Monad (DrawingT u m) where
+  return a  = DrawingT $ \_    -> return (a, emptyG)
+  ma >>= k  = DrawingT $ \attr -> getDrawingT ma attr      >>= \(a,w1) ->
+                                  (getDrawingT . k) a attr >>= \(b,w2) -> 
+                                  return (b, w2 . w1)
+
+-- TraceM 
+
+instance TraceM (Drawing u) u where
+  trace a = Drawing $ \_ -> ((),a)
+
+instance Monad m => TraceM (DrawingT u m) u where
+  trace a = DrawingT $ \_ -> return ((),a)
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (Drawing u) where
+  askDrawingCtx   = Drawing $ \attr -> (attr,emptyG)
+  localCtx ctx ma = Drawing $ \_    -> getDrawing ma ctx
+
+
+
+instance Monad m => DrawingCtxM (DrawingT u m) where
+  askDrawingCtx   = DrawingT $ \attr -> return (attr,emptyG)
+  localCtx ctx ma = DrawingT $ \_    -> getDrawingT ma ctx
+
+
+
+
+
+runDrawing :: DrawingAttr -> Drawing u a -> (a, Graphic u) 
+runDrawing attr ma = getDrawing ma attr
+
+execDrawing :: DrawingAttr -> Drawing u a -> Graphic u
+execDrawing attr ma = snd $ runDrawing attr ma
+
+runDrawingT :: Monad m => DrawingAttr -> DrawingT u m a -> m (a, Graphic u) 
+runDrawingT attr ma = getDrawingT ma attr
+
+execDrawingT :: Monad m => DrawingAttr -> DrawingT u m a -> m (Graphic u)
+execDrawingT attr ma = liftM snd $ runDrawingT attr ma
diff --git a/src/Wumpus/Basic/Monads/STraceMonad.hs b/src/Wumpus/Basic/Monads/STraceMonad.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Monads/STraceMonad.hs
+++ /dev/null
@@ -1,128 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/src/Wumpus/Basic/Monads/SnocDrawing.hs
+++ /dev/null
@@ -1,175 +0,0 @@
-{-# 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
--- a/src/Wumpus/Basic/Monads/TraceClass.hs
+++ b/src/Wumpus/Basic/Monads/TraceClass.hs
@@ -25,10 +25,9 @@
   ) where
 
 
-import Wumpus.Basic.Utils.HList
+import Wumpus.Basic.Graphic
 
 
-class TraceM  m i | m -> i where
-  trace  :: H i -> m ()
-  trace1 :: i -> m ()
+class TraceM  m u | m -> u where
+  trace  :: Graphic u -> m ()
 
diff --git a/src/Wumpus/Basic/Monads/TraceMonad.hs b/src/Wumpus/Basic/Monads/TraceMonad.hs
deleted file mode 100644
--- a/src/Wumpus/Basic/Monads/TraceMonad.hs
+++ /dev/null
@@ -1,138 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE UndecidableInstances       #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
-{-# OPTIONS -Wall #-}
-
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Wumpus.Basic.Monads.TraceMonad
--- Copyright   :  (c) Stephen Tetley 2010
--- License     :  BSD3
---
--- Maintainer  :  stephen.tetley@gmail.com
--- Stability   :  unstable
--- Portability :  GHC 
---
--- \"Trace\" monad and monad transformer.
---
--- Trace is operationally similar to the Writer monad but it
--- supports elementary consing as well as the Writer\'s monoidal 
--- concatenation. 
---
--- Note, some care is needed to order the output to a trace with
--- respect to the Z-order of a drawing. The API here may well
--- be too limited... 
--- 
---------------------------------------------------------------------------------
-
-module Wumpus.Basic.Monads.TraceMonad
-  (
-
-    Trace
-  , TraceT
-
-  , runTrace
-  , runTraceT
- 
-  ) 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 Trace  i   a = Trace  { getTrace  :: H i -> (a, H i) }
-
-newtype TraceT i m a = TraceT { getTraceT :: H i -> m (a, H i) }
-
--- Functor
-
-instance Functor (Trace i) where
-  fmap f m = Trace $ \w -> let (a,w') = getTrace m w in (f a, w')
-
-instance Monad m => Functor (TraceT i m) where
-  fmap f m = TraceT $ \w -> getTraceT m w >>= \(a,w') ->
-                            return (f a, w')
-
--- Applicative
-
-instance Applicative (Trace i) where
-  pure a    = Trace $ \w -> (a,w)
-  mf <*> ma = Trace $ \w -> let (f,w')  = getTrace mf w 
-                                (a,w'') = getTrace ma w'
-                            in (f a,w'')
-
-
-instance Monad m => Applicative (TraceT i m) where
-  pure a    = TraceT $ \w -> return (a,w)
-  mf <*> ma = TraceT $ \w -> getTraceT mf w  >>= \(f,w')  ->
-                             getTraceT ma w' >>= \(a,w'') ->
-                             return (f a,w'') 
-
--- Monad
-
-instance Monad (Trace i) where
-  return a = Trace $ \w -> (a,w)
-  m >>= k  = Trace $ \w -> let (a,w') = getTrace m w
-                           in (getTrace . k) a w'
-     
-
-
-instance Monad m => Monad (TraceT i m) where
-  return a = TraceT $ \w -> return (a,w)
-  m >>= k  = TraceT $ \w -> getTraceT m w        >>= \(a,w')  ->
-                            (getTraceT . k) a w' >>= \(b,w'') ->
-                            return (b,w'')
-
-
-
-
-instance MonadT (TraceT i) where 
-  lift m = TraceT $ \w -> m >>= \ a -> return (a,w)
-
-
-instance TraceM (Trace i) i where
-  trace  h = Trace $ \w -> ((), h . w)  
-  trace1 i = Trace $ \w -> ((), i `consH` w)  
-
-instance Monad m => TraceM (TraceT i m) i where
-  trace  h = TraceT $ \w -> return ((), h . w)  
-  trace1 i = TraceT $ \w -> return ((), i `consH` w)  
-
-
-
-runTrace :: Trace i a -> (a,H i)
-runTrace mf = getTrace mf id 
-
-runTraceT :: Monad m => TraceT i m a -> m (a,H i)
-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/TurtleMonad.hs b/src/Wumpus/Basic/Monads/TurtleMonad.hs
--- a/src/Wumpus/Basic/Monads/TurtleMonad.hs
+++ b/src/Wumpus/Basic/Monads/TurtleMonad.hs
@@ -35,11 +35,18 @@
   , runTurtle
   , runTurtleT
 
- 
+
+  , TurtleDrawing
+  , runTurtleDrawing
+  , execTurtleDrawing
+
+  , module Wumpus.Basic.Monads.DrawingMonad
+  , module Wumpus.Basic.Monads.TurtleClass
+   
   ) where
 
-import Wumpus.Basic.Monads.DrawingCtxClass
-import Wumpus.Basic.Monads.TraceClass
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Monads.DrawingMonad
 import Wumpus.Basic.Monads.TurtleClass
 
 
@@ -155,7 +162,69 @@
 
 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)
 
 
+--------------------------------------------------------------------------------
+
+newtype TurtleDrawing u a = TurtleDrawing { 
+          getTurtleDrawing :: TurtleT u (Drawing u) a }
+
+instance Functor (TurtleDrawing u) where
+  fmap f = TurtleDrawing . fmap f . getTurtleDrawing
+
+-- Applicative 
+instance Applicative (TurtleDrawing u) where
+  pure a    = TurtleDrawing $ pure a
+  mf <*> ma = TurtleDrawing $ getTurtleDrawing mf <*> getTurtleDrawing ma
+
+
+-- Monad 
+
+instance Monad (TurtleDrawing u) where
+  return a = TurtleDrawing $ return a
+  m >>= k  = TurtleDrawing $ getTurtleDrawing m >>= (getTurtleDrawing . k)
+
+-- TurtleM
+
+instance TurtleM (TurtleDrawing u) where
+  getLoc      = TurtleDrawing $ getLoc 
+  setLoc c    = TurtleDrawing $ setLoc c
+  getOrigin   = TurtleDrawing $ getOrigin
+  setOrigin o = TurtleDrawing $ setOrigin o
+
+instance TurtleScaleM (TurtleDrawing u) u where
+  xStep    = TurtleDrawing $ xStep
+  yStep    = TurtleDrawing $ yStep
+
+-- TraceM 
+
+instance TraceM (TurtleDrawing u) u where
+  trace a = TurtleDrawing $ lift (trace a)
+
+
+-- DrawingCtxM
+
+instance DrawingCtxM (TurtleDrawing u) where
+  askDrawingCtx   = TurtleDrawing $ lift askDrawingCtx
+  localCtx ctx ma = TurtleDrawing $ localCtx ctx (getTurtleDrawing ma)
+
+
+runTurtleDrawing :: Num u 
+                 => TurtleConfig u 
+                 -> (Int,Int)
+                 -> DrawingAttr 
+                 -> TurtleDrawing u a 
+                 -> (a, Graphic u)
+runTurtleDrawing cfg ogin attr mf = 
+    runDrawing attr ( runTurtleT cfg ogin $ getTurtleDrawing mf)
+
+
+execTurtleDrawing :: Num u 
+                  => TurtleConfig u
+                  -> (Int,Int) 
+                  -> DrawingAttr 
+                  -> TurtleDrawing u a 
+                  -> Graphic u
+execTurtleDrawing cfg ogin attr mf = 
+    snd $ runTurtleDrawing cfg ogin attr mf
 
diff --git a/src/Wumpus/Basic/Paths.hs b/src/Wumpus/Basic/Paths.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Paths.hs
@@ -0,0 +1,165 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Paths
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Extended path type - more amenable for complex drawings than
+-- the type in Wumpus-Core.
+--
+-- \*\* WARNING \*\* this module is an experiment, and may 
+-- change significantly or even be dropped from future revisions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Paths 
+  ( 
+
+    connectS
+  , pathGraphic
+
+  , shorten
+  , shortenL
+  , shortenR
+  , midpoint
+  , directionL
+  , directionR
+
+  ) where
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Graphic.DrawingAttr
+import Wumpus.Basic.Paths.Base
+import Wumpus.Basic.Paths.Construction
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Data.Sequence
+
+
+
+connectS :: Floating u => BPathF u
+connectS = \p0 p1 -> execPath p0 $ lineto p1
+
+
+
+-- This one might be more useful...
+
+pathGraphic :: Num u => BPath u -> DrawingAttr -> Graphic u
+pathGraphic bpath attr = wrapG $ ostroke (strokeAttr attr) $ toPathU bpath
+
+
+
+
+shorten  :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u
+shorten u p = shortenL u $ shortenR u p
+
+--------------------------------------------------------------------------------
+-- shorten from the left...
+
+shortenL :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u
+shortenL n (BPath u bp) | n >= u         = emptyPath
+                        | otherwise      = step n (viewl bp)
+  where
+    step _ EmptyL     = emptyPath
+    step d (e :< se)  = let z = segmentLength e in
+                        case compare d z of
+                          GT -> step (d-z) (viewl se)
+                          EQ -> BPath (u-n) se
+                          _  -> BPath (u-n) (shortenSegL d e <| se)
+
+
+shortenSegL :: (Real u, Floating u) => u -> BPathSeg u -> BPathSeg u
+shortenSegL n (BLineSeg  u l) = BLineSeg  (u-n) (shortenLineL n l) 
+shortenSegL n (BCurveSeg u c) = BCurveSeg (u-n) (snd $ subdividet (n/u) c)
+
+shortenLineL :: (Real u, Floating u) => u -> Line u -> Line u
+shortenLineL n (Line p1 p2) = Line (p1 .+^ v) p2
+  where
+    v0 = p2 .-. p1
+    v  = avec (direction v0) n
+    
+--------------------------------------------------------------------------------
+-- shorten from the right ...
+ 
+shortenR :: (Real u, Floating u, Ord u) => u -> BPath u -> BPath u
+shortenR n (BPath u bp) | n >= u         = emptyPath
+                        | otherwise      = step n (viewr bp)
+  where
+    step _ EmptyR     = emptyPath
+    step d (se :> e)  = let z = segmentLength e in
+                        case compare d z of
+                          GT -> step (d-z) (viewr se)
+                          EQ -> BPath (u-n) se
+                          _  -> BPath (u-n) (se |> shortenSegR d e)
+
+
+
+shortenSegR :: (Real u, Floating u) => u -> BPathSeg u -> BPathSeg u
+shortenSegR n (BLineSeg  u l) = BLineSeg  (u-n) (shortenLineR n l) 
+shortenSegR n (BCurveSeg u c) = BCurveSeg (u-n) (fst $ subdividet ((u-n)/u) c)
+
+
+shortenLineR :: (Real u, Floating u) => u -> Line u -> Line u
+shortenLineR n (Line p1 p2) = Line p1 (p2 .+^ v)
+  where
+    v0 = p1 .-. p2
+    v  = avec (direction v0) n
+
+
+
+--------------------------------------------------------------------------------
+
+midpoint :: (Real u, Floating u) => BPath u -> Point2 u
+midpoint (BPath u bp) = step (u/2) (viewl bp)
+  where
+    step _ EmptyL    = zeroPt
+    step d (e :< se) = let z = segmentLength e in
+                       case compare d z of
+                         GT -> step (d-z) (viewl se)
+                         EQ -> segmentEnd e
+                         _  -> segmentEnd $ shortenSegL d e 
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- tangents
+
+
+directionL :: (Real u, Floating u) => BPath u -> Radian
+directionL (BPath _ se) = step $ viewl se
+  where
+    step (BLineSeg  _ l :< _) = lineDirectionL l 
+    step (BCurveSeg _ c :< _) = curveDirectionL c
+    step _                    = 0
+
+directionR :: (Real u, Floating u) => BPath u -> Radian
+directionR (BPath _ se) = step $ viewr se
+  where
+    step (_ :> BLineSeg  _ l) = lineDirectionR l 
+    step (_ :> BCurveSeg _ c) = curveDirectionR c
+    step _                    = 0
+
+
+lineDirectionL :: (Real u, Floating u) => Line u -> Radian
+lineDirectionL (Line p0 p1) = direction (pvec p1 p0)
+
+lineDirectionR :: (Real u, Floating u) => Line u -> Radian
+lineDirectionR (Line p0 p1) = direction (pvec p0 p1)
+
+curveDirectionL :: (Real u, Floating u) => Curve u -> Radian
+curveDirectionL (Curve p0 p1 _ _) = direction $ pvec p1 p0
+
+curveDirectionR :: (Real u, Floating u) => Curve u -> Radian
+curveDirectionR (Curve _ _ p2 p3) = direction $ pvec p2 p3
+ 
diff --git a/src/Wumpus/Basic/Paths/Base.hs b/src/Wumpus/Basic/Paths/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Paths/Base.hs
@@ -0,0 +1,216 @@
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Paths.Base
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Extended path type - more amenable for complex drawings than
+-- the type in Wumpus-Core.
+--
+-- \*\* WARNING \*\* this module is an experiment, and may 
+-- change significantly or even be dropped from future revisions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Paths.Base
+  ( 
+
+    BPathF
+
+  , BPath(..)
+  , BPathSeg(..)
+  , Curve(..)
+  , Line(..)
+  , emptyPath
+  , pline
+  , pcurve
+  , addSegment
+  , segmentLength
+  , segmentStart
+  , segmentEnd
+
+  , toPath 
+  , toPathU
+  , subdivide
+  , subdividet
+    
+  ) where
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace
+import Data.VectorSpace
+
+import Data.Maybe
+import Data.Sequence ( Seq, ViewL(..), viewl, (|>)  )
+import qualified Data.Sequence as S
+
+
+type BPathF u = Point2 u -> Point2 u -> BPath u
+
+
+data BPath u = BPath 
+       { path_length    :: u 
+       , path_elements  :: Seq (BPathSeg u)
+       }
+  deriving (Eq,Ord,Show)
+
+
+-- Annotation is length...
+-- 
+data BPathSeg u = BLineSeg  u (Line u)
+                | BCurveSeg u (Curve u)
+  deriving (Eq,Ord,Show)
+
+
+data Curve u = Curve 
+      { curve_start :: Point2 u
+      , ctrl_point1 :: Point2 u
+      , ctrl_point2 :: Point2 u
+      , curve_end   :: Point2 u
+      }
+  deriving (Eq,Ord,Show)
+
+data Line u = Line 
+      { line_start  :: Point2 u
+      , line_end    :: Point2 u 
+      }
+  deriving (Eq,Ord,Show)
+
+
+emptyPath :: Num u => BPath u 
+emptyPath = BPath 0 S.empty
+
+
+addSegment :: Num u => BPath u -> BPathSeg u -> BPath u
+addSegment (BPath n se) e@(BLineSeg u _)  = BPath (n+u) (se |> e)
+addSegment (BPath n se) e@(BCurveSeg u _) = BPath (n+u) (se |> e)
+
+segmentLength :: BPathSeg u -> u
+segmentLength (BLineSeg  u _) = u
+segmentLength (BCurveSeg u _) = u
+
+segmentStart :: BPathSeg u -> Point2 u
+segmentStart (BLineSeg  _ (Line p0 _))      = p0
+segmentStart (BCurveSeg _ (Curve p0 _ _ _)) = p0
+
+segmentEnd :: BPathSeg u -> Point2 u
+segmentEnd (BLineSeg  _ (Line _ p1))      = p1
+segmentEnd (BCurveSeg _ (Curve _ _ _ p3)) = p3
+
+
+
+
+pline :: Floating u => Point2 u -> Point2 u -> BPathSeg u 
+pline p0 p1 = BLineSeg (vlength $ pvec p0 p1) (Line p0 p1)
+
+pcurve :: (Floating u, Ord u)
+       => Point2 u -> Point2 u -> Point2 u -> Point2 u -> BPathSeg u 
+pcurve p0 p1 p2 p3 = 
+    let c = Curve p0 p1 p2 p3 in BCurveSeg (curveLength c) c
+
+
+-- | Turn a BasicPath into an ordinary Path.
+--
+-- An empty path returns Nothing - the path representation in 
+-- Wumpus-Core does not allow empty paths - a path must always
+-- have at least start point.
+--
+-- Assumes path is properly formed - i.e. end point of one 
+-- segment is the same point as the start point of the next
+-- segment.
+--
+toPath :: BPath u -> Maybe (Path u)
+toPath = step1 . viewl . path_elements
+  where
+    step1 EmptyL               = Nothing
+    step1 (e :< se)            = let (p1,s) = elemP e in 
+                                 Just $ path p1 $ s : step2 (viewl se)
+
+    step2 EmptyL               = []
+    step2 (e :< se)            = snd (elemP e) : step2 (viewl se)
+    
+    elemP (BLineSeg  _ l)      = elemL l
+    elemP (BCurveSeg _ c)      = elemC c
+ 
+    elemL (Line p1 p2)         = (p1, lineTo p2)
+    elemC (Curve p1 p2 p3 p4)  = (p1, curveTo p2 p3 p4)
+
+toPathU :: BPath u -> Path u
+toPathU = fromMaybe errK . toPath
+  where
+    errK = error "toPathU - empty Path"
+
+
+
+--------------------------------------------------------------------------------
+-- Curve length
+
+curveLength :: (Floating u, Ord u) => Curve u -> u
+curveLength = gravesenLength 0.1
+
+-- | Jens Gravesen\'s bezier arc-length approximation. 
+--
+-- Note this implementation is parametrized on error tolerance.
+--
+gravesenLength :: (Floating u, Ord u) => u -> Curve u -> u
+gravesenLength err_tol crv = step crv where
+  step c = let l1 = ctrlPolyLength c
+               l0 = cordLength c
+           in if   l1-l0 > err_tol
+              then let (a,b) = subdivide c in step a + step b
+              else 0.5*l0 + 0.5*l1
+
+
+ctrlPolyLength :: Floating u => Curve u -> u
+ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3
+  where
+    len pa pb = vlength $ pvec pa pb
+
+cordLength :: Floating u => Curve u -> u
+cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3
+
+
+-- | midpoint between two points
+--
+pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
+pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0
+
+
+-- | Curve subdivision via de Casteljau\'s algorithm.
+--
+subdivide :: Fractional u => Curve u -> (Curve u, Curve u)
+subdivide (Curve p0 p1 p2 p3) =
+    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)
+  where
+    p01   = pointMidpoint p0    p1
+    p12   = pointMidpoint p1    p2
+    p23   = pointMidpoint p2    p3
+    p012  = pointMidpoint p01   p12
+    p123  = pointMidpoint p12   p23
+    p0123 = pointMidpoint p012  p123
+
+-- | subdivide with an affine weight along the line...
+--
+subdividet :: Real u
+           => u -> Curve u -> (Curve u, Curve u)
+subdividet t (Curve p0 p1 p2 p3) = 
+    (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3)
+  where
+    p01   = affineCombination t p0    p1
+    p12   = affineCombination t p1    p2
+    p23   = affineCombination t p2    p3
+    p012  = affineCombination t p01   p12
+    p123  = affineCombination t p12   p23
+    p0123 = affineCombination t p012  p123
+
+affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u
+affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1)
+
diff --git a/src/Wumpus/Basic/Paths/Construction.hs b/src/Wumpus/Basic/Paths/Construction.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Paths/Construction.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE FlexibleContexts           #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Paths.Construction
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Build paths.
+--
+-- \*\* WARNING \*\* this module is an experiment, and may 
+-- change significantly or even be dropped from future revisions.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Paths.Construction
+  ( 
+
+    MPath
+  , CPath
+  , runPath
+  , execPath
+  , lineto
+  , bezierto
+  , curveto
+  , verticalHorizontal
+  , horizontalVertical
+
+  ) where
+
+import Wumpus.Basic.Paths.Base
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Control.Applicative
+
+data PathState u = PathState 
+      { current_point :: Point2 u 
+      , path_accum    :: BPath u
+      }
+
+newtype MPath u a = MPath { getMPath :: PathState u -> (a,PathState u) }
+
+type CPath u = MPath u ()
+
+instance Functor (MPath u) where
+  fmap f mf = MPath $ \s -> let (a,s') = getMPath mf s in (f a,s')
+
+
+instance Applicative (MPath u) where
+  pure a    = MPath $ \s -> (a,s)
+  mf <*> ma = MPath $ \s -> let (f,s')  = getMPath mf s
+                                (a,s'') = getMPath ma s'
+                            in (f a,s'')
+
+instance Monad (MPath u) where
+  return a  = MPath $ \s -> (a,s)
+  m >>= k   = MPath $ \s -> let (a,s') = getMPath m s in
+                            (getMPath . k) a s'
+
+
+runPath :: Num u => Point2 u -> MPath u a -> (a, BPath u)
+runPath start mf = let (a,s') = getMPath mf s in (a, path_accum s')
+  where
+    s = PathState { current_point = start
+                  , path_accum    = emptyPath
+                  }
+
+execPath :: Num u => Point2 u -> MPath u a -> BPath u
+execPath start mf = snd $ runPath start mf
+
+
+exchTip :: Point2 u -> (Point2 u -> BPath u -> BPath u) -> MPath u ()
+exchTip new updP = 
+    MPath $ \(PathState old bp) -> ((), PathState new (updP old bp)) 
+
+tip :: MPath u (Point2 u)
+tip = MPath $ \s -> (current_point s,s)
+
+
+lineto :: Floating u => Point2 u -> CPath u
+lineto end = exchTip end upd
+  where
+    upd start bp = bp `addSegment` pline start end
+
+
+
+bezierto :: (Floating u, Ord u) 
+         => Point2 u -> Point2 u -> Point2 u -> CPath u
+bezierto cp1 cp2 end = exchTip end upd 
+  where
+    upd start bp = bp `addSegment` pcurve start cp1 cp2 end
+
+
+curveto :: (Floating u, Ord u) 
+        => Radian -> Radian -> Point2 u -> CPath u
+curveto cin cout end = exchTip end upd
+  where 
+    upd start bp = bp `addSegment` pcurveAng start cin cout end
+
+
+pcurveAng :: (Floating u, Ord u) 
+        => Point2 u -> Radian -> Radian -> Point2 u -> BPathSeg u
+pcurveAng start cin cout end = pcurve start (start .+^ v1) (end .+^ v2) end
+  where
+    sz     = 0.375 * (vlength $ pvec start end)
+    v1     = avec cin  sz
+    v2     = avec cout sz
+
+
+verticalHorizontal :: Floating u => Point2 u -> CPath u
+verticalHorizontal (P2 x y) = 
+    tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y)
+
+horizontalVertical :: Floating u => Point2 u -> CPath u
+horizontalVertical (P2 x y) = 
+    tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y)
diff --git a/src/Wumpus/Basic/SafeFonts.hs b/src/Wumpus/Basic/SafeFonts.hs
--- a/src/Wumpus/Basic/SafeFonts.hs
+++ b/src/Wumpus/Basic/SafeFonts.hs
@@ -56,74 +56,74 @@
 --------------------------------------------------------------------------------
 -- Times-Roman
 
-timesRoman :: Int -> FontAttr
-timesRoman = FontAttr "Times-Roman" "Times New Roman" SVG_REGULAR
+timesRoman :: FontFace
+timesRoman = FontFace "Times-Roman" "Times New Roman" SVG_REGULAR
 
 -- Times Italic
 
-timesItalic :: Int -> FontAttr
-timesItalic = FontAttr "Times-Italic" "Times New Roman" SVG_ITALIC
+timesItalic :: FontFace
+timesItalic = FontFace "Times-Italic" "Times New Roman" SVG_ITALIC
 
 -- Times Bold
 
-timesBold :: Int -> FontAttr
-timesBold = FontAttr "Times-Bold" "Times New Roman" SVG_BOLD
+timesBold :: FontFace
+timesBold = FontFace "Times-Bold" "Times New Roman" SVG_BOLD
 
 -- Times Bold Italic
 
-timesBoldItalic :: Int -> FontAttr
+timesBoldItalic :: FontFace
 timesBoldItalic = 
-    FontAttr "Times-BoldItalic" "Times New Roman" SVG_BOLD_ITALIC
+    FontFace "Times-BoldItalic" "Times New Roman" SVG_BOLD_ITALIC
 
 
 --------------------------------------------------------------------------------
 -- Helvetica
 
-helvetica :: Int -> FontAttr
-helvetica = FontAttr "Helvetica" "Helvetica" SVG_REGULAR
+helvetica :: FontFace
+helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR
 
 
 -- Helvetica Oblique
 
-helveticaOblique :: Int -> FontAttr
-helveticaOblique = FontAttr "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE
+helveticaOblique :: FontFace
+helveticaOblique = FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE
 
 -- Helvetica Bold
 
-helveticaBold :: Int -> FontAttr
-helveticaBold = FontAttr "Helvetica-Bold" "Helvetica" SVG_BOLD
+helveticaBold :: FontFace
+helveticaBold = FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD
 
 
 -- Helvetica Bold Oblique
 
-helveticaBoldOblique :: Int -> FontAttr
+helveticaBoldOblique :: FontFace
 helveticaBoldOblique = 
-    FontAttr "Helvetica-Bold-Oblique" "Helvetica" SVG_BOLD_OBLIQUE
+    FontFace "Helvetica-Bold-Oblique" "Helvetica" SVG_BOLD_OBLIQUE
 
 
 
 --------------------------------------------------------------------------------
 -- Courier
 
-courier :: Int -> FontAttr
-courier = FontAttr "Courier" "Courier New" SVG_REGULAR
+courier :: FontFace
+courier = FontFace "Courier" "Courier New" SVG_REGULAR
 
 -- Courier Oblique
 
-courierOblique :: Int -> FontAttr
-courierOblique = FontAttr "Courier-Oblique" "Courier New" SVG_OBLIQUE
+courierOblique :: FontFace
+courierOblique = FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE
 
 -- Courier Bold
 
-courierBold :: Int -> FontAttr
-courierBold = FontAttr "Courier-Bold" "Courier New" SVG_BOLD
+courierBold :: FontFace
+courierBold = FontFace "Courier-Bold" "Courier New" SVG_BOLD
 
 
 -- Courier Bold Oblique
 
-courierBoldOblique :: Int -> FontAttr
+courierBoldOblique :: FontFace
 courierBoldOblique = 
-    FontAttr "Courier-Bold-Oblique" "Courier New" SVG_BOLD_OBLIQUE
+    FontFace "Courier-Bold-Oblique" "Courier New" SVG_BOLD_OBLIQUE
 
 --------------------------------------------------------------------------------
 -- Symbol
@@ -132,8 +132,8 @@
 -- Symbol does not appear to be well supported by SVG.
 -- It renders in Chrome but not in Firefox.
 
-symbol :: Int -> FontAttr
-symbol = FontAttr "Symbol" "Symbol" SVG_REGULAR
+symbol :: FontFace
+symbol = FontFace "Symbol" "Symbol" SVG_REGULAR
 
 
 
diff --git a/src/Wumpus/Basic/Text/LRSymbol.hs b/src/Wumpus/Basic/Text/LRSymbol.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Text/LRSymbol.hs
@@ -0,0 +1,203 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Text.LRSymbol
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Named literals from Symbol font, drawn with the LRText monad.
+-- 
+-- Note - currently the techinique used here generates adequate
+-- PostScript, but very ineficient SVG.
+-- 
+-- Also uUpsilon is not mapped to the correct character...
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Text.LRSymbol
+  ( 
+
+  -- * Lower case
+
+    alpha
+  , beta
+  , gamma
+  , delta
+  , epsilon
+  , zeta
+  , eta
+  , theta
+  , iota
+  , kappa
+  , lambda
+  , mu
+  , nu
+  , xi
+  , pi
+  , rho
+  , sigma
+  , tau
+  , upsilon
+  , phi
+  , chi
+  , psi
+  , omega
+
+  -- * Upper case
+  , uGamma
+  , uDelta
+  , uTheta
+  , uLambda
+  , uXi
+  , uPi
+  , uSigma
+  , uUpsilon
+  , uPhi
+  , uPsi
+  , uOmega
+
+  ) where
+
+
+import Wumpus.Basic.SafeFonts
+import Wumpus.Basic.Text.LRText
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.Char ( chr )
+import Prelude hiding ( pi )
+
+-- Note - due to a optimization in Wumpus-Core, the PostScript
+-- generated by the techinique here - writing a 
+-- (single-character) label one at a time - isn\'t too bad as 
+-- Wumpus-Core only issues a findfont command when the font 
+-- changes. 
+-- 
+-- However for SVG the result is very poor - one text element 
+-- including an orientation changing matrix transforming for 
+-- each character.
+-- 
+-- Wumpus-Core\'s SVG rendering will work at some point.
+-- 
+
+useSymbol :: TextM u a -> TextM u a
+useSymbol = bracketFontFace symbol
+
+
+--------------------------------------------------------------------------------
+-- lower case
+
+
+alpha       :: (Num u, FromPtSize u) => TextM u ()
+alpha       = useSymbol $ char 'a'
+
+beta        :: (Num u, FromPtSize u) => TextM u ()
+beta        = useSymbol $ char 'b'
+
+gamma       :: (Num u, FromPtSize u) => TextM u ()
+gamma       = useSymbol $ char 'g'
+
+delta       :: (Num u, FromPtSize u) => TextM u ()
+delta       = useSymbol $ char 'd'
+
+epsilon     :: (Num u, FromPtSize u) => TextM u ()
+epsilon     = useSymbol $ char 'e'
+
+zeta        :: (Num u, FromPtSize u) => TextM u ()
+zeta        = useSymbol $ char 'z'
+
+eta         :: (Num u, FromPtSize u) => TextM u ()
+eta         = useSymbol $ char 'h'
+
+theta       :: (Num u, FromPtSize u) => TextM u ()
+theta       = useSymbol $ char 'q'
+
+iota        :: (Num u, FromPtSize u) => TextM u ()
+iota        = useSymbol $ char 'i'
+
+kappa       :: (Num u, FromPtSize u) => TextM u ()
+kappa       = useSymbol $ char 'k'
+
+lambda      :: (Num u, FromPtSize u) => TextM u ()
+lambda      = useSymbol $ char 'l'
+
+mu          :: (Num u, FromPtSize u) => TextM u ()
+mu          = useSymbol $ char 'm'
+
+nu          :: (Num u, FromPtSize u) => TextM u ()
+nu          = useSymbol $ char 'n'
+
+xi          :: (Num u, FromPtSize u) => TextM u ()
+xi          = useSymbol $ char 'x'
+
+pi          :: (Num u, FromPtSize u) => TextM u ()
+pi          = useSymbol $ char 'p'
+
+rho         :: (Num u, FromPtSize u) => TextM u ()
+rho         = useSymbol $ char 'r'
+
+sigma       :: (Num u, FromPtSize u) => TextM u ()
+sigma       = useSymbol $ char 's'
+
+tau         :: (Num u, FromPtSize u) => TextM u ()
+tau         = useSymbol $ char 't'
+
+upsilon     :: (Num u, FromPtSize u) => TextM u ()
+upsilon     = useSymbol $ char 'u'
+
+phi         :: (Num u, FromPtSize u) => TextM u ()
+phi         = useSymbol $ char 'j'
+
+chi         :: (Num u, FromPtSize u) => TextM u ()
+chi         = useSymbol $ char 'c'
+
+psi         :: (Num u, FromPtSize u) => TextM u ()
+psi         = useSymbol $ char 'y'
+
+omega       :: (Num u, FromPtSize u) => TextM u ()
+omega       = useSymbol $ char 'w'
+
+
+--------------------------------------------------------------------------------
+-- upper case
+
+uGamma      :: (Num u, FromPtSize u) => TextM u ()
+uGamma      = useSymbol $ char 'G'
+
+uDelta      :: (Num u, FromPtSize u) => TextM u ()
+uDelta      = useSymbol $ char 'D'
+
+uTheta      :: (Num u, FromPtSize u) => TextM u ()
+uTheta      = useSymbol $ char 'Q'
+
+uLambda     :: (Num u, FromPtSize u) => TextM u ()
+uLambda     = useSymbol $ char 'L'
+
+uXi         :: (Num u, FromPtSize u) => TextM u ()
+uXi         = useSymbol $ char 'X'
+
+uPi         :: (Num u, FromPtSize u) => TextM u ()
+uPi         = useSymbol $ char 'P'
+
+uSigma      :: (Num u, FromPtSize u) => TextM u ()
+uSigma      = useSymbol $ char 'S'
+
+-- | Not working, though 161 should be uUpsilon.
+--
+uUpsilon    :: (Num u, FromPtSize u) => TextM u ()
+uUpsilon    = useSymbol $ char $ chr 161
+
+uPhi        :: (Num u, FromPtSize u) => TextM u ()
+uPhi        = useSymbol $ char 'F'
+
+uPsi        :: (Num u, FromPtSize u) => TextM u ()
+uPsi        = useSymbol $ char 'Y'
+
+uOmega      :: (Num u, FromPtSize u) => TextM u ()
+uOmega      = useSymbol $ char 'W'
+
diff --git a/src/Wumpus/Basic/Text/LRText.hs b/src/Wumpus/Basic/Text/LRText.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Text/LRText.hs
@@ -0,0 +1,189 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Text.LRText
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- LRText monad - left-to-right text.
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Text.LRText
+  ( 
+    TextM
+  , runTextM
+
+  , text
+  , char
+  , kern
+  , newline
+  , bracketFontFace
+
+  ) where
+
+
+import Wumpus.Basic.Graphic
+import Wumpus.Basic.Utils.Combinators
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Control.Applicative
+
+-- Need a note in wumpus-core and here about space:preserve
+
+
+-- Graphic or GraphicF ? ans. GraphicF
+
+-- Note - should be compatible with free-label and shape labels.
+-- This seems to favour GraphicF.
+
+-- Not quite the same as a trace monad because it needs the 
+-- result to a function \"from Point -> ... \"
+
+
+data Idx = Idx { idx_x :: !Int, idx_y :: !Int }
+  deriving (Eq,Ord,Show)
+
+
+rightn      :: Int -> Idx -> Idx 
+rightn n    = star (\s i -> s { idx_x = i+n }) idx_x
+
+down1       :: Idx -> Idx 
+down1       = star (\s i -> s { idx_y = i-1, idx_x =0 }) idx_y
+
+-- can track the /user vectors so far/ in the state...
+
+
+data St u = St 
+      { xy_pos          :: Idx
+      , font_desc       :: FontAttr
+      , horizontal_disp :: PtSize
+      , acc_graphic     :: TGraphicF u
+      }
+
+-- Vertical distance between baselines.
+type VDist = PtSize       
+
+type Env = (VDist, DRGB)
+
+newtype TextM u a = TextM { getTextM :: Env -> St u -> (a, St u) }
+
+-- wrap GraphicF as it has /special/ construction.
+--
+newtype TGraphicF u = TGraphicF { getTGraphicF :: GraphicF u }
+
+consT :: Num u => (Vec2 u, GraphicF u) -> TGraphicF u -> TGraphicF u
+consT (V2 x y, f) tg = TGraphicF $ (f . disp x y) `cc` (getTGraphicF tg) 
+
+
+instance Functor (TextM u) where
+  fmap f mf = TextM $ \r s -> let (a,s') = getTextM mf r s in (f a,s')
+
+instance Applicative (TextM u) where
+  pure a    = TextM $ \_ s -> (a,s)
+  mf <*> ma = TextM $ \r s -> let (f,s')  = getTextM mf r s
+                                  (a,s'') = getTextM ma r s'
+                              in (f a,s'')
+
+instance Monad (TextM u) where
+  return a  = TextM $ \_ s -> (a,s)
+  m >>= k   = TextM $ \r s -> let (a,s')  = getTextM m r s 
+                              in (getTextM . k) a r s'
+                              
+-- Note - post has to displace in the vertical to get the bottom 
+-- line at the base line...
+
+runTextM :: (Num u, FromPtSize u) 
+         => PtSize -> (DRGB,FontAttr) -> (TextM u a) -> (a,GraphicF u)
+runTextM vdistance (rgb,font) ma = post $ getTextM ma env st
+  where
+    post (a,s)  = let gf = getTGraphicF $ acc_graphic s
+                      h  = fromIntegral $ idx_y $ xy_pos s
+                  in (a, gf . vdisp (negate $ h * fromPtSize vdistance))
+
+    env         = (vdistance,rgb) 
+
+    st          = St { xy_pos          = Idx 0 0 
+                     , font_desc       = font
+                     , horizontal_disp = 0
+                     , acc_graphic     = TGraphicF (const emptyG) }
+
+
+--------------------------------------------------------------------------------
+-- State monad ops.
+-- Note - not all the state should be accessible. 
+
+setFontAttr :: FontAttr -> TextM u ()
+setFontAttr fa = TextM $ \_ s -> ((), s { font_desc = fa })
+
+setsFontAttr :: (FontAttr -> FontAttr) -> TextM u ()
+setsFontAttr fn = TextM $ \_ st -> ((), upd st) 
+  where
+    upd = star (\s i -> s { font_desc = fn i} ) font_desc
+
+getFontAttr :: TextM u FontAttr
+getFontAttr = TextM $ \_ s -> (font_desc s,s)   
+
+
+--------------------------------------------------------------------------------
+
+makeDisplacement :: (Num u, FromPtSize u) 
+                 => FontSize -> PtSize -> PtSize -> Idx -> (Vec2 u)
+makeDisplacement font_sz lefth vdist (Idx x y) = 
+    vec (txt_width + fromPtSize lefth)   
+        (fromPtSize vdist * fromIntegral y)
+  where
+    txt_width = fromPtSize $ textWidth font_sz x
+
+
+text :: (Num u, FromPtSize u) => String -> TextM u ()
+text str = TextM $ \r s -> ((), upd r s)
+  where
+    upd (vdist,rgb) s@(St idx font h acc) = 
+        let g1  = textline (rgb,font) str 
+            v   = makeDisplacement (font_size font) h vdist idx
+        in s { xy_pos      = rightn (length str) idx
+             , acc_graphic = (v,g1) `consT` acc      }
+
+
+char :: (Num u, FromPtSize u) => Char -> TextM u ()
+char ch = TextM $ \r s -> ((), upd r s)
+  where
+    upd (vdist,rgb) s@(St idx font h acc) = 
+        let g1  = textline (rgb,font) [ch] 
+            v   = makeDisplacement (font_size font) h vdist idx
+        in s { xy_pos      = rightn 1 idx
+             , acc_graphic = (v,g1) `consT` acc }
+
+
+kern :: (Num u, FromPtSize u) => PtSize ->  TextM u ()
+kern h = TextM $ \_ s -> ((), upd s)
+  where
+    upd = star (\s i -> s { horizontal_disp = i + h }) horizontal_disp
+
+
+
+
+newline :: TextM u ()
+newline = TextM $ \_ s -> ((), upd s)
+  where
+    upd = star (\s idx -> s { xy_pos = down1 idx, horizontal_disp = 0})
+               xy_pos
+
+
+
+bracketFontFace :: FontFace -> TextM u a -> TextM u a
+bracketFontFace face mf = do
+    old <- getFontAttr
+    setsFontAttr fn
+    ans <- mf 
+    setFontAttr old 
+    return ans
+  where
+    fn attr = attr { font_face = face }
diff --git a/src/Wumpus/Basic/Utils/Combinators.hs b/src/Wumpus/Basic/Utils/Combinators.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Utils/Combinators.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Utils.Combinators
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Combinators...
+-- 
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Utils.Combinators
+  ( 
+
+  -- * Starlings...
+    star
+  , star2
+  , star3
+  , star4 
+
+  ) where
+
+-- starlings...
+
+-- Note - this is the correct argument order for a starling.
+-- I\'ve used these combinators elsewhere with arguments of the
+-- \"combiner\" in the wrong order.
+
+star     :: (r -> a -> ans) 
+         -> (r -> a) 
+         -> r -> ans
+star f fa x = f x (fa x)
+
+star2    :: (r -> a -> b -> ans) 
+         -> (r -> a) 
+         -> (r -> b) 
+         -> r -> ans
+star2 f fa fb x = f x (fa x) (fb x)
+
+star3    :: (r -> a -> b -> c -> ans) 
+         -> (r -> a) 
+         -> (r -> b) 
+         -> (r -> c) 
+         -> r -> ans
+star3 f fa fb fc x = f x (fa x) (fb x) (fc x)
+
+star4    :: (r -> a -> b -> c -> d -> ans) 
+         -> (r -> a) 
+         -> (r -> b) 
+         -> (r -> c)
+         -> (r -> d) 
+         -> r -> ans
+star4 f fa fb fc fd x = f x (fa x) (fb x) (fc x) (fd x)
+
+
diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs
--- a/src/Wumpus/Basic/VersionNumber.hs
+++ b/src/Wumpus/Basic/VersionNumber.hs
@@ -23,7 +23,7 @@
 
 -- | Version number
 --
--- > (0,3,0)
+-- > (0,4,0)
 --
 wumpus_basic_version :: (Int,Int,Int)
-wumpus_basic_version = (0,3,0)
+wumpus_basic_version = (0,4,0)
diff --git a/src/Wumpus/Deprecated/PictureLanguage.hs b/src/Wumpus/Deprecated/PictureLanguage.hs
--- a/src/Wumpus/Deprecated/PictureLanguage.hs
+++ b/src/Wumpus/Deprecated/PictureLanguage.hs
@@ -527,7 +527,7 @@
 --
 -- An error is throw if the list of strings is empty
 -- 
-multilabel :: (Real u, Floating u, TextLabel t) 
+multilabel :: (Real u, Floating u, FromPtSize u, TextLabel t) 
            => t -> u -> VAlign -> [String] -> Point2 u -> Picture u
 multilabel _    _ _  []     _  = error $ 
     "Wumpus.Core.PictureLanguage.multilabel - empty list."
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.3.0
+version:          0.4.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -20,6 +20,17 @@
   .
   Changelog:
   .
+  0.3.0 to 0.4.0:
+  .
+  * Reworked the monads. Monads.DrawingMonad replaces 
+    Monads.Trace, Monads.DrawingCtx, Monads.ConsDrawing. The 
+    SnocDrawing monads have been removed as they were a design
+    mistake.
+  .
+  * Removed MGraphicF type, added AGraphic.
+  .
+  * Initial work on arrow drawing and extended text drawing.
+  .
   0.2.0 to 0.3.0 :
   . 
   * Added the anchors, monads, drawingAttrs...
@@ -59,34 +70,39 @@
 library
   hs-source-dirs:     src
   build-depends:      base            <  5, 
+                      containers      >= 0.3     && <= 0.4, 
                       vector-space    >= 0.6,
                       monadLib        >= 3.6,
-                      wumpus-core     >= 0.21.0
+                      wumpus-core     >= 0.23.0
 
   
   exposed-modules:
     Wumpus.Basic.Anchors,
-    Wumpus.Basic.AnchorDots,
+    Wumpus.Basic.Arrows,
+    Wumpus.Basic.Arrows.Tips,
     Wumpus.Basic.Dots,
+    Wumpus.Basic.Dots.Base,
     Wumpus.Basic.Graphic,
     Wumpus.Basic.Graphic.DrawingAttr,
     Wumpus.Basic.Graphic.PointSupply,
-    Wumpus.Basic.Monads.ConsDrawing,
     Wumpus.Basic.Monads.Drawing,
+    Wumpus.Basic.Monads.DrawingMonad,
     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.Paths,
+    Wumpus.Basic.Paths.Base,
+    Wumpus.Basic.Paths.Construction,
     Wumpus.Basic.SafeFonts,
     Wumpus.Basic.SVGColours,
-    Wumpus.Basic.X11Colours,
+    Wumpus.Basic.Text.LRSymbol,
+    Wumpus.Basic.Text.LRText,
+    Wumpus.Basic.Utils.Combinators,
     Wumpus.Basic.Utils.HList,
     Wumpus.Basic.Utils.Intersection,
     Wumpus.Basic.VersionNumber,
+    Wumpus.Basic.X11Colours,
     Wumpus.Deprecated.PictureLanguage
 
   other-modules: