diff --git a/demo/SimpleAdvGraphic.hs b/demo/SimpleAdvGraphic.hs
new file mode 100644
--- /dev/null
+++ b/demo/SimpleAdvGraphic.hs
@@ -0,0 +1,52 @@
+{-# OPTIONS -Wall #-}
+
+
+module SimpleAdvGraphic where
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                      -- package: wumpus-core
+
+import System.Directory
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    let pic1 = runCtxPictureU std_attr drawing01
+    writeEPS "./out/simple_adv_graphic01.eps" pic1
+    writeSVG "./out/simple_adv_graphic01.svg" pic1
+
+
+std_attr :: DrawingContext
+std_attr = standardContext 24
+
+
+drawing01 :: DCtxPicture
+drawing01 = drawTracing $ mf 
+
+
+mf :: (Floating u, FromPtSize u) => TraceDrawing u ()
+mf = do
+    drawi_ $ advspace (hvec 10) [text01, text02, text01] `at` P2 0 120
+    drawi_ $ advconcat [text01, text02, text01] `at` P2 0 80
+    drawi_ $ (miniDisk `advcat` text01 `advcat` miniDisk) `at` P2 0 40 
+    drawi_ $ (miniDisk `advcat` text02 `advcat` miniDisk) `at` P2 0 0 
+
+
+-- Normally, text calculate the advance vector from the font 
+-- metrics...
+--
+text01 :: Num u => AdvGraphic u 
+text01 = replaceAns (hvec 84) $ textline "text01"
+    
+
+text02 :: Num u => AdvGraphic u 
+text02 = replaceAns (hvec 210) $ textline "text number two"
+
+
+miniDisk :: Num u => AdvGraphic u
+miniDisk = replaceAns (V2 0 0) $ localize (fillColour sienna) $ filledDisk 3
+
+
+sienna :: RGBi
+sienna = RGBi 160 82 45
diff --git a/demo/SimplePosImage.hs b/demo/SimplePosImage.hs
new file mode 100644
--- /dev/null
+++ b/demo/SimplePosImage.hs
@@ -0,0 +1,98 @@
+{-# OPTIONS -Wall #-}
+
+
+module SimplePosImage where
+
+import Wumpus.Basic.Kernel
+
+import Wumpus.Core                      -- package: wumpus-core
+import Wumpus.Core.Colour ( red )
+
+import System.Directory
+
+main :: IO ()
+main = do 
+    createDirectoryIfMissing True "./out/"
+    let pic1 = runCtxPictureU std_attr drawing01
+    writeEPS "./out/simple_pos_image01.eps" pic1
+    writeSVG "./out/simple_pos_image01.svg" pic1
+
+
+std_attr :: DrawingContext
+std_attr = standardContext 24
+
+
+drawing01 :: DCtxPicture
+drawing01 = drawTracing $ localize (fillColour red) $ mf 
+
+
+mf :: (Floating u, FromPtSize u) => TraceDrawing u ()
+mf = do
+    draw $ testDrawMinor NN     `at` (P2   0 300)
+    draw $ testDrawMinor SS     `at` (P2  75 300)
+    draw $ testDrawMinor EE     `at` (P2 150 300)
+    draw $ testDrawMinor WW     `at` (P2 225 300)
+    draw $ testDrawMinor NE     `at` (P2   0 225)
+    draw $ testDrawMinor SE     `at` (P2  75 225)
+    draw $ testDrawMinor SW     `at` (P2 150 225)
+    draw $ testDrawMinor NW     `at` (P2 225 225)
+    draw $ testDrawMinor CENTER `at` (P2   0 150)
+    draw $ testDrawBl    CENTER `at` (P2 225 150)
+    draw $ testDrawBl    NN     `at` (P2   0 75)
+    draw $ testDrawBl    SS     `at` (P2  75 75)
+    draw $ testDrawBl    EE     `at` (P2 150 75)
+    draw $ testDrawBl    WW     `at` (P2 225 75)
+    draw $ testDrawBl    NE     `at` (P2   0 0)
+    draw $ testDrawBl    SE     `at` (P2  75 0)
+    draw $ testDrawBl    SW     `at` (P2 150 0)
+    draw $ testDrawBl    NW     `at` (P2 225 0)
+    
+
+testDrawBl :: Floating u => RectPosition -> LocGraphic u
+testDrawBl rpos = filledDisk 2 `oplus` (rectBl `startPos` rpos)
+
+rectBl :: Floating u => PosGraphic u 
+rectBl = makePosImage opos (mkRectBl w h)
+  where
+    w    = 40 
+    h    = 20
+    opos = ObjectPos { op_x_minor = 0
+                     , op_x_major = w
+                     , op_y_minor = 0
+                     , op_y_major = h }
+ 
+
+-- start-point - bottom left
+mkRectBl :: Floating u => u -> u -> LocGraphic u
+mkRectBl w h = promoteR1 $ \bl -> 
+    let br = displaceH w bl
+        tr = displaceV h br
+        tl = displaceV h bl
+    in closedStroke $ vertexPath [bl, br, tr, tl]
+
+
+
+testDrawMinor :: Floating u => RectPosition -> LocGraphic u
+testDrawMinor rpos = filledDisk 2 `oplus` (rectMinor `startPos` rpos)
+
+rectMinor :: Floating u => PosGraphic u 
+rectMinor = makePosImage opos (mkRectMinor m w h)
+  where
+    m    = 10
+    w    = 40 
+    h    = 20
+    opos = ObjectPos { op_x_minor = m
+                     , op_x_major = (w-m)
+                     , op_y_minor = m
+                     , op_y_major = (h-m) }
+ 
+
+-- start-point - +10 +10
+mkRectMinor :: Floating u => u -> u -> u -> LocGraphic u
+mkRectMinor m w h = promoteR1 $ \pt -> 
+    let bl = displaceVec (vec (-m) (-m)) pt
+        br = displaceH w bl
+        tr = displaceV h br
+        tl = displaceV h bl
+    in closedStroke $ vertexPath [bl, br, tr, tl]
+
diff --git a/src/Wumpus/Basic/Geometry/Base.hs b/src/Wumpus/Basic/Geometry/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Geometry/Base.hs
@@ -0,0 +1,468 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Geometry.Base
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Base geometric types and operations.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Geometry.Base
+  ( 
+
+  -- * constants
+    half_pi
+  , two_pi
+
+  -- * 2x2 Matrix
+  , Matrix2'2(..)
+  , DMatrix2'2
+  , identity2'2
+  , det2'2
+  , transpose2'2
+  
+  -- * Line in equational form 
+  , LineEquation(..)
+  , DLineEquation
+  , lineEquation
+  , pointViaX
+  , pointViaY
+  , pointLineDistance
+
+  -- * Line segment
+  , LineSegment(..)
+  , DLineSegment
+  
+  , rectangleLineSegments
+  , polygonLineSegments
+
+  -- * Cubic Bezier curves
+  
+  , BezierCurve(..)
+  , DBezierCurve
+
+  , bezierLength
+  , subdivide
+  , subdividet
+  
+  , bezierArcPoints
+  , bezierMinorArc
+
+  -- * Functions
+  , affineComb
+  , midpoint
+  , lineAngle
+
+
+  ) 
+  where
+
+import Wumpus.Basic.Kernel                      -- package: wumpus-basic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
+
+
+
+
+half_pi :: Floating u => u
+half_pi = 0.5*pi
+
+two_pi  :: Floating u => u
+two_pi  = 2*pi
+
+
+--------------------------------------------------------------------------------
+-- 2x2 matrix
+
+
+-- | 2x2 matrix, considered to be in row-major form.
+-- 
+-- > (M2'2 a b
+-- >       c d)
+--
+-- 
+
+data Matrix2'2 u = M2'2 !u !u   !u !u
+  deriving (Eq)
+
+type DMatrix2'2 = Matrix2'2 Double
+
+
+type instance DUnit (Matrix2'2 u)   = u
+
+
+instance Functor Matrix2'2 where
+  fmap f (M2'2 a b  c d) = M2'2 (f a) (f b)  (f c) (f d)
+
+instance Show u => Show (Matrix2'2 u) where
+  show (M2'2 a b c d) = "(M2'2 " ++ body ++ ")" 
+    where
+      body = show [[a,b],[c,d]]
+
+lift2Matrix2'2 :: (u -> u -> u) -> Matrix2'2 u -> Matrix2'2 u -> Matrix2'2 u
+lift2Matrix2'2 op (M2'2 a b c d) (M2'2 m n o p) = 
+      M2'2 (a `op` m) (b `op` n) 
+           (c `op` o) (d `op` p)
+
+instance Num u => Num (Matrix2'2 u) where
+  (+) = lift2Matrix2'2 (+) 
+  (-) = lift2Matrix2'2 (-)
+
+  (*) (M2'2 a b c d) (M2'2 m n o p) = 
+      M2'2 (a*m + b*o) (a*n + b*p)  
+           (c*m + d*o) (c*n + d*p) 
+  
+  abs    = fmap abs 
+  negate = fmap negate
+  signum = fmap signum
+  fromInteger a = M2'2 a' a'  a' a' where a' = fromInteger a
+
+
+-- | Construct the identity 2x2 matrix:
+--
+-- > (M2'2 1 0 
+-- >       0 1 )
+--
+identity2'2 :: Num u => Matrix2'2 u
+identity2'2 = M2'2  1 0  
+                    0 1
+
+
+-- | Determinant of a 2x2 matrix.
+--
+det2'2 :: Num u => Matrix2'2 u -> u
+det2'2 (M2'2 a b c d) = a*d - b*c
+
+
+-- | Transpose a 2x2 matrix.
+--
+transpose2'2 :: Matrix2'2 u -> Matrix2'2 u
+transpose2'2 (M2'2 a b 
+                   c d) = M2'2 a c
+                               b d
+
+
+--------------------------------------------------------------------------------
+
+-- | Line in equational form, i.e. @Ax + By + C = 0@.
+--
+data LineEquation u = LineEquation 
+      { line_eqn_A :: !u
+      , line_eqn_B :: !u
+      , line_eqn_C :: !u 
+      }
+  deriving (Eq,Show)
+
+type DLineEquation = LineEquation Double
+
+type instance DUnit (LineEquation u) = u
+
+-- | 'lineEquation' : @ point1 * point2 -> LineEquation @
+-- 
+-- Construct a line in equational form bisecting the supplied 
+-- points.
+--
+lineEquation :: Num u => Point2 u -> Point2 u -> LineEquation u
+lineEquation (P2 x1 y1) (P2 x2 y2) = LineEquation a b c 
+  where
+    a = y1 - y2
+    b = x2 - x1
+    c = (x1*y2) - (x2*y1)
+
+-- | 'pointViaX' : @ x * line_equation -> Point @
+--
+-- Calculate the point on the line for the supplied @x@ value.
+-- 
+pointViaX :: Fractional u => u -> LineEquation u -> Point2 u
+pointViaX x (LineEquation a b c) = P2 x y
+  where
+    y = ((a*x) + c) / (-b)
+
+
+-- | 'pointViaY' : @ y * line_equation -> Point @
+--
+-- Calculate the point on the line for the supplied @y@ value.
+-- 
+pointViaY :: Fractional u => u -> LineEquation u -> Point2 u
+pointViaY y (LineEquation a b c) = P2 x y
+  where
+    x = ((b*y) + c) / (-a)
+
+
+-- | 'pointLineDistance' : @ point -> line -> Distance @
+--
+-- Find the distance from a point to a line in equational form
+-- using this formula:
+-- 
+-- > P(u,v) 
+-- > L: Ax + By + C = 0
+-- >
+-- > (A*u) + (B*v) + C 
+-- > -----------------
+-- > sqrt $ (A^2) +(B^2)
+--
+-- A positive distance indicates the point is above the line, 
+-- negative indicates below.
+--
+pointLineDistance :: Floating u => Point2 u -> LineEquation u -> u
+pointLineDistance (P2 u v) (LineEquation a b c) = 
+    ((a*u) + (b*v) + c) / base
+  where
+    base = sqrt $ (a^two) + (b^two)
+    two  :: Integer
+    two  = 2
+
+--------------------------------------------------------------------------------
+
+data LineSegment u = LineSegment (Point2 u) (Point2 u)
+  deriving (Eq,Ord,Show)
+
+type DLineSegment = LineSegment Double
+
+type instance DUnit (LineSegment u) = u
+
+
+
+-- | 'rectangleLineSegments' : @ half_width * half_height -> [LineSegment] @
+--
+-- Compute the line segments of a rectangle.
+--
+rectangleLineSegments :: Num u => u -> u -> Point2 u -> [LineSegment u]
+rectangleLineSegments hw hh ctr = 
+    [ LineSegment br tr, LineSegment tr tl, LineSegment tl bl
+    , LineSegment bl br 
+    ]
+  where
+    br = ctr .+^ vec hw    (-hh)
+    tr = ctr .+^ vec hw    hh
+    tl = ctr .+^ vec (-hw) hh
+    bl = ctr .+^ vec (-hw) (-hh)
+
+
+-- | 'polygonLineSegments' : @ [point] -> [LineSegment] @
+--
+-- Build the line segments of a polygon fome a list of 
+-- its vertices.
+--
+polygonLineSegments :: [Point2 u] -> [LineSegment u]
+polygonLineSegments []     = []
+polygonLineSegments (x:xs) = step x xs 
+  where
+    step a []        = [LineSegment a x]
+    step a (b:bs)    = (LineSegment a b) : step b bs
+
+
+
+
+--------------------------------------------------------------------------------
+-- Bezier curves
+
+
+-- | A Strict cubic Bezier curve.
+--
+data BezierCurve u = BezierCurve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)
+  deriving (Eq,Ord,Show)
+
+type DBezierCurve = BezierCurve Double
+
+type instance DUnit (BezierCurve u) = u
+
+
+
+-- | 'bezierLength' : @ start_point * control_1 * control_2 * 
+--        end_point -> Length @ 
+--
+-- Find the length of a Bezier curve. The result is an 
+-- approximation, with the /tolerance/ is 0.1 of a point. This
+-- seems good enough for drawing (potentially the tolerance could 
+-- be larger still). 
+--
+-- The result is found through repeated subdivision so the 
+-- calculation is potentially costly.
+--
+bezierLength :: (Floating u, Ord u, FromPtSize u)      
+             => BezierCurve u -> u
+bezierLength = gravesenLength (fromPtSize 0.1)
+
+
+
+-- | Jens Gravesen\'s bezier arc-length approximation. 
+--
+-- Note this implementation is parametrized on error tolerance.
+--
+gravesenLength :: (Floating u, Ord u) => u -> BezierCurve u -> u
+gravesenLength err_tol crv = step crv 
+  where
+    step c = let l1 = ctrlPolyLength c
+                 l0 = cordLength c
+             in if   l1-l0 > err_tol
+                then let (a,b) = subdivide c in step a + step b
+                else 0.5*l0 + 0.5*l1
+
+-- | Length of the tree lines spanning the control points.
+--
+ctrlPolyLength :: Floating u => BezierCurve u -> u
+ctrlPolyLength (BezierCurve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3
+  where
+    len pa pb = vlength $ pvec pa pb
+
+
+-- | Length of the cord - start point to end point.
+--
+cordLength :: Floating u => BezierCurve u -> u
+cordLength (BezierCurve p0 _ _ p3) = vlength $ pvec p0 p3
+
+
+
+
+-- | Curve subdivision via de Casteljau\'s algorithm.
+--
+subdivide :: Fractional u 
+          => BezierCurve u -> (BezierCurve u, BezierCurve u)
+subdivide (BezierCurve p0 p1 p2 p3) =
+    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)
+  where
+    p01   = midpoint p0    p1
+    p12   = midpoint p1    p2
+    p23   = midpoint p2    p3
+    p012  = midpoint p01   p12
+    p123  = midpoint p12   p23
+    p0123 = midpoint p012  p123
+
+-- | subdivide with an affine weight along the line...
+--
+subdividet :: Real u
+           => u -> BezierCurve u -> (BezierCurve u, BezierCurve u)
+subdividet t (BezierCurve p0 p1 p2 p3) = 
+    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)
+  where
+    p01   = affineComb t p0    p1
+    p12   = affineComb t p1    p2
+    p23   = affineComb t p2    p3
+    p012  = affineComb t p01   p12
+    p123  = affineComb t p12   p23
+    p0123 = affineComb t p012  p123
+
+
+
+
+kappa :: Floating u => u
+kappa = 4 * ((sqrt 2 - 1) / 3)
+
+
+
+-- | 'bezierArcPoints' : @ apex_angle * radius * rotation * center -> [Point] @
+--
+-- > ang should be in the range 0 < ang < 360deg.
+--
+-- > if   0 < ang <=  90 returns 4 points
+-- > if  90 < ang <= 180 returns 7 points
+-- > if 180 < ang <= 270 returns 10 points
+-- > if 270 < ang <  360 returns 13 points
+--
+bezierArcPoints ::  Floating u 
+                => Radian -> u -> Radian -> Point2 u -> [Point2 u]
+bezierArcPoints ang radius theta pt = go (circularModulo ang)
+  where
+    go a | a <= half_pi = wedge1 a
+         | a <= pi      = wedge2 (a/2)
+         | a <= 1.5*pi  = wedge3 (a/3)
+         | otherwise    = wedge4 (a/4)
+    
+    wedge1 a = 
+      let (BezierCurve p0 p1 p2 p3) = bezierMinorArc a radius theta pt
+      in [p0,p1,p2,p3]
+
+    wedge2 a = 
+      let (BezierCurve  p0 p1 p2 p3) = bezierMinorArc a radius theta pt
+          (BezierCurve _   p4 p5 p6) = bezierMinorArc a radius (theta+a) pt
+      in [ p0,p1,p2,p3, p4,p5,p6 ] 
+
+    wedge3 a = 
+      let (BezierCurve p0 p1 p2 p3) = bezierMinorArc a radius theta pt
+          (BezierCurve _  p4 p5 p6) = bezierMinorArc a radius (theta+a) pt
+          (BezierCurve _  p7 p8 p9) = bezierMinorArc a radius (theta+a+a) pt
+      in [ p0,p1,p2,p3, p4,p5,p6, p7, p8, p9 ] 
+  
+    wedge4 a = 
+      let (BezierCurve p0 p1 p2 p3)    = bezierMinorArc a radius theta pt
+          (BezierCurve _  p4 p5 p6)    = bezierMinorArc a radius (theta+a) pt
+          (BezierCurve _  p7 p8 p9)    = bezierMinorArc a radius (theta+a+a) pt
+          (BezierCurve _  p10 p11 p12) = bezierMinorArc a radius (theta+a+a+a) pt
+      in [ p0,p1,p2,p3, p4,p5,p6, p7,p8,p9, p10,p11, p12 ] 
+
+
+-- | 'bezierMinorArc' : @ apex_angle * radius * rotation * center -> BezierCurve @
+--
+-- > ang should be in the range 0 < ang <= 90deg.
+--
+bezierMinorArc :: Floating u 
+                 => Radian -> u -> Radian -> Point2 u -> BezierCurve u
+bezierMinorArc ang radius theta pt = BezierCurve p0 c1 c2 p3
+  where
+    kfactor = fromRadian $ ang / (0.5*pi)
+    rl      = kfactor * radius * kappa
+    totang  = circularModulo $ ang + theta
+
+    p0      = displaceParallel radius theta pt
+    c1      = displacePerpendicular rl theta p0
+    c2      = displacePerpendicular (-rl) totang p3
+    p3      = displaceParallel radius totang pt
+
+
+--------------------------------------------------------------------------------
+--
+
+
+-- | Affine combination...
+--
+affineComb :: Real u => u -> Point2 u -> Point2 u -> Point2 u
+affineComb t p1 p2 = p1 .+^ t *^ (p2 .-. p1)
+
+
+-- | 'midpoint' : @ start_point * end_point -> Midpoint @
+-- 
+-- Mid-point on the line formed between the two supplied points.
+--
+midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u
+midpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0
+
+
+
+-- | 'lineAngle' : @ start_point * end_point -> Angle @
+--
+-- Calculate the counter-clockwise angle between the line formed 
+-- by the two points and the horizontal plane.
+--
+lineAngle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian
+lineAngle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1)
+  where
+    -- north-east quadrant 
+    step x y | pve x && pve y = toRadian $ atan (y/x)          
+    
+    -- north-west quadrant
+    step x y | pve y          = pi     - (toRadian $ atan (y / abs x))
+
+    -- south-east quadrant
+    step x y | pve x          = (2*pi) - (toRadian $ atan (abs y / x)) 
+
+    -- otherwise... south-west quadrant
+    step x y                  = pi     + (toRadian $ atan (y/x))
+
+    pve a                     = signum a >= 0
+
+-- Ideally this would be in Geometry.Quadrant.
+-- And surely there is a simpler formulation...
+
+
diff --git a/src/Wumpus/Basic/Geometry/Intersection.hs b/src/Wumpus/Basic/Geometry/Intersection.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Geometry/Intersection.hs
@@ -0,0 +1,223 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Geometry.Intersection
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Intersection of line to line and line to plane.
+-- 
+-- \*\* - WARNING \*\* - this uses quite a high tolerance for 
+-- floating point equality. 
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Geometry.Intersection
+  ( 
+
+    LineSegment
+  , interLineLine
+  , interLinesegLineseg
+  , interLinesegLine
+  , interCurveLine
+
+  , findIntersect
+  , makePlane
+  , rectangleLineSegments
+  , polygonLineSegments
+
+
+  ) 
+  where
+
+import Wumpus.Basic.Geometry.Base
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+
+-- Potentially lines hould be a new datatype.
+
+
+-- | 'interLineLine' : @ line1 * line2 -> Maybe Point @
+-- 
+-- Find the intersection of two lines, if there is one. 
+--
+-- Lines are infinite they are represented by points on them, 
+-- they are not line segments.
+--
+-- An answer of @Nothing@ may indicate wither the lines coincide
+-- or the are parallel.
+--
+interLineLine :: Fractional u 
+              => (Point2 u, Point2 u) -> (Point2 u, Point2 u) 
+              -> Maybe (Point2 u)
+interLineLine (p1,p2) (q1,q2) = 
+    if det_co == 0 then Nothing 
+                   else Just $ P2 (det_xm / det_co) (det_ym / det_co)
+  where
+    -- Ax + By + C = 0
+    LineEquation a1 b1 c1 = lineEquation p1 p2
+    LineEquation a2 b2 c2 = lineEquation q1 q2
+
+    coeffM                = M2'2 a1 b1  a2 b2
+    det_co                = det2'2 coeffM
+
+    xM                    = M2'2  (negate c1) b1  (negate c2) b2
+    det_xm                = det2'2 xM
+
+    yM                    = M2'2  a1 (negate c1) a2 (negate c2)
+    det_ym                = det2'2 yM
+
+
+
+-- | 'interLinesegLineseg' : @ line_segment1 * line_segment2 -> Maybe Point @
+-- 
+-- Find the intersection of two line segments, if there is one. 
+--
+-- An answer of @Nothing@ indicates that the line segments 
+-- coincide, or that there is no intersection.
+--
+interLinesegLineseg :: (Fractional u, Ord u, FromPtSize u)
+                    => LineSegment u -> LineSegment u -> Maybe (Point2 u)
+interLinesegLineseg a@(LineSegment p q) b@(LineSegment s t) = 
+    interLineLine (p,q) (s,t) >>= segcheck
+  where
+    segcheck = mbCheck (\pt -> withinPoints pt a && withinPoints pt b)
+ 
+
+-- | 'interLinesegLine' : @ line_segment * line -> Maybe Point @
+-- 
+-- Find the intersection of a line and a line segment, if there 
+-- is one. 
+--
+-- An answer of @Nothing@ indicates that the the line and line
+-- segment coincide, or that there is no intersection.
+--
+interLinesegLine :: (Fractional u, Ord u, FromPtSize u)
+                 => LineSegment u -> (Point2 u, Point2 u) -> Maybe (Point2 u)
+interLinesegLine a@(LineSegment p q) line = 
+    interLineLine (p,q) line >>= segcheck
+  where
+    segcheck = mbCheck (\pt -> withinPoints pt a)
+
+
+mbCheck :: (a -> Bool) -> a -> Maybe a
+mbCheck test a = if test a then Just a else Nothing
+
+-- | Check the point is \"within\" the span of the line.
+--
+-- Note - this function is to be used \*after\* an intersection
+-- has been found. Hence it is not export.
+--
+withinPoints :: (Ord u, FromPtSize u) => Point2 u -> LineSegment u -> Bool
+withinPoints (P2 x y) (LineSegment (P2 x0 y0) (P2 x1 y1)) =  
+    between x (ordpair x0 x1) && between y (ordpair y0 y1)
+  where
+    ordpair a b     = (min a b, max a b)
+    between a (s,t) = (s `tGT` a) && (a `tGT` t)
+
+    tGT a b         = a < b || abs (a-b) < tolerance
+
+-- | Note - its important to use tolerance for the @withPoints@ 
+-- function.
+--
+tolerance :: FromPtSize u => u
+tolerance = fromPtSize 0.01
+
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- intersection of line and Bezier curve
+
+interCurveLine :: (Floating u , Ord u, FromPtSize u)
+               => BezierCurve u -> (Point2 u, Point2 u) -> Maybe (Point2 u)
+interCurveLine c0 (p,q) = step c0
+  where
+    eqline  = lineEquation p q
+    step c  = case cut c eqline of
+                Left pt     -> Just pt      -- cut at start or end
+                Right False -> Nothing
+                Right True  -> let (a,b) = subdivide c
+                               in case step a of
+                                   Just pt -> Just pt
+                                   Nothing -> step b
+ 
+-- | Is the curve cut by the line? 
+--
+-- The curve might cut at the start or end points - which is good
+-- as it saves performing a subdivision. But make the return type
+-- a bit involved.
+--
+cut :: (Floating u , Ord u, FromPtSize u)
+    => BezierCurve u -> LineEquation u -> Either (Point2 u) Bool
+cut (BezierCurve p0 p1 p2 p3) line = 
+    if d0 `tEQ` 0 then Left p0 else
+    if d3 `tEQ` 0 then Left p3 else
+    let ds = [d0,d1,d2,d3] in Right $ not $ all pve ds || all nve ds
+  where
+    tEQ = \a b -> abs (a-b) < tolerance
+    pve = \a -> a > tolerance
+    nve = \a -> a < (negate tolerance)
+    d0  = pointLineDistance p0 line 
+    d1  = pointLineDistance p1 line 
+    d2  = pointLineDistance p2 line 
+    d3  = pointLineDistance p3 line 
+
+
+
+    
+
+
+--------------------------------------------------------------------------------
+-- Intersection of shape boundaries...
+
+
+
+-- | 'findIntersect' :: @ radial_origin * theta * [line_segment] -> Maybe Point @
+--
+-- Find the first intersection of a line through @radial_origin@ 
+-- at angle @theta@ and the supplied line segments, if there 
+-- is one. 
+--
+findIntersect :: (Floating u, Real u, Ord u, FromPtSize u)
+               => Point2 u -> Radian -> [LineSegment u] 
+               -> Maybe (Point2 u)
+findIntersect radial_ogin ang = step 
+  where
+    plane       = makePlane radial_ogin ang
+    step []     = Nothing
+    step (x:xs) = case interLinesegLine x plane of 
+                     Just pt | quadrantCheck ang radial_ogin pt -> Just pt
+                     _       -> step xs
+
+
+-- | The tolerance on Radian equality should be acceptable...
+--
+quadrantCheck :: (Real u, Floating u) 
+              => Radian -> Point2 u -> Point2 u -> Bool
+quadrantCheck theta ctr pt = theta == lineAngle ctr pt
+
+
+
+
+
+-- | 'makePlane' : @ point * ang -> Line @
+--
+-- Make an infinite line \/ plane passing through the supplied 
+-- with elevation @ang@.
+--
+makePlane :: Floating u => Point2 u -> Radian -> (Point2 u, Point2 u)
+makePlane radial_ogin ang = (radial_ogin, radial_ogin .+^ avec ang 100)
+
+
diff --git a/src/Wumpus/Basic/Geometry/Paths.hs b/src/Wumpus/Basic/Geometry/Paths.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Geometry/Paths.hs
@@ -0,0 +1,138 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Drawing.Basic.Paths
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Paths for /elementary/ shapes - rectangles...
+-- 
+-- \*\* - WARNING \*\* - half baked. 
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Geometry.Paths
+  ( 
+    LocCoordPath
+  , coordinatePrimPath
+
+  , rectangleCoordPath
+  , diamondCoordPath
+  , polygonCoordPath
+  , isoscelesTriangleCoordPath
+  , isoscelesTrianglePoints
+  , equilateralTriangleCoordPath
+  , equilateralTrianglePoints
+  ) 
+  where
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+import Data.List ( unfoldr )
+
+
+-- | A functional type from /initial point/ to point list.
+--
+type LocCoordPath u = Point2 u -> [Point2 u]
+
+
+-- Note - extraction needs a naming scheme - extractFROM or 
+-- extractTO? - in either case this might be queuing up 
+-- name-clash problems.
+--
+-- The Path data type will also need a similar function...
+--
+ 
+coordinatePrimPath :: Num u => Point2 u -> LocCoordPath u -> PrimPath u
+coordinatePrimPath pt fn = go (fn pt)
+  where
+    go ps@(_:_) = vertexPath ps
+    go []       = emptyPath pt        -- fallback
+
+
+-- NOTE - These functions need changing to generate LocCoordPaths...
+
+-- | Supplied point is /bottom-left/, subsequenct points are 
+-- counter-clockise so [ bl, br, tr, tl ] .
+--
+rectangleCoordPath :: Num u => u -> u -> LocCoordPath u
+rectangleCoordPath w h bl = [ bl, br, tr, tl ]
+  where
+    br = bl .+^ hvec w
+    tr = br .+^ vvec h
+    tl = bl .+^ vvec h 
+
+
+
+-- | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @
+--
+diamondCoordPath :: Num u => u -> u -> LocCoordPath u
+diamondCoordPath hw hh ctr = [ s,e,n,w ]
+  where
+    s     = ctr .+^ vvec (-hh)
+    e     = ctr .+^ hvec hw
+    n     = ctr .+^ vvec hh
+    w     = ctr .+^ hvec (-hw)
+    
+
+-- | 'polygonCoordPath' : @ num_points * radius * center -> [point] @ 
+--
+polygonCoordPath :: Floating u => Int -> u -> LocCoordPath u
+polygonCoordPath n radius ctr = unfoldr phi (0,(pi*0.5))
+  where
+    theta = (pi*2) / fromIntegral n
+    
+    phi (i,ang) | i < n     = Just (ctr .+^ avec ang radius, (i+1,ang+theta))
+                | otherwise = Nothing
+
+
+
+-- | @isocelesTriangle bw h pt@
+--
+-- Supplied point is the centriod of the triangle. This has a 
+-- nicer visual balance than using half-height.
+--
+isoscelesTriangleCoordPath :: Floating u => u -> u -> LocCoordPath u
+isoscelesTriangleCoordPath bw h ctr = [bl,br,top]
+  where
+    (bl,br,top) = isoscelesTrianglePoints bw h ctr
+
+
+-- | @isocelesTriangle bw h pt@
+--
+-- Supplied point is the centriod of the triangle. This has a 
+-- nicer visual balance than using half-height.
+--
+isoscelesTrianglePoints :: Floating u 
+                        => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u)
+isoscelesTrianglePoints bw h ctr = (bl, br, top) 
+  where
+    hw         = 0.5*bw 
+    theta      = atan $ h / hw
+    centroid_h = hw * tan (0.5*theta)
+    top        = ctr .+^ vvec (h - centroid_h)
+    br         = ctr .+^ V2   hw  (-centroid_h)
+    bl         = ctr .+^ V2 (-hw) (-centroid_h)
+
+
+-- | @ side_length * ctr -> [Points] @
+--
+equilateralTriangleCoordPath :: Floating u => u -> LocCoordPath u
+equilateralTriangleCoordPath sl ctr = [bl, br, top] 
+  where
+    (bl,br,top) = equilateralTrianglePoints sl ctr
+
+equilateralTrianglePoints :: Floating u 
+                          => u -> Point2 u -> (Point2 u, Point2 u, Point2 u)
+equilateralTrianglePoints sl = isoscelesTrianglePoints sl h
+  where
+    h = sl * sin (pi/3)
+
diff --git a/src/Wumpus/Basic/Geometry/Quadrant.hs b/src/Wumpus/Basic/Geometry/Quadrant.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Geometry/Quadrant.hs
@@ -0,0 +1,306 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Geometry.Quadrant
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
+-- Stability   :  highly unstable
+-- Portability :  GHC
+--
+-- Quadrants and trigonometric calculations.
+-- 
+-- \*\* - WARNING \*\* - in progress. 
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Geometry.Quadrant
+  ( 
+    Quadrant(..)
+
+  , quadrant
+  , qiModulo
+
+  , rectRadialVector
+  , rectangleQI
+
+  , diamondRadialVector
+  , triangleRadialVector
+  , triangleQI
+  , rightTrapezoidQI
+  
+  , rightTrapeziumBaseWidth
+
+  ) 
+  where
+
+import Wumpus.Core                              -- package: wumpus-core
+
+data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE
+  deriving (Enum,Eq,Ord,Show)
+
+-- | 'quadrant' : @ ang -> Quadrant @
+--
+-- Get the quadrant of an angle.
+--
+quadrant :: Radian -> Quadrant
+quadrant = fn . circularModulo
+  where
+    fn a | a < 0.5*pi   = QUAD_NE
+         | a < pi       = QUAD_NW
+         | a < 1.5*pi   = QUAD_SW
+         | otherwise    = QUAD_SE
+
+
+-- | 'qiModulo' : @ ang -> Radian @
+-- 
+-- Modulo an angle so it lies in quadrant I (north east), 
+-- i.e. modulo into the range @0..(pi/2)@.
+--
+qiModulo :: Radian -> Radian 
+qiModulo r = d2r $ dec + (fromIntegral $ i `mod` 90)
+  where
+    i       :: Integer
+    dec     :: Double
+    (i,dec) = properFraction $ r2d r
+
+
+--------------------------------------------------------------------------------
+
+negateX :: Num u => Vec2 u -> Vec2 u
+negateX (V2 x y) = V2 (-x) y
+
+negateY :: Num u => Vec2 u -> Vec2 u
+negateY (V2 x y) = V2 x (-y)
+
+negateXY :: Num u => Vec2 u -> Vec2 u
+negateXY (V2 x y) = V2 (-x) (-y)
+
+
+-- | 'rectRadialVector' : @ half_width * half_height * ang -> Vec @
+--
+-- Find where a radial line extended from (0,0) with the elevation
+-- @ang@ intersects with an enclosing rectangle. The rectangle is 
+-- centered at (0,0).
+-- 
+-- Internally the calculation is made in quadrant I (north east),
+-- symmetry is used to translate result to the other quadrants.
+--
+rectRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u
+rectRadialVector hw hh ang = fn $ circularModulo ang
+  where
+    fn a | a < 0.5*pi   = rectangleQI hw hh a
+         | a < pi       = negateX  $ rectangleQI hw hh (pi - a)
+         | a < 1.5*pi   = negateXY $ rectangleQI hw hh (a - pi) 
+         | otherwise    = negateY  $ rectangleQI hw hh (2*pi - a)
+
+
+-- | 'rectangleQI' : @ width * height * ang -> Vec @
+--
+-- Find where a line from (0,0) in direction @ang@ intersects the 
+-- top or right side of a rectangle in QI (left side is the 
+-- y-axis, bottom is the x-axis).  
+--
+-- > ang must be in the @range 0 < ang <= 90 deg@.
+-- >
+-- > width and height must be positive.
+--
+rectangleQI :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u    
+rectangleQI w h ang
+    | ang < theta  = let y = w * fromRadian (tan ang) in V2 w y
+    | otherwise    = let x = h / fromRadian (tan ang) in V2 x h
+  where
+    theta               = toRadian $ atan (h/w)
+
+
+-- | 'diamondRadialVector' : @ half_width * half_height * ang -> Vec @
+--
+-- Find where a radial line extended from (0,0) with the elevation
+-- @ang@ intersects with an enclosing diamond. The diamond is 
+-- centered at (0,0).
+-- 
+-- Internally the calculation is made in quadrant I (north east),
+-- symmetry is used to translate result to the other quadrants.
+--
+diamondRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u
+diamondRadialVector hw hh ang = fn $ circularModulo ang
+  where
+    fn a | a < 0.5*pi   = triangleQI hw hh a
+         | a < pi       = negateX  $ triangleQI hw hh (pi - a)
+         | a < 1.5*pi   = negateXY $ triangleQI hw hh (a - pi) 
+         | otherwise    = negateY  $ triangleQI hw hh (2*pi - a)
+
+
+-- | 'triangleRadialVector' : @ half_base_width * height_minor * 
+--        height_minor * ang -> Vec @
+--
+-- Find where a radial line extended from (0,0) with the elevation
+-- @ang@ intersects with an enclosing triangle. The triangle has 
+-- the centroid at (0,0), so solutions in quadrants I and II are 
+-- intersections with a simple line. Intersections in quadrants
+-- III and IV can intersect either the respective side or the 
+-- base.
+-- 
+--
+triangleRadialVector :: (Real u, Floating u) => u -> u -> u -> Radian -> Vec2 u
+triangleRadialVector hbw hminor hmajor ang = fn $ circularModulo ang
+  where
+    fn a | a < 0.5*pi   = triangleQI major_width hmajor a
+         | a < pi       = negateX  $ triangleQI major_width hmajor (pi - a)
+         | a < 1.5*pi   = negateXY $ rightTrapezoidQI hbw hminor base_rang (a - pi) 
+         | otherwise    = negateY  $ rightTrapezoidQI hbw hminor base_rang (2*pi - a)
+
+    height              = hmajor + hminor
+    base_rang           = toRadian $ atan (height / hbw)
+    major_width         = hmajor / (fromRadian $ tan base_rang)
+
+
+-- | 'triangleQI' : @ width * height * ang -> Vec @
+--
+-- Find where a line from (0,0) with elevation @ang@ intersects 
+-- the hypotenuse a right triangle in QI (the legs of the triangle 
+-- take the x and y-axes).  
+--
+-- > ang must be in the @range 0 < ang <= 90@.
+-- >
+-- > width and height must be positive.
+--
+triangleQI :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u
+triangleQI w h ang = avec ang dist
+  where
+    base_ang = atan (h / w)
+    apex     = pi - (base_ang + fromRadian ang)
+    dist     = sin base_ang * (w / sin apex)
+
+
+
+-- | 'rightTrapezoidQI' : @ top_width * height * top_right_ang -> Vec @
+--
+-- Find where a line from (0,0) with elevation @ang@ intersects 
+-- the either the lines A_B or B_D in a right trapezoid in QI. 
+-- 
+-- The right trapezoid has a variable right side. Left side is the
+-- y-axis (C_A), bottom side is the x-axis (C_D), top side is 
+-- parallel to the x-axis (A_B).
+--
+-- >  A   B
+-- >  -----
+-- >  |    \
+-- >  |     \     
+-- >  -------
+-- >  C      D
+--
+-- >  A      B
+-- >  -------
+-- >  |     /
+-- >  |    /     
+-- >  -----
+-- >  C   D
+--
+-- > ang must be in the range 0 < ang <= 90.
+-- >
+-- > top_width and height must be positive.
+--
+rightTrapezoidQI :: (Real u, Floating u) 
+                 => u -> u -> Radian -> Radian -> Vec2 u
+rightTrapezoidQI tw h top_rang ang = 
+    if w0 <= tw then dv else avec ang minor_dist
+  where
+    -- dist is hypotenuse of a right triangle1
+    dist         = h / (fromRadian $ sin ang)
+    
+    -- potentially this vector is *too long*.
+    dv@(V2 w0 _) = avec ang dist
+
+    -- this is dist *cut short* because it intersects the right
+    -- side rather than the top
+    minor_dist   = triangleLeftSide base_width ang lr_ang
+    
+    lr_ang       = pi - top_rang
+
+    base_width   = rightTrapeziumBaseWidth tw h top_rang
+
+
+-- Legend:
+-- 
+-- > @top_rang@ is A/B\C.
+-- >
+-- > @ang@ is B/C\D.
+-- > 
+-- > w (width) is A_B.
+--
+-- > h (height) is C_A.
+-- 
+-- >  A     B
+-- >  ------ 
+-- >  |    / .
+-- >  |   /   .
+-- >  |  /     .
+-- >  | /       .     
+-- >  |/..........
+-- >  C          D
+--
+-- Synthetically:
+--
+-- > Right triangle 1 is ABC.
+-- >
+-- > @dist@ is C_B.
+-- >
+-- > @base_width@ is C_D.
+-- >
+-- > @lr_ang is C/D\B. 
+--   
+
+
+-- | 'traingleLeftSide' : @ base_width * left_ang * right_ang -> Length @
+--
+-- >  
+-- >        C   
+-- >       /\
+-- >      /  \
+-- >     /    \
+-- >    /      \    
+-- >   /________\
+-- >  A          B
+-- >
+-- 
+-- > Calculate A_C given side A_B, angle C/A\B and angle A/B\C.
+--
+triangleLeftSide :: Fractional u => u -> Radian -> Radian -> u
+triangleLeftSide base_width lang rang =
+    (fromRadian $ sin rang) / factor 
+  where
+    apex   = pi - (lang + rang)
+    factor = (fromRadian $ sin apex) / base_width
+
+
+-- | 'rightTrapeziumBaseWidth' : @ top_width * height * top_right_ang -> Length @
+-- 
+-- Find the length of the line C_D:
+--
+-- >  A   B
+-- >  -----
+-- >  |    \
+-- >  |     \     
+-- >  -------
+-- >  C      D
+--
+-- >  A      B
+-- >  -------
+-- >  |     /
+-- >  |    /     
+-- >  -----
+-- >  C   D
+--
+-- 
+rightTrapeziumBaseWidth :: Fractional u => u -> u -> Radian -> u
+rightTrapeziumBaseWidth tw h tr_ang 
+    | tr_ang < half_pi = tw - shorten
+    | tr_ang > half_pi = tw + extend
+    | otherwise        = tw
+  where
+    half_pi  = 0.5*pi
+    shorten  = h / fromRadian (tan tr_ang)
+    extend   = let lr_ang = pi - tr_ang in h / fromRadian (tan lr_ang)
diff --git a/src/Wumpus/Basic/Kernel.hs b/src/Wumpus/Basic/Kernel.hs
--- a/src/Wumpus/Basic/Kernel.hs
+++ b/src/Wumpus/Basic/Kernel.hs
@@ -3,7 +3,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
@@ -31,7 +31,10 @@
   , module Wumpus.Basic.Kernel.Objects.Bounded
   , module Wumpus.Basic.Kernel.Objects.Connector
   , module Wumpus.Basic.Kernel.Objects.CtxPicture
+  , module Wumpus.Basic.Kernel.Objects.Displacement
+  , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives
   , module Wumpus.Basic.Kernel.Objects.Graphic
+  , module Wumpus.Basic.Kernel.Objects.PosImage
   , module Wumpus.Basic.Kernel.Objects.TraceDrawing
   ) where
 
@@ -49,5 +52,8 @@
 import Wumpus.Basic.Kernel.Objects.Bounded
 import Wumpus.Basic.Kernel.Objects.Connector
 import Wumpus.Basic.Kernel.Objects.CtxPicture
+import Wumpus.Basic.Kernel.Objects.Displacement
+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
 import Wumpus.Basic.Kernel.Objects.Graphic
+import Wumpus.Basic.Kernel.Objects.PosImage
 import Wumpus.Basic.Kernel.Objects.TraceDrawing
diff --git a/src/Wumpus/Basic/Kernel/Base/Anchors.hs b/src/Wumpus/Basic/Kernel/Base/Anchors.hs
--- a/src/Wumpus/Basic/Kernel/Base/Anchors.hs
+++ b/src/Wumpus/Basic/Kernel/Base/Anchors.hs
@@ -17,6 +17,12 @@
 -- anchors on node shapes to get the start and end points for 
 -- connectors in a network (graph) diagram.
 -- 
+-- \*\* WARNING \*\* - The API here needs some thought as to a
+-- good balance of the type classes - in a nutshell \"are corners 
+-- better than cardinals\". Originally I tried to follow how I 
+-- understand the TikZ anchors to work, but this is perhaps not 
+-- ideal for dividing into type-classes.
+--
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Kernel.Base.Anchors
@@ -24,19 +30,17 @@
 
   -- * Anchors
     CenterAnchor(..)
+  , ApexAnchor(..)
   , CardinalAnchor(..)
   , CardinalAnchor2(..)
   , RadialAnchor(..)
+  , TopCornerAnchor(..)
+  , BottomCornerAnchor(..)
+  , SideMidpointAnchor(..)
 
+
   -- * Extended anchor points
-  , northwards
-  , southwards
-  , eastwards
-  , westwards
-  , northeastwards
-  , southeastwards
-  , southwestwards
-  , northwestwards
+  , projectAnchor
 
   , radialConnectorPoints
 
@@ -52,6 +56,13 @@
 class CenterAnchor t where
   center :: DUnit t ~ u => t -> Point2 u
 
+
+-- | Apex of an object.
+--
+class ApexAnchor t where
+  apex :: DUnit t ~ u => t -> Point2 u
+
+
 -- | Cardinal (compass) positions on an object. 
 -- 
 -- Note - in TikZ cardinal anchors are not necessarily at the
@@ -67,13 +78,23 @@
   east  :: DUnit t ~ u => t -> Point2 u
   west  :: DUnit t ~ u => t -> Point2 u
 
+--
+-- Note - a design change is probably in order where the cardinals 
+-- should /always/ represent their true cardinal position.
+--
+-- If this change is made, it is worthwhile having cardinals as
+-- classes (rather than making them derived operations on 
+-- RadialAnchor) as classes allow for more efficient 
+-- implementations usually by trigonometry.
+-- 
 
+
 -- | Secondary group of cardinal (compass) positions on an object. 
 -- 
 -- It seems possible that for some objects defining the primary
 -- compass points (north, south,...) will be straight-forward 
 -- whereas defining the secondary compass points may be 
--- problemmatic, hence the compass points are split into two 
+-- problematic, hence the compass points are split into two 
 -- classes.
 --
 class CardinalAnchor2 t where
@@ -92,108 +113,71 @@
   radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u
 
 
-
-
-extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u
-extendPtDist d p1 p2 = let v   = pvec p1 p2
-                           ang = vdirection v
-                           len = vlength v
-                       in p1 .+^ avec ang (len+d)
-
-
--- | 'northwards' : @ dist * object -> Point @
--- 
--- Project the anchor along a line from the center that goes 
--- through the north anchor. 
---
--- If the distance is zero the answer with be the north anchor.
---
--- If the distance is negative the answer within the object before 
--- the north anchor.
+-- | Anchors at the top left and right corners of a shape.
 --
--- If the distance is positive the anchor outside the object.
+-- For some shapes (Rectangle) the TikZ convention appears to be
+-- have cardinals as the corner anchors, but this doesn\'t seem
+-- to be uniform. Wumpus will need to reconsider anchors at some 
+-- point...
 --
-northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
-              , u ~ DUnit t ) 
-           => u -> t -> Point2 u
-northwards u a = extendPtDist u (center a) (north a)
+class TopCornerAnchor t where
+  topLeftCorner  :: DUnit t ~ u => t -> Point2 u
+  topRightCorner :: DUnit t ~ u => t -> Point2 u
 
 
--- | 'southwards' : @ dist * object -> Point @
--- 
--- Variant of the function 'northwards', but projecting the line 
--- southwards from the center of the object.
+-- | Anchors at the bottom left and right corners of a shape.
 --
-southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
-              , u ~ DUnit t ) 
-           => u -> t -> Point2 u
-southwards u a = extendPtDist u (center a) (south a)
+class BottomCornerAnchor t where
+  bottomLeftCorner  :: DUnit t ~ u => t -> Point2 u
+  bottomRightCorner :: DUnit t ~ u => t -> Point2 u
 
 
--- | 'eastwards' : @ dist * object -> Point @
+-- | Anchors in the center of a side.
 -- 
--- Variant of the function 'northwards', but projecting the line 
--- eastwards from the center of the object.
---
-eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
-             , u ~ DUnit t ) 
-          => u -> t -> Point2 u
-eastwards u a = extendPtDist u (center a) (east a)
-
-
--- | 'westwards' : @ dist * object -> Point @
+-- Sides are addressable by index. Following TikZ, side 1 is 
+-- expected to be the top of the shape. If the shape has an apex 
+-- instead of a side then side 1 is expected to be the first side 
+-- left of the apex.
 -- 
--- Variant of the function 'northwards', but projecting the line 
--- westwards from the center of the object.
+-- Implementations are also expected to modulo the side number, 
+-- rather than throw an out-of-bounds error.
 --
-westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t
-             , u ~ DUnit t ) 
-          => u -> t -> Point2 u
-westwards u a = extendPtDist u (center a) (west a)
+class SideMidpointAnchor t where
+  sideMidpoint :: DUnit t ~ u => Int -> t -> Point2 u
 
 
--- | 'northeastwards' : @ dist * object -> Point @
--- 
--- Variant of the function 'northwards', but projecting the line 
--- northeastwards from the center of the object.
---
-northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
-                  , u ~ DUnit t ) 
-               => u -> t -> Point2 u
-northeastwards u a = extendPtDist u (center a) (northeast a)
 
+--------------------------------------------------------------------------------
 
--- | 'southeastwards' : @ dist * object -> Point @
+-- | 'projectAnchor' : @ extract_func * dist * object -> Point @
 -- 
--- Variant of the function 'northwards', but projecting the line 
--- southeastwards from the center of the object.
---
-southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
-                  , u ~ DUnit t ) 
-               => u -> t -> Point2 u
-southeastwards u a = extendPtDist u (center a) (southeast a)
-
-
--- | 'southwestwards' : @ dist * object -> Point @
+-- Derive a anchor by projecting a line from the center of an 
+-- object through the intermediate anchor (produced by the 
+-- extraction function). The final answer point is located along
+-- the projected line at the supplied distance @dist@.
 -- 
--- Variant of the function 'northwards', but projecting the line 
--- southwestwards from the center of the object.
+-- E.g. take the north of a rectangle and project it 10 units 
+-- further on:
+--  
+-- > projectAnchor north 10 my_rect
 --
-southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
-                  , u ~ DUnit t ) 
-               => u -> t -> Point2 u
-southwestwards u a = extendPtDist u (center a) (southwest a)
-
-
--- | 'northwestwards' : @ dist * object -> Point @
--- 
--- Variant of the function 'northwards', but projecting the line 
--- northwestwards from the center of the object.
+-- If the distance is zero the answer with be whatever point the 
+-- the extraction function produces.
 --
-northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t
-                  , u ~ DUnit t ) 
-               => u -> t -> Point2 u
-northwestwards u a = extendPtDist u (center a) (northwest a)
+-- If the distance is negative the answer will be along the 
+-- projection line, between the center and the intermediate anchor.
+--
+-- If the distance is positive the anchor will be extend outwards 
+-- from the intermediate anchor.
+--
+projectAnchor :: (Real u, Floating u, u ~ DUnit t, CenterAnchor t) 
+              => (t -> Point2 u) -> u -> t -> Point2 u
+projectAnchor f d a = p1 .+^ (avec ang d)
+  where
+    p1  = f a
+    v   = pvec (center a) p1
+    ang = vdirection v
+     
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs
--- a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs
+++ b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs
@@ -35,23 +35,15 @@
   , HAlign(..)
   , VAlign(..)  
 
+  -- * Cardinal (compass) positions
+  , Cardinal(..)
+
   -- * Advance vector
   , AdvanceVec
   , advanceH
   , advanceV
 
-  -- * Moving points
-  , PointDisplace
-  , displace
-  , displaceVec
-  , displaceH
-  , displaceV
 
-  , ThetaPointDisplace
-  , displaceParallel
-  , displacePerpendicular
-
-
   -- * Monadic drawing
   , MonUnit
 
@@ -61,7 +53,7 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace                         -- package: vector-space
 
 infixr 6 `oplus`
 
@@ -95,15 +87,26 @@
   a `oplus` b = primGroup [a,b]
 
 instance (OPlus a, OPlus b) => OPlus (a,b) where
-  (a,b) `oplus` (a',b') = (a `oplus` a', b `oplus` b')
+  (a,b) `oplus` (m,n) = (a `oplus` m, b `oplus` n)
 
+instance (OPlus a, OPlus b, OPlus c) => OPlus (a,b,c) where
+  (a,b,c) `oplus` (m,n,o) = (a `oplus` m, b `oplus` n, c `oplus` o)
 
+instance (OPlus a, OPlus b, OPlus c, OPlus d) => OPlus (a,b,c,d) where
+  (a,b,c,d) `oplus` (m,n,o,p) = (oplus a m, oplus b n, oplus c o, oplus d p)
+
+
+
 instance OPlus a => OPlus (r -> a) where
   f `oplus` g = \x -> f x `oplus` g x
 
 -- The functional instance (r -> a) also covers (r1 -> r2 -> a),
 -- (r1 -> r2 -> r3 -> a) etc.
 
+instance Num u => OPlus (Vec2 u) where 
+  oplus = (^+^)
+
+
 --------------------------------------------------------------------------------
 
 -- | A Bifunctor class.
@@ -154,7 +157,16 @@
 data VAlign = VLeft | VCenter | VRight
   deriving (Enum,Eq,Ord,Show)
 
+--------------------------------------------------------------------------------
 
+-- Compass positions
+
+-- | An enumeratied type representing the compass positions.
+--
+data Cardinal = NORTH | NORTH_EAST | EAST | SOUTH_EAST 
+              | SOUTH | SOUTH_WEST | WEST | NORTH_WEST
+   deriving (Enum,Eq,Ord,Show) 
+
 --------------------------------------------------------------------------------
 
 -- | Advance vectors provide an idiom for drawing consecutive
@@ -181,85 +193,6 @@
 --
 advanceV :: AdvanceVec u -> u
 advanceV (V2 _ h)  = h
-
---------------------------------------------------------------------------------
--- Displacing points
-
--- | 'PointDisplace' is a type representing functions 
--- @from Point to Point@.
---
--- It is especially useful for building composite graphics where 
--- one part of the graphic is drawn from a different start point 
--- to the other part.
---
-type PointDisplace u = Point2 u -> Point2 u
-
--- | 'displace' : @ x -> y -> PointDisplace @
---
--- Build a combinator to move @Points@ by the supplied @x@ and 
--- @y@ distances.
---
-displace :: Num u => u -> u -> PointDisplace u
-displace dx dy (P2 x y) = P2 (x+dx) (y+dy)
-
-
--- | 'displaceV' : @ (V2 x y) -> PointDisplace @
--- 
--- Version of 'displace' where the displacement is supplied as
--- a vector rather than two parameters.
--- 
-displaceVec :: Num u => Vec2 u -> PointDisplace u
-displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)
-
-
--- | 'displaceH' : @ x -> PointDisplace @
--- 
--- Build a combinator to move @Points@ by horizontally the 
--- supplied @x@ distance.
---
-displaceH :: Num u => u -> PointDisplace u
-displaceH dx (P2 x y) = P2 (x+dx) y
-
--- | 'displaceV' : @ y -> PointDisplace @
--- 
--- Build a combinator to move @Points@ vertically by the supplied 
--- @y@ distance.
---
-displaceV :: Num u => u -> PointDisplace u
-displaceV dy (P2 x y) = P2 x (y+dy)
-
-
--- | 'ThetaPointDisplace' is a type representing functions 
--- @from Radian * Point to Point@.
---
--- It is useful for building arrowheads which are constructed 
--- with an implicit angle representing the direction of the line 
--- at the arrow tip.
---
-type ThetaPointDisplace u = Radian -> PointDisplace u
-
-
-
--- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
--- 
--- Build a combinator to move @Points@ in parallel to the 
--- direction of the implicit angle by the supplied distance 
--- @dist@. 
---
-displaceParallel :: Floating u => u -> ThetaPointDisplace u
-displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d
-
-
--- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
--- 
--- Build a combinator to move @Points@ perpendicular to the 
--- direction of the implicit angle by the supplied distance 
--- @dist@. 
---
-displacePerpendicular :: Floating u => u -> ThetaPointDisplace u
-displacePerpendicular d = 
-    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d
-
 
 
 
diff --git a/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs b/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs
--- a/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs
+++ b/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs
@@ -66,9 +66,10 @@
       { get_bounding_box  :: forall u. FromPtSize u => PtSize -> BoundingBox u 
       , get_cw_table      :: forall u. FromPtSize u => PtSize -> CharWidthTable u
       , get_cap_height    :: forall u. FromPtSize u => PtSize -> u
+      , get_descender     :: forall u. FromPtSize u => PtSize -> u
       }
 
--- | 'MetricsOps' tfor a particular named font.
+-- | 'MetricsOps' for a particular named font.
 -- 
 data FontMetricsOps = FontMetricsOps FontName MetricsOps
 
@@ -101,17 +102,19 @@
     { get_bounding_box  = \sz -> BBox (lowerLeft sz) (upperRight sz)
     , get_cw_table      = \sz _ -> hvec (upscale sz width_vec) 
     , get_cap_height    = \sz -> upscale sz cap_height
+    , get_descender     = \sz -> upscale sz descender
     }
   where
-    llx           = (-23)  / 1000
-    lly           = (-250) / 1000
-    urx           = 715    / 1000
-    ury           = 805    / 1000
-    width_vec     = 600    / 1000
-    cap_height    = 562    / 1000
+    llx             = (-23)  / 1000
+    lly             = (-250) / 1000
+    urx             = 715    / 1000
+    ury             = 805    / 1000
+    width_vec       = 600    / 1000
+    cap_height      = 562    / 1000
+    descender       = (-157) / 1000
 
-    upscale sz d  = fromPtSize $ sz * d
-    lowerLeft sz  = P2 (upscale sz llx) (upscale sz lly) 
-    upperRight sz = P2 (upscale sz urx) (upscale sz ury) 
+    upscale sz d    = fromPtSize $ sz * d
+    lowerLeft sz    = P2 (upscale sz llx) (upscale sz lly) 
+    upperRight sz   = P2 (upscale sz urx) (upscale sz ury) 
 
 
diff --git a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs
--- a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs
+++ b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs
@@ -3,7 +3,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel.Base.QueryDC
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
@@ -12,6 +12,10 @@
 --
 -- Querying the Drawing Context.
 --
+-- \*\* WARNING \*\* - parts of this module especially the 
+-- mono-space glyph metrics need a re-think and will change or be 
+-- dropped.
+--
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Kernel.Base.QueryDC
@@ -43,10 +47,9 @@
 
   -- * Glyph metrics
   , glyphBoundingBox
-  , glyphHeightRange
-  , glyphHeight
   , glyphCapHeight
-
+  , glyphDescender
+  , glyphVerticalSpan
   , cwLookupTable
 
   -- * Default monospace metrics
@@ -108,8 +111,7 @@
 
 
 
--- | Vertical distance between baselines of consecutive text 
--- lines.
+-- | Size of the round corner factor.
 --
 getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u
 getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1)
@@ -117,9 +119,11 @@
 
 
 
--- | Vertical distance between baselines of consecutive text 
--- lines.
+-- | Get the (x,y) margin around text.
 --
+-- Note - not all text operations in Wumpus are drawn with text 
+-- margin. 
+-- 
 getTextMargin :: (DrawingCtxM m, Fractional u, FromPtSize u) => m (u,u)
 getTextMargin = (\(TextMargin xsep ysep) -> (fn xsep, fn ysep))
                     <$> asksDC text_margin
@@ -174,23 +178,32 @@
 glyphQuery :: DrawingCtxM m => (MetricsOps -> PtSize -> u) -> m u
 glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC
 
+-- | Get the font bounding box - this is the maximum boundary of 
+-- the glyphs in the font. The span of the height is expected to 
+-- be bigger than the cap_height plus descender depth.
+--
 glyphBoundingBox :: (FromPtSize u, DrawingCtxM m) => m (BoundingBox u)
 glyphBoundingBox = glyphQuery get_bounding_box
 
 
-glyphHeightRange :: (FromPtSize u, DrawingCtxM m) => m (u,u)
-glyphHeightRange = fn <$> glyphBoundingBox
-  where
-    fn (BBox (P2 _ ymin) (P2 _ ymax)) = (ymin,ymax)
 
 
-glyphHeight :: (FromPtSize u, DrawingCtxM m) => m u
-glyphHeight = (\(ymax,ymin) -> ymax - ymin) <$> glyphHeightRange
 
-
 glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u
 glyphCapHeight = glyphQuery get_cap_height
 
+-- | Note - descender is expected to be negative.
+--
+glyphDescender :: (FromPtSize u, DrawingCtxM m) => m u
+glyphDescender = glyphQuery get_descender
+
+-- | This is the distance from cap_height to descender.
+--
+glyphVerticalSpan :: (FromPtSize u, DrawingCtxM m) => m u
+glyphVerticalSpan = 
+    (\ch dd -> ch - dd) <$> glyphCapHeight <*> glyphDescender
+
+
 cwLookupTable :: (FromPtSize u, DrawingCtxM m) => m (CharWidthTable u)
 cwLookupTable = glyphQuery get_cw_table
 
@@ -271,11 +284,14 @@
     -- no longer quite works... 
 
  
+{-# DEPRECATED monoDefaultPadding "Needs a rethink" #-}
 
 -- | The default padding is half of the /char width/.
 --
 monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u
 monoDefaultPadding = (0.5*) <$> monoCharWidth
+
+
 
 -- | Vector from baseline left to center
 --
diff --git a/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs
--- a/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs
+++ b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs
@@ -58,6 +58,7 @@
   , fontFace
 
   -- * Font / mark drawing size
+  , scalesize
   , doublesize
   , halfsize
 
@@ -79,6 +80,7 @@
 
 import Control.Applicative
 
+import Data.Ratio
 
 --------------------------------------------------------------------------------
 
@@ -214,12 +216,16 @@
 
 --------------------------------------------------------------------------------
 
+scalesize           :: Ratio Int -> DrawingContextF
+scalesize r         = let (n,d) = (numerator r, denominator r)
+                      in (\s sz -> fontSize (n * sz `div` d) s) 
+                           <*> (font_size . font_props)
+
 -- | Set the font size to double the current size, note the font
 -- size also controls the size of dots, arrowsheads etc.
 -- 
 doublesize          :: DrawingContextF
-doublesize          = (\s sz -> fontSize (sz*2) s) 
-                        <*> (font_size . font_props)
+doublesize          = scalesize 2 
 
 
 -- | Set the font size to half the current size, note the font
@@ -229,8 +235,7 @@
 -- 15pt type is 7pt.
 -- 
 halfsize            :: DrawingContextF
-halfsize            = (\s sz -> fontSize (sz `div` 2) s) 
-                        <*> (font_size . font_props)
+halfsize            = scalesize (1%2)
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs b/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs
--- a/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs
@@ -13,7 +13,7 @@
 -- Portability :  GHC 
 --
 -- Extended Graphic object - an AdvanceGraphic is a Graphic 
--- twinned with and AdvanceV vector.
+-- twinned with and advance vector.
 --
 --------------------------------------------------------------------------------
 
@@ -25,33 +25,37 @@
   , DAdvGraphic
 
 
-  , makeAdvGraphic
-  , extractLocGraphic
-  , runAdvGraphic
+  , intoAdvGraphic
+  , emptyAdvGraphic
 
+
   -- * Composition
-  , advplus
+  , advcat
+  , advsep
   , advconcat
+  , advspace
+  , advpunctuate
+  , advfill
 
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
 import Wumpus.Basic.Kernel.Base.ContextFun
-import Wumpus.Basic.Kernel.Base.DrawingContext
-import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 import Wumpus.Basic.Kernel.Objects.BaseObjects
 import Wumpus.Basic.Kernel.Objects.Graphic
 
 import Wumpus.Core                              -- package: wumpus-core
 
+import Data.AffineSpace                         -- package: vector-space
+import Data.VectorSpace
 
-import Control.Applicative
 
+
 -- | /Advance vector/ graphic - this partially models the 
 -- PostScript @show@ command which moves the /current point/ by the
--- width (advance) vector as each character is drawn.
+-- advance (width) vector as each character is drawn.
 --
-type AdvGraphic u      = LocImage u (Point2 u)
+type AdvGraphic u      = LocImage u (Vec2 u)
 
 type DAdvGraphic       = AdvGraphic Double
 
@@ -61,27 +65,35 @@
 
 
 
--- | Construction is different to intoZZ functions hence the 
--- different name.
+
+-- | 'intoAdvGraphic' : @ loc_context_function * graphic -> Image @
 --
-makeAdvGraphic :: DrawingInfo (PointDisplace u)
+-- Build an 'AdvGraphic' from a context function ('CF') that 
+-- generates the answer displacement vector and a 'LocGraphic' 
+-- that draws the 'AdvGraphic'.
+--
+intoAdvGraphic :: LocCF u (Vec2 u)
                -> LocGraphic u 
                -> AdvGraphic u
-makeAdvGraphic dispf gf = 
-    promoteR1 $ \pt -> dispf >>= \fn -> fmap (replaceL $ fn pt) (gf `at` pt)  
+intoAdvGraphic = intoLocImage
 
 
+-- | 'emptyAdvGraphic' : @ AdvGraphic @
+--
+-- Build an empty 'AdvGraphic'.
+-- 
+-- The 'emptyAdvGraphic' is treated as a /null primitive/ by 
+-- @Wumpus-Core@ and is not drawn, the answer vetor generated is
+-- the empty vector @(V2 0 0)@.
+-- 
+emptyAdvGraphic :: Num u => AdvGraphic u
+emptyAdvGraphic = replaceAns (V2 0 0) $ emptyLocGraphic
 
 
 
--- This should probably go - the name is not exact enough...
-
-extractLocGraphic :: AdvGraphic u -> LocGraphic u
-extractLocGraphic = fmap (replaceL uNil)
-
-runAdvGraphic :: DrawingContext  -> Point2 u -> AdvGraphic u 
-              -> (Point2 u, PrimGraphic u)
-runAdvGraphic ctx pt df = runCF1 ctx pt df
+-- runAdvGraphic :: DrawingContext  -> Point2 u -> AdvGraphic u 
+--               -> (Point2 u, PrimGraphic u)
+-- runAdvGraphic ctx pt df = runCF1 ctx pt df
 
 
 
@@ -91,16 +103,64 @@
 -- Note there are opportunities for extra composition operators
 -- like the /picture language/...
 
-infixr 6 `advplus`
 
+-- Naming convention - binary functions are favoured for shorter names.
 
--- | \*\* WARNING \*\* - pending removal.
+infixr 6 `advcat`
+infixr 5 `advsep`
+
+-- | Concatenate the two AdvGraphics.
 --
-advplus :: AdvGraphic u -> AdvGraphic u -> AdvGraphic u
-advplus = chain1
+advcat :: Num u => AdvGraphic u -> AdvGraphic u -> AdvGraphic u
+advcat af ag = promoteR1 $ \start -> 
+                 (af `at` start)        >>= \(v1,prim1) -> 
+                 (ag `at` start .+^ v1) >>= \(v2,prim2) -> 
+                 return (v1 ^+^ v2, prim1 `oplus` prim2)
 
 
+-- | Concatenate the two AdvGraphics spacing them by the supplied 
+-- vector.
+--
+advsep :: Num u => Vec2 u -> AdvGraphic u -> AdvGraphic u -> AdvGraphic u
+advsep sv af ag = promoteR1 $ \start -> 
+                 (af `at` start)        >>= \(v1,prim1) -> 
+                 (ag `at` start .+^ sv ^+^ v1) >>= \(v2,prim2) -> 
+                 return (v1 ^+^ sv ^+^  v2, prim1 `oplus` prim2)
+
+
+-- | Concatenate the list of AdvGraphic with 'advcat'.
+--
 advconcat :: Num u => [AdvGraphic u] -> AdvGraphic u
-advconcat []     = makeAdvGraphic (pure id) emptyLocGraphic
-advconcat [x]    = x
-advconcat (x:xs) = x `chain1` advconcat xs 
+advconcat []     = emptyAdvGraphic
+advconcat (x:xs) = step x xs
+  where
+    step a (b:bs) = step (a `advcat` b) bs
+    step a []     = a
+
+
+-- | Concatenate the list of AdvGraphic with 'advsep'.
+--
+advspace :: Num u => Vec2 u -> [AdvGraphic u] -> AdvGraphic u
+advspace _  []     = emptyAdvGraphic
+advspace sv (x:xs) = step x xs
+  where
+    step a (b:bs) = step (advsep sv a b) bs
+    step a []     = a
+
+
+-- | Concatenate the list of AdvGraphic with 'advsep'.
+--
+advpunctuate :: Num u => AdvGraphic u -> [AdvGraphic u] -> AdvGraphic u
+advpunctuate _  []     = emptyAdvGraphic
+advpunctuate sep (x:xs) = step x xs
+  where
+    step a (b:bs) = step (a `advcat` sep `advcat` b) bs
+    step a []     = a
+
+
+-- | Render the supplied AdvGraphic, but swap the result advance
+-- for the supplied vector. This function has behaviour analogue 
+-- to @fill@ in the @wl-pprint@ library.
+-- 
+advfill :: Num u => Vec2 u -> AdvGraphic u -> AdvGraphic u
+advfill sv = replaceAns sv
diff --git a/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs b/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs
--- a/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs
@@ -38,8 +38,6 @@
   , DLocImage
   , DLocThetaImage
 
-  , hyperlink
-
   ) where
 
 import Wumpus.Basic.Kernel.Base.ContextFun
@@ -180,9 +178,6 @@
 --------------------------------------------------------------------------------
 
 
-hyperlink :: XLink -> Image u a -> Image u a
-hyperlink hypl = 
-    fmap (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim))
 
 
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Bounded.hs b/src/Wumpus/Basic/Kernel/Objects/Bounded.hs
--- a/src/Wumpus/Basic/Kernel/Objects/Bounded.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/Bounded.hs
@@ -30,12 +30,15 @@
   , DBoundedLocThetaGraphic
 
   , emptyBoundedLocGraphic
+  , emptyBoundedLocThetaGraphic
 
   , centerOrthoBBox
   , illustrateBoundedGraphic
   , illustrateBoundedLocGraphic
   , illustrateBoundedLocThetaGraphic
 
+  , bbrectangle
+
   ) where
 
 import Wumpus.Basic.Kernel.Base.BaseDefs
@@ -43,10 +46,10 @@
 import Wumpus.Basic.Kernel.Base.DrawingContext
 import Wumpus.Basic.Kernel.Base.UpdateDC
 import Wumpus.Basic.Kernel.Objects.BaseObjects
+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
 import Wumpus.Basic.Kernel.Objects.Graphic
 
 import Wumpus.Core                              -- package: wumpus-core
-import Wumpus.Core.Colour ( blue )
 
 import Control.Applicative
 
@@ -81,7 +84,7 @@
 
 
 
--- | 'openStroke' : @ theta * bbox -> BBox @
+-- | 'centerOrthoBBox' : @ theta * bbox -> BBox @
 -- 
 -- Rotate a bounding box by @theta@ about its center. Take the 
 -- new bounding box.
@@ -99,11 +102,36 @@
     ctr = boundaryCenter bb
 
 
+
+
+-- | 'emptyBoundedLocGraphic' : @ BoundedLocGraphic @
+--
+-- Build an empty 'BoundedLocGraphic'.
+-- 
+-- The 'emptyBoundedLocGraphic' is treated as a /null primitive/ 
+-- by @Wumpus-Core@ and is not drawn, although it does generate
+-- the minimum bounding box with both the bottom-left and 
+-- upper-right corners at the implicit start point.
+--
 emptyBoundedLocGraphic :: Num u => BoundedLocGraphic u
-emptyBoundedLocGraphic = intoLocImage fn  emptyLocGraphic
+emptyBoundedLocGraphic = intoLocImage fn emptyLocGraphic
   where
     fn = promoteR1 $ \pt -> pure (BBox pt pt)
 
+
+-- | 'emptyBoundedLocThetaGraphic' : @ BoundedLocThetaGraphic @
+--
+-- Build an empty 'BoundedLocThetaGraphic'.
+-- 
+-- The 'emptyBoundedLocThetaGraphic' is treated as a /null primitive/ 
+-- by @Wumpus-Core@ and is not drawn, although it does generate
+-- the minimum bounding box with both the bottom-left and 
+-- upper-right corners at the implicit start point (the implicit 
+-- inclination can be ignored).
+--
+emptyBoundedLocThetaGraphic :: Num u => BoundedLocThetaGraphic u
+emptyBoundedLocThetaGraphic = lift1R2 emptyBoundedLocGraphic
+
 --------------------------------------------------------------------------------
 -- 
 
@@ -126,15 +154,15 @@
     promoteR2 $ \pt theta-> illustrateBoundedGraphic $ apply2R2 mf pt theta
 
 
-
+-- 
 bbrectangle :: Fractional u => BoundingBox u -> Graphic u
 bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))
     | llx == urx && lly == ury = emptyLocGraphic `at` p1
     | otherwise                = 
         localize drawing_props $ rect1 `oplus` cross
   where
-    drawing_props = strokeColour blue . capRound . dashPattern (Dash 0 [(1,2)])
+    drawing_props = capRound . dashPattern (Dash 0 [(1,2)])
     rect1         = strokedRectangle (urx-llx) (ury-lly) `at` p1
-    cross         = straightLineBetween p1 p2 
-                      `oplus` straightLineBetween (P2 llx ury) (P2 urx lly)
+    cross         = straightLineGraphic p1 p2 
+                      `oplus` straightLineGraphic (P2 llx ury) (P2 urx lly)
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Connector.hs b/src/Wumpus/Basic/Kernel/Objects/Connector.hs
--- a/src/Wumpus/Basic/Kernel/Objects/Connector.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/Connector.hs
@@ -29,15 +29,19 @@
   , ConnectorImage
   , DConnectorImage
 
-
+  , intoConnectorImage
+  , emptyConnectorGraphic
 
   ) where
 
+import Wumpus.Basic.Kernel.Base.BaseDefs
 import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Objects.BaseObjects
+import Wumpus.Basic.Kernel.Objects.Graphic
 
 -- import Wumpus.Core                              -- package: wumpus-core
 
+import Control.Applicative
 
 --------------------------------------------------------------------------------
 -- Connector Graphic
@@ -48,7 +52,9 @@
 --
 type ConnectorGraphic u         = ConnectorCF u (GraphicAns u)
 
-
+-- | Alias of 'ConnectorGraphic' where the unit type is 
+-- specialized to Double. 
+--
 type DConnectorGraphic          = ConnectorGraphic Double
 
 
@@ -61,14 +67,46 @@
 -- | ConnectorImage is a connector drawn between two points 
 -- constructing an Image.
 --
--- Usually the answer type of a ConnectorImage will be a Path so
--- the Points ar @midway@, @atstart@ etc. can be taken on it.
+-- Usually the answer type of a ConnectorImage will be a Path 
+-- (defined in Wumpus-Drawing) so the points at @midway@, 
+-- @atstart@ etc. or the end directions and tangents can be taken 
+-- on it.
 --
 type ConnectorImage u a = ConnectorCF u (ImageAns u a)
 
 
+-- | Alias of 'ConnectorImage' where the unit type is 
+-- specialized to Double. 
+--
 type DConnectorImage a  = ConnectorImage Double a
 
 
+
+-- | 'intoConnectorImage' : @ conn_context_function * conn_graphic -> LocImage @
+--
+-- /Connector/ version of 'intoImage'. 
+-- 
+-- The 'ConnectorImage' is built as a function from an implicit 
+-- start and end points to the answer.
+--
+intoConnectorImage :: ConnectorCF u a -> ConnectorGraphic u 
+                   -> ConnectorImage u a
+intoConnectorImage = liftA2 (\a (_,b) -> (a,b))
+
+
+-- | 'emptyConnectorGraphic' : @ ConnectorGraphic @
+--
+-- Build an empty 'ConnectorGraphic'.
+-- 
+-- The 'emptyConnectorGraphic' is treated as a /null primitive/ by 
+-- @Wumpus-Core@ and is not drawn, although it does generate a 
+-- bounding box around the rectangular hull of the start and end 
+-- points.
+-- 
+emptyConnectorGraphic :: Num u => ConnectorGraphic u 
+emptyConnectorGraphic = promoteR2 $ \start end -> 
+    let a = emptyLocGraphic `at` start
+        b = emptyLocGraphic `at` end
+    in a `oplus` b
 
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
--- a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
@@ -4,7 +4,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel.Objects.CtxPicture
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
@@ -15,14 +15,16 @@
 -- 
 -- This is the corresponding type to Picture in the Wumpus-Core.
 -- 
--- CtxPicture is a function from the DrawingContext to a Picture.
--- Internally the result is actually a (Maybe Picture) and not a 
--- Picture, this is a trick to promote the extraction from 
--- possibly empty drawings (created by TraceDrawing) to the 
--- top-level of the type hierarchy where client code can deal 
--- with empty drawings explicitly (empty Pictures cannot be 
--- rendered by Wumpus-Core).
+-- Note - many of the composition functions are in 
+-- /destructor form/. As Wumpus cannot make a Picture from an 
+-- empty list of Pictures, /destructor form/ decomposes the 
+-- list into the @head@ and @rest@ as arguments in the function 
+-- signature, rather than take a possibly empty list and have to 
+-- throw an error.
 -- 
+-- TODO - PosImage no longer supports composition operators, so 
+-- better names are up for grabs...
+-- 
 --------------------------------------------------------------------------------
 
 module Wumpus.Basic.Kernel.Objects.CtxPicture
@@ -38,36 +40,33 @@
   , mapCtxPicture
 
   -- * Composition
-  , over 
-  , under
+  , cxpBeneath
 
-  , centric
-  , nextToH
-  , nextToV
+  , cxpUniteCenter
+  , cxpRight
+  , cxpDown
   
-  , atPoint 
-  , centeredAt
+  , cxpCenteredAt
 
-  , zconcat
 
-  , hcat 
-  , vcat
+  , cxpRow 
+  , cxpColumn
 
 
-  , hspace
-  , vspace
-  , hsep
-  , vsep
+  , cxpRightSep
+  , cxpDownSep
+  , cxpRowSep
+  , cxpColumnSep
  
   -- * Compose with alignment
-  , alignH
-  , alignV
-  , alignHSep
-  , alignVSep
-  , hcatA
-  , vcatA
-  , hsepA
-  , vsepA
+  , cxpAlignH
+  , cxpAlignV
+  , cxpAlignSepH
+  , cxpAlignSepV
+  , cxpAlignRow
+  , cxpAlignColumn
+  , cxpAlignRowSep
+  , cxpAlignColumnSep
 
 
   ) where
@@ -87,9 +86,34 @@
 import Data.List ( foldl' )
 
 
+-- Note - PosGraphic should take priority for the good names.
 
+-- | A /Contextual Picture/.
+-- 
+-- This type corresponds to the 'Picture' type in Wumpus-Core, but
+-- it is embedded with a 'DrawingContext' (for font properties, 
+-- fill colour etc.). So it is a function 
+-- /from DrawingContext to Picture/.
+--
+-- Internally the result is actually a (Maybe Picture) and not a 
+-- Picture, this is a trick to promote the extraction from 
+-- possibly empty drawings (created by TraceDrawing) to the 
+-- top-level of the type hierarchy where client code can deal 
+-- with empty drawings explicitly (empty Pictures cannot be 
+-- rendered by Wumpus-Core).
+--
+-- > a `oplus` b
+--
+-- The 'OPlus' (semigroup) instance for 'CtxPicture' draws picture 
+-- a in front of picture b in the z-order, neither picture is 
+-- moved. (Usually the picture composition operators in this 
+-- module move the second picture aligning it somehow with the 
+-- first).
+--
 newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) }
 
+-- | Version of CtxPicture specialized to Double for the unit type.
+--
 type DCtxPicture = CtxPicture Double
 
 
@@ -97,22 +121,40 @@
 
 
 
-
+-- | 'runCtxPicture' : @ drawing_ctx * ctx_picture -> Maybe Picture @
+--
+-- Run a 'CtxPicture' with the supplied 'DrawingContext' 
+-- producing a 'Picture'.
+--
+-- The resulting Picture may be empty. Wumpus-Core cannot 
+-- generate empty pictures as they have no bounding box, so the 
+-- result is wrapped within a Maybe. This delegates reponsibility 
+-- for handling empty pictures to client code.
+--
 runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u)
 runCtxPicture ctx drw = runCF ctx (getCtxPicture drw)  
 
-
+-- | 'runCtxPictureU' : @ drawing_ctx * ctx_picture -> Picture @
+--
+-- /Unsafe/ version of 'runCtxPicture'.
+--
+-- This function throws a runtime error when supplied with an
+-- empty CtxPicture.
+--
 runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u
 runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df
   where
     fk = error "runCtxPictureU - empty CtxPicture."   
 
 
-
+-- | 'drawTracing' : @ trace_drawing  -> CtxPicture @
+--
+-- Transform a 'TraceDrawing' into a 'CtxPicture'.
+--
 drawTracing :: (Real u, Floating u, FromPtSize u) 
             => TraceDrawing u a -> CtxPicture u
 drawTracing mf = CtxPicture $ 
-    drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) )
+    drawingCtx >>= \ctx -> return (liftToPictureMb $ execTraceDrawing ctx mf)
 
 
 -- Note - cannot get an answer from a TraceDrawing with this 
@@ -127,15 +169,34 @@
 -- a where this would be useful (rather than just making things 
 -- more complicated)? 
 --
---------------------------------------------------------------------------------
 
-clipCtxPicture :: (Num u, Ord u) => (PrimPath u) -> CtxPicture u -> CtxPicture u
+-- | 'clipCtxPicture' : @ path * ctx_picture -> CtxPicture @
+--
+-- Clip a picture with a path.
+-- 
+clipCtxPicture :: (Num u, Ord u) => PrimPath u -> CtxPicture u -> CtxPicture u
 clipCtxPicture cpath = mapCtxPicture (clip cpath)
 
+-- Note - it seems preferable to clip a smaller type in the 
+-- hierarchy than CtxPicture. But which one Graphic, TraceDrawing? 
+-- ...
+--
 
+
+-- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @
+--
+-- Apply a picture transformation function to the 'Picture'
+-- warpped in a 'CtxPicture'.
+--
 mapCtxPicture :: (Picture u -> Picture u) -> CtxPicture u -> CtxPicture u
 mapCtxPicture pf = CtxPicture . fmap (fmap pf) . getCtxPicture
 
+
+--------------------------------------------------------------------------------
+
+
+
+
 instance (Real u, Floating u) => Rotate (CtxPicture u) where 
   rotate ang = mapCtxPicture (rotate ang)
 
@@ -226,23 +287,24 @@
 
 
 
-  
--- Note - do not export the empty drawing. It is easier to 
--- pretend it doesn't exist.
--- 
-empty_drawing :: (Real u, Floating u, FromPtSize u) => CtxPicture u
-empty_drawing = drawTracing $ return ()
 
 
-
-
 --------------------------------------------------------------------------------
 -- Composition operators
 
+-- Naming convention - Wumpus-Core already prefixes operations
+-- on Pictures with pic. As the picture operators here work on a
+-- different type, they merit a different naming scheme.
+--
+-- Unfortunately the @cxp_@ prefix is rather ugly...
+--
+-- Directional names seem better than positional ones (less 
+-- ambiguous as when used as binary operators).
+--
 
-drawingConcat :: (Picture u -> Picture u -> Picture u) 
-              -> CtxPicture u -> CtxPicture u -> CtxPicture u
-drawingConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)
+cxpConcat :: (Picture u -> Picture u -> Picture u) 
+          -> CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)
 
 
 
@@ -273,49 +335,39 @@
           -> (a -> a -> Picture u -> Picture u) 
           -> CtxPicture u -> CtxPicture u
           -> CtxPicture u
-megaCombR qL qR trafoR = drawingConcat fn
+megaCombR qL qR trafoR = cxpConcat fn
   where
     fn pic1 pic2 = let a    = qL pic1
                        b    = qR pic2
                        p2   = trafoR a b pic2
                    in pic1 `picOver` p2
 
-
-
-
--- | > a `over` b
+-- | > a `oplus` b
 -- 
 -- Place \'drawing\' a over b. The idea of @over@ here is in 
 -- terms z-ordering, nither picture a or b are actually moved.
 --
-over    :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-over    = drawingConcat picOver
-
+instance (Num u, Ord u) => OPlus (CtxPicture u) where
+  oplus = cxpConcat picOver
 
 
--- | > a `under` b
---
--- Similarly @under@ draws the first drawing behind 
--- the second but move neither.
+-- | 'cxpBeneath' : @ ctx_picture1 * ctx_picture2 -> CtxPicture @
+-- 
+-- > a `cxpBeneath` b
 --
-under :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-under = flip over
-
-
-
--- | Move in both the horizontal and vertical.
+-- Similarly @beneath@ draws the first picture behind the second 
+-- picture in the z-order, neither picture is moved.
 --
-move :: (Num u, Ord u) => Vec2 u -> CtxPicture u -> CtxPicture u
-move v = mapCtxPicture (\p -> p `picMoveBy` v)
-
+cxpBeneath :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpBeneath = flip oplus
 
 
 
 --------------------------------------------------------------------------------
 -- Composition
 
-infixr 5 `nextToV`
-infixr 6 `nextToH`, `centric`
+infixr 5 `cxpDown`
+infixr 6 `cxpRight`, `cxpUniteCenter`
 
 
 
@@ -323,51 +375,47 @@
 -- | Draw @a@, move @b@ so its center is at the same center as 
 -- @a@, @b@ is drawn over underneath in the zorder.
 --
--- > a `centeric` b 
---
+-- > a `cxpUniteCenter` b 
 --
-centric :: (Fractional u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-centric = megaCombR boundaryCtr boundaryCtr moveFun
+
+cxpUniteCenter :: (Fractional u, Ord u) 
+               => CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpUniteCenter = megaCombR boundaryCtr boundaryCtr moveFun
   where
     moveFun p1 p2 pic =  let v = p1 .-. p2 in pic `picMoveBy` v
 
-
+--
+-- Are combinator names less ambiguous if they name direction
+-- rather than position?
+--
 
--- | > a `nextToH` b
+-- | > a `cxpRight` b
 -- 
--- Horizontal composition - move @b@, placing it to the right 
--- of @a@.
+-- Horizontal composition - position picture @b@ to the right of 
+-- picture @a@.
 -- 
-nextToH :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
+cxpRight :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpRight = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
   where 
     moveFun a b pic = pic `picMoveBy` hvec (a - b)
 
 
 
--- | > a `nextToV` b
+-- | > a `cxpDown` b
 --
--- Vertical composition - move @b@, placing it below @a@.
+-- Vertical composition - position picture @b@ /down/ from picture
+-- @a@.
 --
-nextToV :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
-nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
+cxpDown :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpDown = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
   where 
     moveFun a b drw = drw `picMoveBy` vvec (a - b)
 
 
--- | Place the picture at the supplied point.
---
--- `atPoint` was previous the `at` operator.
--- 
-atPoint :: (Num u, Ord u) => CtxPicture u -> Point2 u  -> CtxPicture u
-p `atPoint` (P2 x y) = move (V2 x y) p
-
-
-
 -- | Center the picture at the supplied point.
 --
-centeredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u
-centeredAt d (P2 x y) = mapCtxPicture fn d
+cxpCenteredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u
+cxpCenteredAt d (P2 x y) = mapCtxPicture fn d
   where
     fn p = let bb = boundary p
                dx = x - (boundaryWidth  bb * 0.5)
@@ -375,29 +423,31 @@
            in p `picMoveBy` vec dx dy
 
 
--- | Concatenate the list of drawings. 
---
--- No pictures are moved. 
---
-zconcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u
-zconcat []     = empty_drawing
-zconcat (d:ds) = foldl' over d ds
 
-
-
-
--- | Concatenate the list pictures @xs@ horizontally.
+-- | 'cxpRow' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @
 -- 
-hcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u
-hcat []     = empty_drawing
-hcat (d:ds) = foldl' nextToH d ds
+-- Make a row of pictures concatenating them horizontally.
+-- 
+-- Note - this function is in /destructor form/. As Wumpus cannot
+-- make a Picture from an empty list of Pictures, 
+-- /destructor form/ decomposes the list into the @head@ and the 
+-- @rest@ in the function signature, rather than take a possibly
+-- empty list and have to throw an error.
+-- 
+cxpRow :: (Real u, Floating u, FromPtSize u) 
+       => CtxPicture u -> [CtxPicture u] -> CtxPicture u
+cxpRow = foldl' cxpRight
 
 
--- | Concatenate the list of pictures @xs@ vertically.
+-- | 'cxpColumn' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @
+-- 
+-- Make a column of pictures concatenating them vertically.
+-- 
+-- Note - this function is in /destructor form/.
 --
-vcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u
-vcat []     = empty_drawing
-vcat (d:ds) = foldl' nextToV d ds
+cxpColumn :: (Real u, Floating u, FromPtSize u) 
+          => CtxPicture u -> [CtxPicture u] -> CtxPicture u
+cxpColumn = foldl' cxpDown
 
 
 
@@ -407,13 +457,13 @@
 
 
 
--- | > hspace n a b
+-- | > cxpRightSep n a b
 --
 -- Horizontal composition - move @b@, placing it to the right 
 -- of @a@ with a horizontal gap of @n@ separating the pictures.
 --
-hspace :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
-hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
+cxpRightSep :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpRightSep n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
   where
     moveFun a b pic = pic `picMoveBy` hvec (n + a - b)
 
@@ -421,39 +471,40 @@
 
 
 
--- | > vspace n a b
+-- | > cxpDownSep n a b
 --
 -- Vertical composition - move @b@, placing it below @a@ with a
 -- vertical gap of @n@ separating the pictures.
 --
-vspace :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
-vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
+cxpDownSep :: (Num u, Ord u) 
+           => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpDownSep n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
   where 
     moveFun a b pic = pic `picMoveBy`  vvec (a - b - n)
 
 
 
--- | > hsep n xs
+-- | > picRowSep n x xs
 --
 -- Concatenate the list of pictures @xs@ horizontally with 
 -- @hspace@ starting at @x@. The pictures are interspersed with 
 -- spaces of @n@ units.
 --
-hsep :: (Real u, Floating u, FromPtSize u) => u -> [CtxPicture u] -> CtxPicture u
-hsep _ []     = empty_drawing
-hsep n (d:ds) = foldl' (hspace n) d ds
+cxpRowSep :: (Real u, Floating u, FromPtSize u) 
+          => u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
+cxpRowSep n = foldl' (cxpRightSep n)
 
 
 
--- | > vsep n xs
+-- | > vsepPic n xs
 --
 -- Concatenate the list of pictures @xs@ vertically with 
 -- @vspace@ starting at @x@. The pictures are interspersed with 
 -- spaces of @n@ units.
 --
-vsep :: (Real u, Floating u, FromPtSize u) => u -> [CtxPicture u] -> CtxPicture u
-vsep _ []     = empty_drawing
-vsep n (d:ds) = foldl' (vspace n) d ds
+cxpColumnSep :: (Real u, Floating u, FromPtSize u) 
+             => u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
+cxpColumnSep n = foldl' (cxpDownSep n)
 
 
 --------------------------------------------------------------------------------
@@ -463,29 +514,32 @@
 alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2)
 
 
+-- Note - these don\'t conform to the naming convention, but using 
+-- /Right/ in the names would be confusing with alignment.
 
--- | > alignH align a b
+
+-- | > cxpAlignH align a b
 -- 
 -- Horizontal composition - move @b@, placing it to the right 
 -- of @a@ and align it with the top, center or bottom of @a@.
 -- 
-alignH :: (Fractional u, Ord u) 
-       =>  HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
-alignH HTop     = megaCombR boundaryNE    boundaryNW     alignMove
-alignH HCenter  = megaCombR boundaryE    boundaryW     alignMove
-alignH HBottom  = megaCombR boundarySE boundarySW  alignMove
+cxpAlignH :: (Fractional u, Ord u) 
+          =>  HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpAlignH HTop     = megaCombR boundaryNE boundaryNW  alignMove
+cxpAlignH HCenter  = megaCombR boundaryE  boundaryW   alignMove
+cxpAlignH HBottom  = megaCombR boundarySE boundarySW  alignMove
 
 
--- | > alignV align a b
+-- | > cxpAlignV align a b
 -- 
 -- Vertical composition - move @b@, placing it below @a@ 
 -- and align it with the left, center or right of @a@.
 -- 
-alignV :: (Fractional u, Ord u) 
+cxpAlignV :: (Fractional u, Ord u) 
        => VAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
-alignV VLeft    = megaCombR boundarySW  boundaryNW   alignMove
-alignV VCenter  = megaCombR boundaryS   boundaryN    alignMove
-alignV VRight   = megaCombR boundarySE boundaryNE  alignMove
+cxpAlignV VLeft    = megaCombR boundarySW boundaryNW alignMove
+cxpAlignV VCenter  = megaCombR boundaryS  boundaryN  alignMove
+cxpAlignV VRight   = megaCombR boundarySE boundaryNE  alignMove
 
 
 
@@ -495,69 +549,67 @@
 
 
 
--- | > alignHSep align sep a b
+-- | > cxpAlignSepH align sep a b
 -- 
--- Spacing version of alignH - move @b@ to the right of @a@ 
+-- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@ 
 -- separated by @sep@ units, align @b@ according to @align@.
 -- 
-alignHSep :: (Fractional u, Ord u) 
-          => HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
-alignHSep HTop    dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))
-alignHSep HCenter dx = megaCombR boundaryE  boundaryW  (alignMove2 (hvec dx))
-alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))
+cxpAlignSepH :: (Fractional u, Ord u) 
+               => HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpAlignSepH align dx = go align
+  where
+    go HTop    = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))
+    go HCenter = megaCombR boundaryE  boundaryW  (alignMove2 (hvec dx))
+    go HBottom = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))
 
 
--- | > alignVSep align sep a b
+-- | > cxpAlignSepV align sep a b
 -- 
 -- Spacing version of alignV - move @b@ below @a@ 
 -- separated by @sep@ units, align @b@ according to @align@.
 -- 
-alignVSep :: (Fractional u, Ord u) 
-          => VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
-alignVSep VLeft   dy = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) 
-alignVSep VCenter dy = megaCombR boundaryS  boundaryN  (alignMove2 $ vvec (-dy)) 
-alignVSep VRight  dy = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy))
+cxpAlignSepV :: (Fractional u, Ord u) 
+               => VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
+cxpAlignSepV align dy = go align
+  where
+    go VLeft   = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) 
+    go VCenter = megaCombR boundaryS  boundaryN  (alignMove2 $ vvec (-dy)) 
+    go VRight  = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy))
 
 
--- | Variant of 'hcat' that aligns the pictures as well as
+-- | Variant of 'cxpRow' that aligns the pictures as well as
 -- concatenating them.
 --
-hcatA :: (Real u, Floating u, FromPtSize u) 
-      => HAlign -> [CtxPicture u] -> CtxPicture u
-hcatA _  []     = empty_drawing
-hcatA ha (d:ds) = foldl' (alignH ha) d ds
+cxpAlignRow :: (Real u, Floating u, FromPtSize u) 
+            => HAlign -> CtxPicture u-> [CtxPicture u] -> CtxPicture u
+cxpAlignRow ha = foldl' (cxpAlignH ha)
 
 
 
--- | Variant of 'vcat' that aligns the pictures as well as
+-- | Variant of 'cxpColumn' that aligns the pictures as well as
 -- concatenating them.
 --
-vcatA :: (Real u, Floating u, FromPtSize u) 
-      => VAlign -> [CtxPicture u] -> CtxPicture u
-vcatA _  []     = empty_drawing
-vcatA va (d:ds) = foldl' (alignV va) d ds
+cxpAlignColumn :: (Real u, Floating u, FromPtSize u) 
+               => VAlign -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
+cxpAlignColumn va = foldl' (cxpAlignV va)
 
 
--- | Variant of @hsep@ that aligns the pictures as well as
+-- | Variant of 'cxpRow' that aligns the pictures as well as
 -- concatenating and spacing them.
 --
-hsepA :: (Real u, Floating u, FromPtSize u) 
-      => HAlign -> u -> [CtxPicture u] -> CtxPicture u
-hsepA _  _ []     = empty_drawing
-hsepA ha n (d:ds) = foldl' op d ds
-  where 
-    a `op` b = alignHSep ha n a b 
+cxpAlignRowSep :: (Real u, Floating u, FromPtSize u) 
+                 => HAlign -> u -> CtxPicture u -> [CtxPicture u] 
+                 -> CtxPicture u
+cxpAlignRowSep ha n = foldl' (cxpAlignSepH ha n)
 
 
--- | Variant of @vsep@ that aligns the pictures as well as
+-- | Variant of 'cxpColumn' that aligns the pictures as well as
 -- concatenating and spacing them.
 --
-vsepA :: (Real u, Floating u, FromPtSize u) 
-      => VAlign -> u -> [CtxPicture u] -> CtxPicture u
-vsepA _  _ []     = empty_drawing
-vsepA va n (d:ds) = foldl' op d ds
-  where 
-    a `op` b = alignVSep va n a b 
+cxpAlignColumnSep :: (Real u, Floating u, FromPtSize u) 
+                    => VAlign -> u -> CtxPicture u -> [CtxPicture u] 
+                    -> CtxPicture u
+cxpAlignColumnSep va n = foldl' (cxpAlignSepV va n) 
 
 
 
diff --git a/src/Wumpus/Basic/Kernel/Objects/Displacement.hs b/src/Wumpus/Basic/Kernel/Objects/Displacement.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/Displacement.hs
@@ -0,0 +1,277 @@
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.Displacement
+-- Copyright   :  (c) Stephen Tetley 2010
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Displacing points - often start points. 
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.Displacement
+  (
+
+
+  -- * Moving points and angles
+    PointDisplace
+  , ThetaDisplace
+  , ThetaPointDisplace
+
+
+  , moveStart
+  , moveStartTheta
+  , moveStartThetaPoint
+  , moveStartThetaAngle
+
+  , displace
+  , displaceVec
+  , displaceH
+  , displaceV
+
+  , northwards
+  , southwards 
+  , eastwards
+  , westwards  
+
+  , northeastwards
+  , northwestwards
+  , southeastwards
+  , southwestwards
+
+
+  , displaceParallel
+  , displacePerpendicular
+  , displaceOrtho
+
+  , thetaNorthwards
+  , thetaSouthwards 
+  , thetaEastwards
+  , thetaWestwards  
+
+  , thetaNortheastwards
+  , thetaNorthwestwards
+  , thetaSoutheastwards
+  , thetaSouthwestwards
+
+  ) where
+
+
+import Wumpus.Basic.Kernel.Base.ContextFun
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+
+
+--------------------------------------------------------------------------------
+-- Displacing points
+
+-- | 'PointDisplace' is a type representing functions 
+-- @from Point to Point@.
+--
+-- It is especially useful for building composite graphics where 
+-- one part of the graphic is drawn from a different start point 
+-- to the other part.
+--
+type PointDisplace u = Point2 u -> Point2 u
+
+
+-- | 'ThetaDisplace' is a type representing functions 
+-- @from Radian to Radian@.
+--
+-- It is especially useful for building composite graphics where 
+-- one part of the graphic is drawn from a different start point 
+-- to the other part.
+--
+type ThetaDisplace = Radian -> Radian
+
+
+-- | 'ThetaPointDisplace' is a type representing functions 
+-- @from Radian * Point to Point@.
+--
+-- It is useful for building arrowheads which are constructed 
+-- with an implicit angle representing the direction of the line 
+-- at the arrow tip.
+--
+type ThetaPointDisplace u = Radian -> PointDisplace u
+
+
+
+-- | Move the start-point of a 'LocCF' with the supplied 
+-- displacement function.
+--
+moveStart :: PointDisplace u -> LocCF u a -> LocCF u a
+moveStart f ma = promoteR1 $ \pt -> apply1R1 ma (f pt)
+
+
+
+-- | Move the start-point of a 'LocThetaCF' with the supplied 
+-- displacement function.
+--
+moveStartTheta :: ThetaPointDisplace u -> LocThetaCF u a -> LocThetaCF u a
+moveStartTheta f ma = promoteR2 $ \pt theta -> let p2 = f theta pt 
+                                               in apply2R2 ma p2 theta
+
+
+-- | Move the start-point of a 'LocThetaCF' with the supplied 
+-- displacement function.
+--
+moveStartThetaPoint :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a
+moveStartThetaPoint f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta
+
+
+-- | Change the inclination of a 'LocThetaCF' with the supplied 
+-- displacement function.
+--
+moveStartThetaAngle :: ThetaDisplace -> LocThetaCF u a -> LocThetaCF u a
+moveStartThetaAngle f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta)
+
+
+
+--------------------------------------------------------------------------------
+-- PointDisplace functions
+
+-- | 'displace' : @ x -> y -> PointDisplace @
+--
+-- Build a combinator to move @Points@ by the supplied @x@ and 
+-- @y@ distances.
+--
+displace :: Num u => u -> u -> PointDisplace u
+displace dx dy (P2 x y) = P2 (x+dx) (y+dy)
+
+
+-- | 'displaceV' : @ (V2 x y) -> PointDisplace @
+-- 
+-- Version of 'displace' where the displacement is supplied as
+-- a vector rather than two parameters.
+-- 
+displaceVec :: Num u => Vec2 u -> PointDisplace u
+displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)
+
+
+-- | 'displaceH' : @ x -> PointDisplace @
+-- 
+-- Build a combinator to move @Points@ by horizontally the 
+-- supplied @x@ distance.
+--
+displaceH :: Num u => u -> PointDisplace u
+displaceH dx (P2 x y) = P2 (x+dx) y
+
+-- | 'displaceV' : @ y -> PointDisplace @
+-- 
+-- Build a combinator to move @Points@ vertically by the supplied 
+-- @y@ distance.
+--
+displaceV :: Num u => u -> PointDisplace u
+displaceV dy (P2 x y) = P2 x (y+dy)
+
+
+-- Cardinal displacement 
+
+
+
+northwards :: Num u => u -> PointDisplace u
+northwards = displaceV
+
+
+southwards :: Num u => u -> PointDisplace u
+southwards =  displaceV . negate
+
+eastwards :: Num u => u -> PointDisplace u
+eastwards = displaceH
+
+westwards :: Num u => u -> PointDisplace u
+westwards = displaceH . negate
+
+northeastwards :: Floating u => u -> PointDisplace u
+northeastwards = displaceVec . avec (0.25 * pi)
+
+northwestwards ::  Floating u => u -> PointDisplace u
+northwestwards = displaceVec . avec (0.75 * pi)
+
+southeastwards ::  Floating u => u -> PointDisplace u
+southeastwards = displaceVec . avec (1.75 * pi)
+
+southwestwards ::  Floating u => u -> PointDisplace u
+southwestwards = displaceVec . avec (1.25 * pi)
+
+
+--------------------------------------------------------------------------------
+-- ThetaPointDisplace functions
+
+
+-- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
+-- 
+-- Build a combinator to move @Points@ in parallel to the 
+-- direction of the implicit angle by the supplied distance 
+-- @dist@. 
+--
+displaceParallel :: Floating u => u -> ThetaPointDisplace u
+displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d
+
+
+-- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
+-- 
+-- Build a combinator to move @Points@ perpendicular to the 
+-- inclnation of the implicit angle by the supplied distance 
+-- @dist@. 
+--
+displacePerpendicular :: Floating u => u -> ThetaPointDisplace u
+displacePerpendicular d = 
+    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d
+
+
+
+-- | 'displaceOrtho' : @ vec -> ThetaPointDisplace @
+-- 
+-- This is a combination of @displaceParallel@ and 
+-- @displacePerpendicular@, with the x component of the vector
+-- displaced in parallel and the y component displaced
+-- perpendicular. 
+-- 
+displaceOrtho :: Floating u => Vec2 u -> ThetaPointDisplace u
+displaceOrtho (V2 x y) = \theta -> 
+    displaceParallel x theta . displacePerpendicular y theta
+
+
+thetaNorthwards :: Floating u => u -> ThetaPointDisplace u
+thetaNorthwards = displacePerpendicular
+
+
+thetaSouthwards :: Floating u => u -> ThetaPointDisplace u
+thetaSouthwards = displacePerpendicular . negate
+
+
+thetaEastwards :: Floating u => u -> ThetaPointDisplace u
+thetaEastwards = displaceParallel
+
+
+thetaWestwards :: Floating u => u -> ThetaPointDisplace u
+thetaWestwards = displaceParallel . negate
+
+thetaNortheastwards :: Floating u => u -> ThetaPointDisplace u
+thetaNortheastwards d = 
+    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.25*pi)) d
+
+
+thetaNorthwestwards :: Floating u => u -> ThetaPointDisplace u
+thetaNorthwestwards d = 
+    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.75*pi)) d
+
+
+thetaSoutheastwards :: Floating u => u -> ThetaPointDisplace u
+thetaSoutheastwards d = 
+    \theta pt -> pt .+^ avec (circularModulo $ theta + (1.75*pi)) d
+
+
+thetaSouthwestwards :: Floating u => u -> ThetaPointDisplace u
+thetaSouthwestwards d = 
+    \theta pt -> pt .+^ avec (circularModulo $ theta + (1.25*pi)) d
+
diff --git a/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs b/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs
@@ -0,0 +1,651 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+-- Copyright   :  (c) Stephen Tetley 2010-2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Graphic type - this is largely equivalent to Primitive in
+-- Wumpus-Core, but drawing attributes are implicitly supplied 
+-- by the DrawingContext.
+--
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.DrawingPrimitives
+  (
+
+  -- * Paths
+    locPath
+  , emptyLocPath
+
+  , openStroke
+  , closedStroke
+  , filledPath
+  , borderedPath
+
+  -- * Text
+  , textline
+  , rtextline
+  , escapedline
+  , rescapedline
+
+  , hkernline
+  , vkernline
+
+  -- * Lines
+  , straightLine
+  , straightLineGraphic
+  , curveGraphic
+
+  -- * Circles
+  , strokedCircle
+  , filledCircle
+  , borderedCircle
+
+  -- * Ellipses
+  , strokedEllipse
+  , rstrokedEllipse
+  , filledEllipse
+  , rfilledEllipse
+
+  , borderedEllipse
+  , rborderedEllipse
+
+  -- * Rectangles
+  , strokedRectangle
+  , filledRectangle
+  , borderedRectangle
+
+  -- * Disks  
+  , strokedDisk
+  , filledDisk
+  , borderedDisk
+
+  , strokedEllipseDisk
+  , filledEllipseDisk
+  , borderedEllipseDisk
+
+  ) where
+
+import Wumpus.Basic.Kernel.Base.ContextFun
+import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Base.WrappedPrimitive
+import Wumpus.Basic.Kernel.Objects.Graphic
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+import Control.Applicative
+
+
+
+-- Helper
+--
+graphicAns :: Primitive u -> (UNil u, PrimGraphic u)
+graphicAns p = (uNil, primGraphic p)
+
+
+--------------------------------------------------------------------------------
+-- Paths
+
+-- | 'locPath' : @ [next_vector] -> (Point2 ~> PrimPath) @
+--
+-- Create a path 'LocCF' - i.e. a functional type 
+-- /from Point to PrimPath/.
+-- 
+-- This is the analogue to 'vectorPath' in @Wumpus-Core@, but the 
+-- result is produced /within/ the 'DrawingContext'.
+--
+locPath :: Num u => [Vec2 u] -> LocCF u (PrimPath u)
+locPath vs = promoteR1 $ \pt  -> pure $ vectorPath pt vs
+
+
+-- | 'emptyLocPath' : @ (Point ~> PrimPath) @
+--
+-- Create an empty path 'LocCF' - i.e. a functional type 
+-- /from Point to PrimPath/.
+--
+-- This is the analogue to 'emptyPath' in @Wumpus-Core@, but the
+-- result is produced /within/ the 'DrawingContext'.
+--
+emptyLocPath :: Num u => LocCF u (PrimPath u)
+emptyLocPath = locPath []
+
+
+
+
+--
+-- Drawing paths (stroke, fill, bordered)...
+--
+
+-- | 'openStroke' : @ path -> Graphic @
+--
+-- This is the analogue to 'ostroke' in @Wumpus-core@, but the 
+-- drawing properties (colour, line width, etc.) are taken from 
+-- the implicit 'DrawingContext'.
+--
+openStroke :: Num u => PrimPath u -> Graphic u
+openStroke pp = 
+    withStrokeAttr $ \rgb attr -> graphicAns $ ostroke rgb attr pp
+
+
+-- | 'closedStroke' : @ path -> Graphic @
+--
+-- This is the analogue to 'cstroke' in @Wumpus-core@, but the 
+-- drawing properties (colour, line width, etc.) are taken from 
+-- the implicit 'DrawingContext'.
+--
+closedStroke :: Num u => PrimPath u -> Graphic u
+closedStroke pp = 
+    withStrokeAttr $ \rgb attr -> graphicAns $ cstroke rgb attr pp
+
+
+-- | 'filledPath' : @ path -> Graphic @
+-- 
+-- This is the analogue to 'fill' in @Wumpus-core@, but the 
+-- fill colour is taken from the implicit 'DrawingContext'.
+--
+--
+filledPath :: Num u => PrimPath u -> Graphic u
+filledPath pp = withFillAttr $ \rgb -> graphicAns $ fill rgb pp
+                 
+
+-- | 'borderedPath' : @ path -> Graphic @
+--
+-- This is the analogue to 'fillStroke' in @Wumpus-core@, but the 
+-- drawing properties (fill colour, border colour, line width, 
+-- etc.) are taken from the implicit 'DrawingContext'.
+--
+--
+borderedPath :: Num u => PrimPath u -> Graphic u
+borderedPath pp =
+    withBorderedAttr $ \frgb attr srgb -> 
+      graphicAns $ fillStroke frgb attr srgb pp
+
+
+
+--------------------------------------------------------------------------------
+-- Text
+
+-- | 'textline' : @ string -> LocGraphic @
+-- 
+-- Create a text 'LocGraphic' - i.e. a functional type 
+-- /from Point to Graphic/.
+--
+-- The implicit point of the LocGraphic is the baseline left.
+--
+-- This is the analogue to 'textlabel' in @Wumpus-core@, but the
+-- text properties (font family, font size, colour) are taken from
+-- the implicit 'DrawingContext'.
+--
+textline :: Num u => String -> LocGraphic u
+textline ss = 
+    promoteR1 $ \pt -> 
+      withTextAttr $ \rgb attr -> graphicAns (textlabel rgb attr ss pt)
+
+
+
+
+-- | 'rtextline' : @ string -> LocThetaGraphic @
+-- 
+-- Create a text 'LocThetaGraphic' - i.e. a functional type 
+-- /from Point and Angle to Graphic/.
+--
+-- The implicit point of the LocGraphic is the baseline left, the
+-- implicit angle is rotation factor of the text.
+--
+-- Note - rotated text often does not render well in PostScript or
+-- SVG. Rotated text should be used sparingly.
+-- 
+-- This is the analogue to 'rtextlabel' in @Wumpus-core@.
+--
+rtextline :: Num u => String -> LocThetaGraphic u
+rtextline ss = 
+    promoteR2 $ \pt theta -> 
+      withTextAttr $ \rgb attr -> graphicAns (rtextlabel rgb attr ss theta pt)
+
+
+
+-- | 'escapedline' : @ escaped_text -> LocGraphic @
+-- 
+-- Create a text 'LocGraphic' - i.e. a functional type 
+-- /from Point to Graphic/.
+--
+-- The implicit point of the LocGraphic is the baseline left.
+--
+-- This is the analogue to 'escapedlabel' in @Wumpus-core@, but 
+-- the text properties (font family, font size, colour) are taken 
+-- from the implicit 'DrawingContext'.
+--
+escapedline :: Num u => EscapedText -> LocGraphic u
+escapedline ss = 
+    promoteR1 $ \pt -> 
+      withTextAttr $ \rgb attr -> graphicAns (escapedlabel rgb attr ss pt)
+
+
+
+-- | 'rescapedline' : @ escaped_text -> LocThetaGraphic @
+-- 
+-- Create a text 'LocThetaGraphic' - i.e. a functional type 
+-- /from Point and Angle to Graphic/.
+--
+-- The implicit point of the LocGraphic is the baseline left, the
+-- implicit angle is rotation factor of the text.
+--
+-- Note - rotated text often does not render well in PostScript or
+-- SVG. Rotated text should be used sparingly.
+-- 
+-- This is the analogue to 'rescapedlabel' in @Wumpus-core@, but
+-- the text properties (font family, font size, colour) are taken 
+-- from the implicit 'DrawingContext'.
+--
+rescapedline :: Num u => EscapedText -> LocThetaGraphic u
+rescapedline ss = 
+    promoteR2 $ \pt theta -> 
+      withTextAttr $ \rgb attr -> graphicAns (rescapedlabel rgb attr ss theta pt)
+
+
+
+
+-- | 'hkernline' : @ [kern_char] -> LocGraphic @
+-- 
+-- Create a horizontally kerned text 'LocGraphic' - i.e. a 
+-- functional type /from Point to Graphic/.
+--
+-- The implicit point of the LocGraphic is the baseline left.
+--
+-- This is the analogue to 'hkernlabel' in @Wumpus-core@, but 
+-- the text properties (font family, font size, colour) are taken 
+-- from the implicit 'DrawingContext'.
+--
+hkernline :: Num u => [KerningChar u] -> LocGraphic u
+hkernline xs = 
+    promoteR1 $ \pt -> 
+      withTextAttr $ \rgb attr -> graphicAns (hkernlabel rgb attr xs pt)
+
+
+-- | 'vkernline' : @ [kern_char] -> LocGraphic @
+-- 
+-- Create a vertically kerned text 'LocGraphic' - i.e. a 
+-- functional type /from Point to Graphic/.
+--
+-- The implicit point of the LocGraphic is the baseline left.
+--
+-- This is the analogue to 'vkernlabel' in @Wumpus-core@, but 
+-- the text properties (font family, font size, colour) are taken 
+-- from the implicit 'DrawingContext'.
+--
+vkernline :: Num u => [KerningChar u] -> LocGraphic u
+vkernline xs = 
+    promoteR1 $ \pt -> 
+      withTextAttr $ \rgb attr -> graphicAns (vkernlabel rgb attr xs pt)
+
+
+
+
+--------------------------------------------------------------------------------
+-- Lines
+
+-- | 'straightLine' : @ vec_to -> LocGraphic @ 
+--
+-- Create a stright line 'LocGraphic' - i.e. a functional type 
+-- /from Point to Graphic/.
+--
+-- The implicit point of the LocGraphic is the start point, the 
+-- end point is calculated by displacing the start point with the 
+-- supplied vector.
+--
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+straightLine :: Fractional u => Vec2 u -> LocGraphic u
+straightLine v = mf >>= (lift0R1 . openStroke)
+  where
+    mf = promoteR1 $ \pt -> pure $ primPath pt [lineTo $ pt .+^ v]
+
+          
+-- | 'straightLineGraphic' : @ start_point * end_point -> LocGraphic @ 
+-- 
+-- Create a straight line 'Graphic', the start and end point 
+-- are supplied explicitly.
+-- 
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+straightLineGraphic :: Fractional u => Point2 u -> Point2 u -> Graphic u
+straightLineGraphic p1 p2 = openStroke $ primPath p1 [lineTo p2]
+
+
+
+-- | 'curveGraphic' : @ start_point * control_point1 * 
+--        control_point2 * end_point -> Graphic @ 
+-- 
+-- Create a Bezier curve 'Graphic', all control points are 
+-- supplied explicitly.
+-- 
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+curveGraphic :: Fractional u 
+             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u
+curveGraphic sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep]
+
+
+--------------------------------------------------------------------------------
+-- Circles
+
+-- | 'strokedCircle' : @ radius -> LocGraphic @
+--
+-- Create a stroked circle 'LocGraphic' - the implicit point is 
+-- center. The circle is drawn with four Bezier curves. 
+-- 
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+strokedCircle :: Floating u => u -> LocGraphic u
+strokedCircle r = promoteR1 (closedStroke . curvedPath . bezierCircle r)
+
+
+
+-- | 'filledCircle' : @ radius -> LocGraphic @
+--
+-- Create a filled circle 'LocGraphic' - the implicit point is 
+-- center. The circle is drawn with four Bezier curves. 
+-- 
+-- The fill colour is taken from the implicit 'DrawingContext'.
+-- 
+filledCircle :: Floating u => u -> LocGraphic u
+filledCircle r =  promoteR1 (filledPath . curvedPath . bezierCircle r)
+
+
+
+-- | 'borderedCircle' : @ radius -> LocGraphic @
+--
+-- Create a bordered circle 'LocGraphic' - the implicit point is 
+-- center. The circle is drawn with four Bezier curves. 
+-- 
+-- The background fill colour and the outline stroke properties 
+-- are taken from the implicit 'DrawingContext'.
+-- 
+borderedCircle :: Floating u => u -> LocGraphic u
+borderedCircle r = promoteR1 (borderedPath . curvedPath . bezierCircle r)
+
+
+--------------------------------------------------------------------------------
+-- Ellipses
+
+
+
+-- | 'strokedEllipse' : @ x_radius * y_radius -> LocGraphic @
+--
+-- Create a stroked ellipse 'LocGraphic' - the implicit point is 
+-- center. The ellipse is drawn with four Bezier curves. 
+-- 
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+strokedEllipse :: Floating u => u -> u -> LocGraphic u
+strokedEllipse rx ry =
+    promoteR1 (closedStroke . curvedPath . bezierEllipse rx ry)
+
+
+
+-- | 'rstrokedEllipse' : @ x_radius * y_radius -> LocThetaGraphic @
+--
+-- Create a stroked ellipse 'LocThetaGraphic' - the implicit point
+-- is center and the angle is rotation about the center. The 
+-- ellipse is drawn with four Bezier curves. 
+-- 
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+rstrokedEllipse :: (Real u, Floating u) => u -> u -> LocThetaGraphic u
+rstrokedEllipse hw hh = 
+    promoteR2 $ \ pt theta -> 
+      closedStroke $ curvedPath $ rbezierEllipse hw hh theta pt 
+
+
+-- | 'filledEllipse' : @ x_radius * y_radius -> LocGraphic @
+--
+-- Create a filled ellipse 'LocGraphic' - the implicit point is 
+-- center. The ellipse is drawn with four Bezier curves. 
+-- 
+-- The fill colour is taken from the implicit 'DrawingContext'.
+-- 
+filledEllipse :: Floating u => u -> u -> LocGraphic u
+filledEllipse hw hh = 
+    promoteR1 (filledPath . curvedPath . bezierEllipse hw hh)
+
+
+-- | 'rfilledEllipse' : @ x_radius * y_radius -> LocGraphic @
+--
+-- Create a filled ellipse 'LocThetaGraphic' - the implicit point
+-- is center and the angle is rotation about the center. The 
+-- ellipse is drawn with four Bezier curves.  
+-- 
+-- The fill colour is taken from the implicit 'DrawingContext'.
+-- 
+rfilledEllipse :: (Real u, Floating u) => u -> u -> LocThetaGraphic u
+rfilledEllipse hw hh = 
+    promoteR2 $ \ pt theta -> 
+      filledPath $ curvedPath $ rbezierEllipse hw hh theta pt 
+
+
+
+-- | 'borderedEllipse' : @ x_radius * y_radius -> LocGraphic @
+--
+-- Create a bordered ellipse 'LocGraphic' - the implicit point is 
+-- center. The ellipse is drawn with four Bezier curves. 
+-- 
+-- The background fill colour and the outline stroke properties 
+-- are taken from the implicit 'DrawingContext'.
+-- 
+borderedEllipse :: Floating u => u -> u -> LocGraphic u
+borderedEllipse hw hh =
+    promoteR1 (borderedPath . curvedPath . bezierEllipse hw hh)
+
+
+
+-- | 'rborderedEllipse' : @ x_radius * y_radius -> LocGraphic @
+--
+-- Create a bordered ellipse 'LocThetaGraphic' - the implicit point
+-- is center and the angle is rotation about the center. The 
+-- ellipse is drawn with four Bezier curves.  
+-- 
+-- The background fill colour and the outline stroke properties 
+-- are taken from the implicit 'DrawingContext'.
+-- 
+rborderedEllipse :: (Real u, Floating u) => u -> u -> LocThetaGraphic u
+rborderedEllipse hw hh = 
+    promoteR2 $ \ pt theta -> 
+      borderedPath $ curvedPath $ rbezierEllipse hw hh theta pt 
+
+
+
+-- Note - clipping needs a picture as well as a path, so there is
+-- no analogous @clippedPath@ function.
+
+--------------------------------------------------------------------------------
+-- Rectangles
+
+
+
+-- | Supplied point is /bottom-left/.
+--
+rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u
+rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ]
+  where
+    br = bl .+^ hvec w
+    tr = br .+^ vvec h
+    tl = bl .+^ vvec h
+
+
+-- | 'strokedRectangle' : @ width * height -> LocGraphic @
+--
+-- Create a stroked rectangle 'LocGraphic' - the implicit point is 
+-- bottom-left. 
+-- 
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+strokedRectangle :: Fractional u => u -> u -> LocGraphic u
+strokedRectangle w h = promoteR1 (closedStroke . rectanglePath w h)
+
+
+-- | 'filledRectangle' : @ width * height -> LocGraphic @
+--
+-- Create a filled rectangle 'LocGraphic' - the implicit point is 
+-- the bottom-left. 
+-- 
+-- The fill colour is taken from the implicit 'DrawingContext'.
+-- 
+filledRectangle :: Fractional u => u -> u -> LocGraphic u
+filledRectangle w h = promoteR1 (filledPath . rectanglePath w h)
+
+
+-- | 'borderedRectangle' : @ width * height -> LocGraphic @
+--
+-- Create a bordered rectangle 'LocGraphic' - the implicit point is 
+-- bottom-left. 
+-- 
+-- The background fill colour and the outline stroke properties 
+-- are taken from the implicit 'DrawingContext'.
+-- 
+borderedRectangle :: Fractional u => u -> u -> LocGraphic u
+borderedRectangle w h = promoteR1 (borderedPath . rectanglePath w h)
+
+
+---------------------------------------------------------------------------
+
+
+-- | 'strokedDisk' : @ radius -> LocGraphic @
+--
+-- Create a stroked circle 'LocGraphic' - the implicit point is 
+-- the center. 
+-- 
+-- This is a efficient representation of circles using 
+-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
+-- output. However, stroked-circles do not draw well after 
+-- non-uniform scaling - the pen width is scaled as well as 
+-- the shape.
+--
+-- For stroked circles that can be adequately scaled, use 
+-- 'strokedCircle' instead.
+--
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+strokedDisk :: Num u => u -> LocGraphic u
+strokedDisk r = strokedEllipseDisk r r
+
+
+-- | 'filledDisk' : @ radius -> LocGraphic @
+--
+-- Create a filled circle 'LocGraphic' - the implicit point is 
+-- the center. 
+-- 
+-- This is a efficient representation of circles using 
+-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
+-- output. As the circle is filled rather than drawn with a 
+-- \"pen\" a @filledDisk@ can be scaled. 
+--
+-- The fill colour is taken from the implicit 'DrawingContext'.
+-- 
+filledDisk :: Num u => u -> LocGraphic u
+filledDisk r = filledEllipseDisk r r
+
+
+-- | 'borderedDisk' : @ radius -> LocGraphic @
+--
+-- Create a bordered circle 'LocGraphic' - the implicit point is 
+-- the center. 
+-- 
+-- This is a efficient representation of circles using 
+-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
+-- output. However, bordereded circles do not draw well after 
+-- non-uniform scaling - the pen width of the outline is scaled as 
+-- well as the shape.
+--
+-- For bordered circles that can be adequately scaled, use 
+-- 'borderedCircle' instead.
+--
+-- The background fill colour and the outline stroke properties 
+-- are taken from the implicit 'DrawingContext'.
+-- 
+borderedDisk :: Num u => u -> LocGraphic u
+borderedDisk r = borderedEllipseDisk r r
+
+
+-- | 'strokedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @
+--
+-- Create a stroked ellipse 'LocGraphic' - the implicit point is 
+-- the center. 
+-- 
+-- This is a efficient representation of circles using 
+-- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated 
+-- output. However, stroked ellipses do not draw well after 
+-- non-uniform scaling - the pen width is scaled as well as 
+-- the shape.
+--
+-- For stroked ellipses that can be adequately scaled, use 
+-- 'strokedEllipse' instead.
+--
+-- The line properties (colour, pen thickness, etc.) are taken 
+-- from the implicit 'DrawingContext'.
+-- 
+strokedEllipseDisk :: Num u => u -> u -> LocGraphic u
+strokedEllipseDisk rx ry =
+    promoteR1 $ \ pt -> 
+      withStrokeAttr $ \rgb attr -> 
+        graphicAns (strokeEllipse rgb attr rx ry pt)
+
+
+-- | 'filledEllipseDisk' : @ x_radius * y_radius -> LocGraphic @
+--
+-- Create a filled ellipse 'LocGraphic' - the implicit point is 
+-- the center. 
+-- 
+-- This is a efficient representation of ellipses using 
+-- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated 
+-- output. As the ellipse is filled rather than drawn with a 
+-- \"pen\" a @filledEllipseDisk@ can be scaled. 
+--
+-- The fill colour is taken from the implicit 'DrawingContext'.
+-- 
+filledEllipseDisk :: Num u => u -> u -> LocGraphic u
+filledEllipseDisk rx ry = 
+    promoteR1 $ \pt ->  
+      withFillAttr $ \rgb -> graphicAns (fillEllipse rgb rx ry pt)
+
+
+-- | 'borderedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @
+--
+-- Create a bordered ellipse 'LocGraphic' - the implicit point is 
+-- the center. 
+-- 
+-- This is a efficient representation of ellipses using 
+-- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated 
+-- output. However, bordereded ellipses do not draw well after 
+-- non-uniform scaling - the pen width of the outline is scaled as 
+-- well as the shape.
+--
+-- For bordered ellipses that can be adequately scaled, use 
+-- 'borderedEllipse' instead.
+--
+-- The background fill colour and the outline stroke properties 
+-- are taken from the implicit 'DrawingContext'.
+-- 
+borderedEllipseDisk :: Num u => u -> u -> LocGraphic u
+borderedEllipseDisk rx ry = 
+    promoteR1 $ \pt -> 
+      withBorderedAttr $ \frgb attr srgb -> 
+        graphicAns (fillStrokeEllipse frgb attr srgb rx ry pt)
diff --git a/src/Wumpus/Basic/Kernel/Objects/Graphic.hs b/src/Wumpus/Basic/Kernel/Objects/Graphic.hs
--- a/src/Wumpus/Basic/Kernel/Objects/Graphic.hs
+++ b/src/Wumpus/Basic/Kernel/Objects/Graphic.hs
@@ -5,7 +5,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.Kernel.Objects.Graphic
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
@@ -37,66 +37,33 @@
   , DLocThetaGraphic
 
   -- * Functions
+  , safeconcat
+  , ignoreAns
+  , replaceAns
+  , mapAns
+
   , intoImage
   , intoLocImage
   , intoLocThetaImage
 
-  , moveStartPoint
-  , moveStartPointTheta
-
-  , locPath
-  , emptyLocPath
   , emptyLocGraphic
-
-
-  , openStroke
-  , closedStroke
-  , filledPath
-  , borderedPath
-
-  , textline
-  , rtextline
-  , escapedline
-  , rescapedline
-
-  , hkernline
-  , vkernline
-
-  , strokedEllipse
-  , rstrokedEllipse
-  , filledEllipse
-  , rfilledEllipse
-
-  , borderedEllipse
-  , rborderedEllipse
-
-  , straightLine
-  , straightLineBetween
-  , curveBetween
-
-  , strokedRectangle
-  , filledRectangle
-  , borderedRectangle
+  , emptyLocThetaGraphic 
 
-  , strokedCircle
-  , filledCircle
-  , borderedCircle
+  , decorate
+  , sdecorate
+  , adecorate
   
-  , strokedDisk
-  , filledDisk
-  , borderedDisk
+  , hyperlink
 
   ) where
 
-import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.BaseDefs
-import Wumpus.Basic.Kernel.Base.QueryDC
+import Wumpus.Basic.Kernel.Base.ContextFun
 import Wumpus.Basic.Kernel.Base.WrappedPrimitive
 import Wumpus.Basic.Kernel.Objects.BaseObjects
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import Data.AffineSpace                         -- package: vector-space
 
 import Control.Applicative
 
@@ -143,336 +110,173 @@
 -- Functions
 
 
--- | Build an Image...
---
-intoImage :: CF a -> Graphic u -> Image u a
-intoImage = liftA2 (\a (_,b) -> (a,b))
-
-
--- | Build a LocImage...
---
-intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a
-intoLocImage = liftA2 (\a (_,b) -> (a,b))
-
--- | Build a LocThetaImage...
---
-intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a
-intoLocThetaImage = liftA2 (\a (_,b) -> (a,b))
-
-
--- | Move the start-point of a LocImage with the supplied 
--- displacement function.
---
-moveStartPoint :: PointDisplace u -> LocCF u a -> LocCF u a
-moveStartPoint f ma = promoteR1 $ \pt -> apply1R1 ma (f pt)
-
-
--- | Move the start-point of a LocImage with the supplied 
--- displacement function.
---
-moveStartPointTheta :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a
-moveStartPointTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta
-
---------------------------------------------------------------------------------
-
-
-
-graphicBody :: Primitive u -> (UNil u, PrimGraphic u)
-graphicBody p = (uNil, primGraphic p)
-
-
--- | This is the analogue to 'vectorPath' in @Wumpus-core@.
---
-locPath :: Num u => [Vec2 u] -> LocCF u (PrimPath u)
-locPath vs = promoteR1 $ \pt  -> pure $ vectorPath pt vs
-
-
--- | This is the analogue to 'emptyPath' in @Wumpus-core@.
+-- | 'safeconcat' : @ alternative * [image] -> Image@
+-- 
+-- 'safeconcat' produces a composite 'Image' from a list of 
+-- @Image@\'s. If the list is empty the alternative @Image@ is 
+-- used.
 --
-emptyLocPath :: Num u => LocCF u (PrimPath u)
-emptyLocPath = locPath []
-
--- | Build an empty LocGraphic - this is a path with a start
--- point but no path segments. 
+-- This contrasts to 'oconcat' - when used for @Image@\'s, 
+-- @oconcat@ has the same type signature as @safeconcat@ but 
+-- @oconcat@ considers its arguments to be an already destructured 
+-- list:
 -- 
--- The 'emptyLocGraphic' It is treated as a /null primitive/ by 
--- @Wumpus-Core@ and is not drawn, although it does generate a 
--- minimum bounding box at the implicit start point.
+-- > oconcat (head::Image) (rest::[Image])
 -- 
-emptyLocGraphic :: Num u => LocGraphic u
-emptyLocGraphic = emptyLocPath >>= (lift0R1 . openStroke)
-
-
--- | 'openStroke' : @ path -> Graphic @
---
--- This is the analogue to 'ostroke' in @Wumpus-core@, but the 
--- drawing properties (colour, line width, etc.) are taken from 
--- the implicit 'DrawingContext'.
---
-openStroke :: Num u => PrimPath u -> Graphic u
-openStroke pp = 
-    withStrokeAttr $ \rgb attr -> graphicBody $ ostroke rgb attr pp
+safeconcat :: OPlus a => Image u a -> [Image u a] -> Image u a
+safeconcat _   (x:xs) = oconcat x xs
+safeconcat alt []     = alt
 
 
--- | 'closedStroke' : @ path -> Graphic @
+-- | Ignore the answer produced by an 'Image', a 'LocImage' etc.
 --
--- This is the analogue to 'cstroke' in @Wumpus-core@, but the 
--- drawing properties (colour, line width, etc.) are taken from 
--- the implicit 'DrawingContext'.
+-- Use this function to turn an 'Image' into a 'Graphic', a 
+-- 'LocImage into a 'LocGraphic'.
 --
-closedStroke :: Num u => PrimPath u -> Graphic u
-closedStroke pp = 
-    withStrokeAttr $ \rgb attr -> graphicBody $ cstroke rgb attr pp
+ignoreAns :: Functor f => f (a,b) -> f (UNil u, b)
+ignoreAns = fmap (replaceL uNil)
 
 
--- | 'filledPath' : @ path -> Graphic @
--- 
--- This is the analogue to 'fill' in @Wumpus-core@, but the 
--- fill colour is taken from the implicit 'DrawingContext'.
---
---
-filledPath :: Num u => PrimPath u -> Graphic u
-filledPath pp = withFillAttr $ \rgb -> graphicBody $ fill rgb pp
-                 
-
--- | 'borderedPath' : @ path -> Graphic @
---
--- This is the analogue to 'fillStroke' in @Wumpus-core@, but the 
--- drawing properties (fill colour, border colour, line width, 
--- etc.) are taken from the implicit 'DrawingContext'.
---
+-- | Replace the answer produced by an 'Image', a 'LocImage' etc.
 --
-borderedPath :: Num u => PrimPath u -> Graphic u
-borderedPath pp =
-    withBorderedAttr $ \frgb attr srgb -> 
-      graphicBody $ fillStroke frgb attr srgb pp
-
-
+replaceAns :: Functor f => z -> f (a,b) -> f (z, b)
+replaceAns = fmap . replaceL
 
 
--- | This is the analogue to 'textlabel' in @Wumpus-core@.
+-- | Apply the supplied function to the answer produced by an 
+-- 'Image', a 'LocImage' etc.
 --
-textline :: Num u => String -> LocGraphic u
-textline ss = 
-    promoteR1 $ \pt -> 
-      withTextAttr $ \rgb attr -> graphicBody (textlabel rgb attr ss pt)
-
-
+mapAns :: Functor f => (a -> z) -> f (a,b) -> f (z,b)
+mapAns f = fmap (\(a,b) -> (f a ,b))
 
 
--- | This is the analogue to 'rtextlabel' in @Wumpus-core@.
+-- | 'intoImage' : @ context_function * graphic -> Image @
 --
-rtextline :: Num u => String -> LocThetaGraphic u
-rtextline ss = 
-    promoteR2 $ \pt theta -> 
-      withTextAttr $ \rgb attr -> graphicBody (rtextlabel rgb attr ss theta pt)
-
-
-
--- | This is the analogue to 'escapedlabel' in @Wumpus-core@.
+-- Build an 'Image' from a context function ('CF') that generates 
+-- the answer and a 'Graphic' that draws the 'Image'.
 --
-escapedline :: Num u => EscapedText -> LocGraphic u
-escapedline ss = 
-    promoteR1 $ \pt -> 
-      withTextAttr $ \rgb attr -> graphicBody (escapedlabel rgb attr ss pt)
-
+intoImage :: CF a -> Graphic u -> Image u a
+intoImage = liftA2 (\a (_,b) -> (a,b))
 
 
--- | This is the analogue to 'rescapedlabel' in @Wumpus-core@.
+-- | 'intoLocImage' : @ loc_context_function * loc_graphic -> LocImage @
 --
-rescapedline :: Num u => EscapedText -> LocThetaGraphic u
-rescapedline ss = 
-    promoteR2 $ \pt theta -> 
-      withTextAttr $ \rgb attr -> graphicBody (rescapedlabel rgb attr ss theta pt)
-
-
-
-
--- | This is the analogue to 'hkernlabel' in @Wumpus-core@.
+-- /Loc/ version of 'intoImage'. 
+-- 
+-- The 'LocImage' is built as a function from an implicit start 
+-- point to the answer.
 --
-hkernline :: Num u => [KerningChar u] -> LocGraphic u
-hkernline xs = 
-    promoteR1 $ \pt -> 
-      withTextAttr $ \rgb attr -> graphicBody (hkernlabel rgb attr xs pt)
-
+intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a
+intoLocImage = liftA2 (\a (_,b) -> (a,b))
 
--- | This is the analogue to 'vkernlabel' in @Wumpus-core@.
+-- | 'intoLocThetaImage' : @ loc_theta_cf * loc_theta_graphic -> LocThetaImage @
 --
-vkernline :: Num u => [KerningChar u] -> LocGraphic u
-vkernline xs = 
-    promoteR1 $ \pt -> 
-      withTextAttr $ \rgb attr -> graphicBody (vkernlabel rgb attr xs pt)
-
-
-
-
---------------------------------------------------------------------------------
-
-
-
-
-
--- | This is the analogue to 'strokeEllipse' in @Wumpus-core@.
+-- /LocTheta/ version of 'intoImage'. 
+-- 
+-- The 'LocThetaImage' is built as a function from an implicit 
+-- start point and angle of inclination to the answer.
 --
-strokedEllipse :: Num u => u -> u -> LocGraphic u
-strokedEllipse hw hh =
-    promoteR1 $ \pt -> 
-      withStrokeAttr $ \rgb attr -> graphicBody (strokeEllipse rgb attr hw hh pt)
+intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a
+intoLocThetaImage = liftA2 (\a (_,b) -> (a,b))
 
 
 
--- | This is the analogue to 'rstrokeEllispe' in @Wumpus-core@.
---
-rstrokedEllipse :: Num u => u -> u -> LocThetaGraphic u
-rstrokedEllipse hw hh = 
-    promoteR2 $ \ pt theta -> 
-      withStrokeAttr $ \rgb attr -> 
-        graphicBody (rstrokeEllipse rgb attr hw hh theta pt)
-
-
--- | This is the analogue to 'fillEllispe' in @Wumpus-core@.
---
-filledEllipse :: Num u => u -> u -> LocGraphic u
-filledEllipse hw hh = 
-    promoteR1 $ \pt ->  
-      withFillAttr $ \rgb -> graphicBody (fillEllipse rgb hw hh pt)
-
-
--- | This is the analogue to 'rfillEllispe' in @Wumpus-core@.
+-- | 'emptyLocGraphic' : @ LocGraphic @
 --
-rfilledEllipse :: Num u => u -> u -> LocThetaGraphic u
-rfilledEllipse hw hh = 
-    promoteR2 $ \pt theta ->
-      withFillAttr $ \rgb -> graphicBody (rfillEllipse rgb hw hh theta pt)
+-- Build an empty 'LocGraphic' (i.e. a function 
+-- /from Point to Graphic/). This is a path with a start point 
+-- but no path segments. 
+-- 
+-- The 'emptyLocGraphic' is treated as a /null primitive/ by 
+-- @Wumpus-Core@ and is not drawn, although it does generate a 
+-- minimum bounding box at the implicit start point.
+-- 
+emptyLocGraphic :: Num u => LocGraphic u
+emptyLocGraphic = promoteR1 $ \pt -> 
+                    return $ (uNil, primGraphic $ zostroke $ emptyPath pt)
 
 
 
--- | This is the analogue to 'fillStrokeEllispe' in @Wumpus-core@.
---
-borderedEllipse :: Num u => u -> u -> LocGraphic u
-borderedEllipse hw hh =
-    promoteR1 $ \pt -> 
-      withBorderedAttr $ \frgb attr srgb -> 
-        graphicBody (fillStrokeEllipse frgb attr srgb hw hh pt)
-
--- | This is the analogue to 'rfillStrokeEllispe' in @Wumpus-core@.
+-- | 'emptyLocThetaGraphic' : @ LocThetaGraphic @
 --
-rborderedEllipse :: Num u => u -> u -> LocThetaGraphic u
-rborderedEllipse hw hh = 
-    promoteR2 $ \pt theta -> 
-      withBorderedAttr $ \frgb attr srgb -> 
-        graphicBody (rfillStrokeEllipse frgb attr srgb hw hh theta pt)
-
-
-
--- Note - clipping needs a picture as well as a path, so there is
--- no analogous @clippedPath@ function.
-
---------------------------------------------------------------------------------
-
-
--- | Draw a straight line formed from displacing the implicit 
--- start point with the supplied vector.
+-- Build an empty 'LocThetaGraphic' (i.e. a function 
+-- /from Point and Inclination to Graphic/). 
 -- 
-straightLine :: Fractional u => Vec2 u -> LocGraphic u
-straightLine v = mf >>= (lift0R1 . openStroke)
-  where
-    mf = promoteR1 $ \pt -> pure $ primPath pt [lineTo $ pt .+^ v]
-
-          
--- | Draw a straight line - start and end point are supplied 
--- explicitly.
+-- The 'emptyLocThetaGraphic' is treated as a /null primitive/ by 
+-- @Wumpus-Core@ and is not drawn, although it does generate a 
+-- minimum bounding box at the implicit start point.
 -- 
-straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u
-straightLineBetween p1 p2 = openStroke $ primPath p1 [lineTo p2]
+emptyLocThetaGraphic :: Num u => LocThetaGraphic u
+emptyLocThetaGraphic = lift1R2 emptyLocGraphic
 
 
 
--- | Draw a Bezier curve - all points are supplied explicitly.
--- 
-curveBetween :: Fractional u 
-             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u
-curveBetween sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep]
 
-
--- This is a permuted version of the cardinal-prime combinator...
--- 
--- > (r2 -> a) -> (a -> r1 -> ans) -> (r1 -> r2 -> ans)
+-- | Decorate an Image by superimposing a Graphic.
 --
-
-drawWith :: (Point2 u -> PrimPath u) -> (PrimPath u -> Graphic u) -> LocGraphic u 
-drawWith g mf = promoteR1 $ \pt -> mf (g pt)
-
-
--- | Supplied point is /bottom-left/.
+-- Note - this function has a very general type signature and
+-- supports various graphic types:
 --
-rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u
-rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ]
-  where
-    br = bl .+^ hvec w
-    tr = br .+^ vvec h
-    tl = bl .+^ vvec h
-
--- | Supplied point is /bottom left/.
+-- > decorate :: Image u a -> Graphic u -> Image u a
+-- > decorate :: LocImage u a -> LocGraphic u -> LocImage u a
+-- > decorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
 --
-strokedRectangle :: Fractional u => u -> u -> LocGraphic u
-strokedRectangle w h = rectanglePath w h `drawWith` closedStroke
+decorate :: Monad m 
+         => m (ImageAns u a) -> m (ImageAns u zz) -> m (ImageAns u a) 
+decorate img gf = 
+    img >>= \(a,g1) -> gf >>= \(_,g2) -> return (a, g1 `oplus` g2)
 
 
--- | Supplied point is /bottom left/.
---
-filledRectangle :: Fractional u => u -> u -> LocGraphic u
-filledRectangle w h = rectanglePath w h `drawWith` filledPath
 
--- | Supplied point is /bottom left/.
+-- | /Anterior decorate/ - decorate an Image by superimposing it 
+-- on a Graphic.
 --
-borderedRectangle :: Fractional u => u -> u -> LocGraphic u
-borderedRectangle w h = rectanglePath w h `drawWith` borderedPath
-
-
--- | Supplied point is center. Circle is drawn with Bezier 
--- curves. 
+-- Note - here the Graphic has access to the result produced by the 
+-- the Image unlike 'decorate'.
 --
-strokedCircle :: Floating u => Int -> u -> LocGraphic u
-strokedCircle n r = (curvedPath . bezierCircle n r) `drawWith` closedStroke 
-
-
-
--- | Supplied point is center. Circle is drawn with Bezier 
--- curves. 
+-- Again, this function has a very general type signature and
+-- supports various graphic types:
 --
-filledCircle :: Floating u => Int -> u -> LocGraphic u
-filledCircle n r =  (curvedPath . bezierCircle n r) `drawWith` filledPath
-
-
-
--- | Supplied point is center. Circle is drawn with Bezier 
--- curves. 
+-- > adecorate :: Image u a -> Graphic u -> Image u a
+-- > adecorate :: LocImage u a -> LocGraphic u -> LocImage u a
+-- > adecorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
 --
-borderedCircle :: Floating u => Int -> u -> LocGraphic u
-borderedCircle n r = (curvedPath . bezierCircle n r) `drawWith` borderedPath 
+adecorate :: Monad m 
+          => m (ImageAns u a) -> (a -> m (ImageAns u zz)) -> m (ImageAns u a)
+adecorate img f = 
+    img >>= \(a,g1) -> f a >>= \(_,g0) -> return (a, g0 `oplus` g1)
 
 
--- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive.
+-- | /Superior decorate/ - decorate an image by superimposing a 
+-- graphic on top of it.
 --
--- This is a efficient representation of circles using 
--- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
--- output. However, stroked-circles do not draw well after 
--- non-uniform scaling - the line width is scaled as well as 
--- the shape.
+-- Note, here the Graphic has access to the result produced by the 
+-- the Image unlike 'decorate'.
 --
--- For stroked circles that can be adequately scaled, use 
--- 'strokedCircle' instead.
+-- Again, this function has a very general type signature and
+-- supports various graphic types:
 --
-strokedDisk :: Num u => u -> LocGraphic u
-strokedDisk radius = strokedEllipse radius radius
-
--- | Filled disk...
+-- > sdecorate :: Image u a -> Graphic u -> Image u a
+-- > sdecorate :: LocImage u a -> LocGraphic u -> LocImage u a
+-- > sdecorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
 --
-filledDisk :: Num u => u -> LocGraphic u
-filledDisk radius = filledEllipse radius radius
+sdecorate :: Monad m 
+          => m (ImageAns u a) -> (a -> m (ImageAns u zz)) -> m (ImageAns u a)
+sdecorate img f = 
+    img >>= \(a,g1) -> f a >>= \(_,g2) -> return (a, g1 `oplus` g2)
 
--- | bordered disk...
+
+-- | Hyperlink a graphic object.
+-- 
+-- This function has a very general type signature and supports 
+-- various graphic types:
 --
-borderedDisk :: Num u => u -> LocGraphic u
-borderedDisk radius = borderedEllipse radius radius
+-- > hyperlink :: XLink -> Graphic u -> Graphic u
+-- > hyperlink :: XLink -> Image u a -> Image u a
+-- > hyperlink :: XLink -> LocImage u a -> LocImage u a
+-- > hyperlink :: XLink -> LocThetaImage u a -> LocThetaImage u a
+--
+hyperlink :: Functor m => XLink -> m (ImageAns u a) -> m (ImageAns u a)
+hyperlink hypl = 
+    fmap (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim))
+
diff --git a/src/Wumpus/Basic/Kernel/Objects/PosImage.hs b/src/Wumpus/Basic/Kernel/Objects/PosImage.hs
new file mode 100644
--- /dev/null
+++ b/src/Wumpus/Basic/Kernel/Objects/PosImage.hs
@@ -0,0 +1,237 @@
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS -Wall #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Wumpus.Basic.Kernel.Objects.PosImage
+-- Copyright   :  (c) Stephen Tetley 2011
+-- License     :  BSD3
+--
+-- Maintainer  :  stephen.tetley@gmail.com
+-- Stability   :  highly unstable
+-- Portability :  GHC 
+--
+-- Extended Graphic object - a rectangular /positionable/ Image.
+-- 
+-- This graphic object has a more flexible API for positioning 
+-- than other graphic objects. Rather than a LocGraphic which 
+-- supports a single method of positioning at some start-point,
+-- a @PosGraphic@ can be drawn at its center or locations on its 
+-- outer rectangle.
+--
+--------------------------------------------------------------------------------
+
+module Wumpus.Basic.Kernel.Objects.PosImage
+  (
+
+    RectPosition(..)
+  , ObjectPos(..)
+
+  -- * Positionable image
+
+  , PosImage
+  , DPosImage 
+
+  , PosGraphic
+  , DPosGraphic
+
+  , makePosImage
+
+  , startPos
+  , atStartPos
+
+  , objectPosBounds
+
+  ) where
+
+
+import Wumpus.Basic.Kernel.Base.BaseDefs
+import Wumpus.Basic.Kernel.Base.ContextFun
+import Wumpus.Basic.Kernel.Objects.BaseObjects
+import Wumpus.Basic.Kernel.Objects.Displacement
+
+import Wumpus.Core                              -- package: wumpus-core
+
+import Data.AffineSpace                         -- package: vector-space
+
+-- | Datatype enumerating positions within a rectangle that can be
+-- derived for a 'PosGraphic'.  
+--
+data RectPosition = CENTER | NN | SS | EE | WW | NE | NW | SE | SW 
+  deriving (Enum,Eq,Ord,Show)
+
+
+-- | Utility datatype representing orientation within a 
+-- rectangular /frame/. ObjectPos is useful for graphics such as 
+-- text where the start point is not necessarily at the center 
+-- (or bottom left).
+--
+-- > x_minor is the horizontal distance from the left to the start point
+-- >
+-- > x_major is the horizontal distance from the start point to the right
+-- >
+-- > y_minor is the vertical distance from the bottom to the start point
+-- >
+-- > y_major is the vertical distance from the start point to the top
+--
+-- Values should be not be negative!
+--
+-- 
+data ObjectPos u = ObjectPos 
+      { op_x_minor      :: !u
+      , op_x_major      :: !u
+      , op_y_minor      :: !u
+      , op_y_major      :: !u
+      }
+  deriving (Eq,Ord,Show)
+
+
+
+type instance DUnit (ObjectPos u)   = u
+
+
+
+-- | A positionable Image.
+--
+type PosImage u a = CF2  (Point2 u) RectPosition (ImageAns u a)
+    
+-- | Version of PosImage specialized to Double for the unit type.
+--
+type DPosImage a = PosImage Double a
+
+
+
+-- | A positionable Graphic.
+--
+type PosGraphic u = PosImage u (UNil u) 
+    
+-- | Version of PosGraphic specialized to Double for the unit type.
+--
+type DPosGraphic = PosGraphic Double
+
+
+
+
+
+
+--------------------------------------------------------------------------------
+
+
+instance (Fractional u, Ord u) => OPlus (ObjectPos u) where
+  oplus = concatObjectPos
+
+
+-- | Concatenation here essentially turns both ObjectPos objects
+-- into /center-form/ then finds the maximum rectangle.
+--
+concatObjectPos :: (Fractional u, Ord u) 
+                => ObjectPos u -> ObjectPos u -> ObjectPos u
+concatObjectPos op0 op1 = ObjectPos hw hw hh hh
+  where
+    (hw0,hh0) = halfDists op0
+    (hw1,hh1) = halfDists op1
+    hw        = max hw0 hw1
+    hh        = max hh0 hh1
+
+
+
+--------------------------------------------------------------------------------
+
+
+-- | Find the half-width and half-height of an ObjectPos.
+-- 
+-- Essentially this is /center-form/ of an ObjectPos, but 
+-- in /center-form/ there is duplication: 
+--
+-- > xminor == xmajor
+-- > yminor == ymajor
+-- 
+-- So instead, the result type is just a pair.
+--
+halfDists :: Fractional u => ObjectPos u -> (u,u)
+halfDists (ObjectPos xmin xmaj ymin ymaj) = 
+    (0.5 * (xmin+xmaj), 0.5 * (ymin+ymaj))
+
+
+-- | 'makePosImage' : @ object_pos * loc_graphic -> PosGraphic @ 
+--
+-- Create a 'PosImage' from an 'ObjectPos' describing how it
+-- is orientated within a border rectangle and a 'LocImage' that 
+-- draws it.
+--
+makePosImage :: Fractional u 
+             => ObjectPos u -> LocImage u a -> PosImage u a
+makePosImage opos gf = promoteR2 $ \start rpos -> 
+    let v1 = startVector rpos opos in gf `at` displaceVec v1 start
+
+
+
+infixr 1 `startPos`
+
+-- | 'startPos' : @ pos_image * rect_pos -> LocImage @
+--
+-- /Downcast/ a 'PosImage' to a 'LocImage' by supplying it 
+-- with a 'RectPosition' (start position).
+--  
+startPos :: Floating u 
+         => PosImage u a -> RectPosition -> LocImage u a
+startPos = apply1R2
+ 
+-- | 'atStartPos' : @ pos_image * start_point * rect_pos -> LocImage @
+--
+-- /Downcast/ a 'PosGraphic' to an 'Image' by supplying it 
+-- with an initial point and a 'RectPosition' (start position).
+--  
+atStartPos ::  Floating u 
+           => PosImage u a -> Point2 u -> RectPosition -> Image u a
+atStartPos = apply2R2
+
+-- | The vector from some Rectangle position to the start point.
+--
+startVector :: Fractional u => RectPosition -> ObjectPos u -> Vec2 u
+startVector rpos (ObjectPos xminor xmajor yminor ymajor) = go rpos
+  where
+    w         = xminor + xmajor
+    h         = yminor + ymajor
+    hw        = 0.5 * w
+    hh        = 0.5 * h
+    
+    -- CENTER, NN, SS, EE, WW all go to bottomleft then add back 
+    -- the minors.
+
+    go CENTER = V2 ((-hw) + xminor) ((-hh) + yminor)
+    go NN     = V2 ((-hw) + xminor) ((-h)  + yminor)
+    go SS     = V2 ((-hw) + xminor)  yminor
+    go EE     = V2 ((-w)  + xminor) ((-hh) + yminor)
+    go WW     = V2 xminor           ((-hh) + yminor)
+    go NE     = V2 (-xmajor)        (-ymajor)
+    go SE     = V2 (-xmajor)          yminor
+    go SW     = V2 xminor           yminor
+    go NW     = V2 xminor           (-ymajor)
+
+
+
+-- | Calculate the bounding box formed by locating the 'ObjectPos'
+-- at the supplied point.
+-- 
+objectPosBounds :: Fractional u 
+                => Point2 u -> RectPosition -> ObjectPos u -> BoundingBox u
+objectPosBounds (P2 x y) pos (ObjectPos xmin xmaj ymin ymaj) = go pos
+  where
+    w         = xmin + xmaj
+    h         = ymin + ymaj
+    hw        = 0.5 * w
+    hh        = 0.5 * h
+    bbox      = \bl -> BBox bl (bl .+^ vec w h)
+
+    go CENTER = bbox $ P2 (x-hw) (y-hh)
+    go NN     = bbox $ P2 (x-hw) (y-h)
+    go SS     = bbox $ P2 (x-hw)  y
+    go EE     = bbox $ P2 (x-w)  (y-hh)
+    go WW     = bbox $ P2  x     (y-hh)
+    go NE     = bbox $ P2 (x-w)  (y-h)
+    go SE     = bbox $ P2 (x-w)   y
+    go SW     = bbox $ P2 x       y
+    go NW     = bbox $ P2 x      (y-h)
+
+
diff --git a/src/Wumpus/Basic/System/FontLoader/Afm.hs b/src/Wumpus/Basic/System/FontLoader/Afm.hs
--- a/src/Wumpus/Basic/System/FontLoader/Afm.hs
+++ b/src/Wumpus/Basic/System/FontLoader/Afm.hs
@@ -76,6 +76,7 @@
 afm_mono_defaults_4_1 = 
     MonospaceDefaults { default_letter_bbox  = bbox
                       , default_cap_height   = 562
+                      , default_descender    = (-157)
                       , default_char_width   = V2 600 0
                       }
   where
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs
--- a/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs
+++ b/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs
@@ -71,6 +71,7 @@
               { afm_encoding        = getEncodingScheme info
               , afm_letter_bbox     = getFontBBox       info
               , afm_cap_height      = getCapHeight      info
+              , afm_descender       = getDescender      info
               , afm_glyph_metrics   = cms
               }
 
@@ -101,6 +102,9 @@
 
 getCapHeight           :: GlobalInfo -> Maybe AfmUnit
 getCapHeight           = runQuery "CapHeight" number
+
+getDescender           :: GlobalInfo -> Maybe AfmUnit
+getDescender           = runQuery "Descender" number
 
 
 charBBox :: CharParser AfmBoundingBox
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs b/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs
--- a/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs
+++ b/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs
@@ -46,8 +46,8 @@
 
 import Wumpus.Core                              -- package: wumpus-core
 
-import qualified Data.IntMap   as IntMap
-import qualified Data.Map as Map
+import qualified Data.IntMap   as IM
+import qualified Data.Map      as M
 
 
 
@@ -87,7 +87,7 @@
 type AfmBoundingBox     = BoundingBox AfmUnit
 
 type AfmKey         = String
-type GlobalInfo     = Map.Map AfmKey String
+type GlobalInfo     = M.Map AfmKey String
 
 
 
@@ -106,6 +106,7 @@
       { afm_encoding        :: Maybe String
       , afm_letter_bbox     :: Maybe AfmBoundingBox
       , afm_cap_height      :: Maybe AfmUnit
+      , afm_descender       :: Maybe AfmUnit
       , afm_glyph_metrics   :: [AfmGlyphMetrics]
       }
   deriving (Show) 
@@ -132,6 +133,7 @@
 data MonospaceDefaults cu = MonospaceDefaults 
       { default_letter_bbox  :: BoundingBox cu
       , default_cap_height   :: cu
+      , default_descender    :: cu
       , default_char_width   :: Vec2 cu
       }
   deriving (Eq,Show)
@@ -150,8 +152,9 @@
 data FontProps cu = FontProps
        { fp_bounding_box        :: BoundingBox cu 
        , fp_default_adv_vec     :: Vec2 cu
-       , fp_adv_vecs            :: IntMap.IntMap (Vec2 cu)
+       , fp_adv_vecs            :: IM.IntMap (Vec2 cu)
        , fp_cap_height          :: cu
+       , fp_descender           :: cu
        }
 
 
@@ -159,13 +162,14 @@
 -- scaling function and FontProps read from a file.
 --
 buildMetricsOps :: (cu -> PtSize) -> FontProps cu -> MetricsOps
-buildMetricsOps fn (FontProps (BBox ll ur) (V2 vx vy) 
-                              vec_table    cap_height) = 
+buildMetricsOps fn font@(FontProps { fp_bounding_box = BBox ll ur
+                                   , fp_default_adv_vec = V2 vx vy }) = 
     MetricsOps
       { get_bounding_box  = \sz -> BBox (scalePt sz ll) (scalePt sz ur)
       , get_cw_table      = \sz i -> 
-            maybe (defaultAV sz) (scaleVec sz) $ IntMap.lookup i vec_table 
-      , get_cap_height    = \sz -> upscale sz (fn cap_height)
+            maybe (defaultAV sz) (scaleVec sz) $ IM.lookup i (fp_adv_vecs font)
+      , get_cap_height    = \sz -> upscale sz (fn $ fp_cap_height font)
+      , get_descender     = \sz -> upscale sz (fn $ fp_descender font)
       }
   where
     upscale sz d            = fromPtSize $ sz * d 
diff --git a/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs b/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs
--- a/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs
+++ b/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs
@@ -164,13 +164,15 @@
                   -> AfmFile 
                   -> FontLoadIO (FontProps AfmUnit)
 buildAfmFontProps defaults afm = do 
-    cap_height <- extractCapHeight defaults afm
-    bbox       <- extractFontBBox  defaults afm 
+    cap_height  <- extractCapHeight defaults afm
+    desc_depth  <- extractDescender defaults afm
+    bbox        <- extractFontBBox  defaults afm 
     return $ FontProps 
                { fp_bounding_box    = bbox
                , fp_default_adv_vec = default_char_width defaults
                , fp_adv_vecs        = char_widths
                , fp_cap_height      = cap_height
+               , fp_descender       = desc_depth
                }  
   where
     char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm
@@ -185,6 +187,14 @@
   where
     errk = logLoadMsg "WARNING - Could not extract CapHeight" >> 
            return (default_cap_height defaults)
+
+
+
+extractDescender :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
+extractDescender defaults afm = maybe errk return $ afm_descender afm
+  where
+    errk = logLoadMsg "WARNING - Could not extract Descender" >> 
+           return (default_descender defaults)
 
 
 extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile 
diff --git a/src/Wumpus/Basic/System/FontLoader/GhostScript.hs b/src/Wumpus/Basic/System/FontLoader/GhostScript.hs
--- a/src/Wumpus/Basic/System/FontLoader/GhostScript.hs
+++ b/src/Wumpus/Basic/System/FontLoader/GhostScript.hs
@@ -80,6 +80,7 @@
 ghostscript_mono_defaults_8_54 = 
     MonospaceDefaults { default_letter_bbox  = bbox
                       , default_cap_height   = 563
+                      , default_descender    = (-186)
                       , default_char_width   = V2 600 0
                       }
   where
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
@@ -3,7 +3,7 @@
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Wumpus.Basic.VersionNumber
--- Copyright   :  (c) Stephen Tetley 2010
+-- Copyright   :  (c) Stephen Tetley 2010-2011
 -- License     :  BSD3
 --
 -- Maintainer  :  stephen.tetley@gmail.com
@@ -23,7 +23,7 @@
 
 -- | Version number
 --
--- > (0,15,0)
+-- > (0,16,0)
 --
 wumpus_basic_version :: (Int,Int,Int)
-wumpus_basic_version = (0,15,0)
+wumpus_basic_version = (0,16,0)
diff --git a/wumpus-basic.cabal b/wumpus-basic.cabal
--- a/wumpus-basic.cabal
+++ b/wumpus-basic.cabal
@@ -1,5 +1,5 @@
 name:             wumpus-basic
-version:          0.15.0
+version:          0.16.0
 license:          BSD3
 license-file:     LICENSE
 copyright:        Stephen Tetley <stephen.tetley@gmail.com>
@@ -30,6 +30,32 @@
   .
   Changelog:
   .
+  v0.15.0 to v0.16.0:
+  .
+  * Moved the Geometry modules from Wumpus-Drawing into 
+    Wumpus-Basic.
+  .
+  * Re-worked the @CtxPicture@ API, although the current naming 
+    scheme is not satisfactory.
+  .
+  * Added extra Anchor classes.
+  .
+  * Added @PosImage@ object - this is a rectangle-framed object 
+    that can be drawn from any of its corners or its center. 
+  .
+  * Added @Displacement@ module. This defines the @PointDisplace@
+    type and provides a library of @PointDisplace@ functions.
+    Note - some of the new functions have taken names previously 
+    used for anchor projection functions (@northwards@, 
+    @southwards@, etc.), anchor projections are now build with the 
+    function @projectAnchor@.
+  .
+  * Added the property @descender@ to the font metrics.
+  .
+  * Split drawing primitives from type in @Objects.Graphic@, 
+    drawing primitives are now in the module 
+    @Objects.DrawingPrimitives@.
+  .
   v0.14.0 to v0.15.0:
   . 
   * Split previous @Wumpus-Basic@ package into two packages:
@@ -59,7 +85,9 @@
 extra-source-files:
   CHANGES,
   LICENSE,
-  demo/FontDeltaPic.hs
+  demo/FontDeltaPic.hs,
+  demo/SimpleAdvGraphic.hs,
+  demo/SimplePosImage.hs
 
 library
   hs-source-dirs:     src
@@ -68,10 +96,14 @@
                       directory       >= 1.0     && <  2.0, 
                       filepath        >= 1.1     && <  2.0,
                       vector-space    >= 0.6     && <  1.0,
-                      wumpus-core     >= 0.42.0  && <  0.43.0
+                      wumpus-core     >= 0.43.0  && <  0.44.0
 
   
   exposed-modules:
+    Wumpus.Basic.Geometry.Base,
+    Wumpus.Basic.Geometry.Intersection,
+    Wumpus.Basic.Geometry.Paths,
+    Wumpus.Basic.Geometry.Quadrant,
     Wumpus.Basic.Kernel,
     Wumpus.Basic.Kernel.Base.Anchors,
     Wumpus.Basic.Kernel.Base.BaseDefs,
@@ -87,7 +119,10 @@
     Wumpus.Basic.Kernel.Objects.Bounded,
     Wumpus.Basic.Kernel.Objects.Connector,
     Wumpus.Basic.Kernel.Objects.CtxPicture,
+    Wumpus.Basic.Kernel.Objects.Displacement,
+    Wumpus.Basic.Kernel.Objects.DrawingPrimitives,
     Wumpus.Basic.Kernel.Objects.Graphic,
+    Wumpus.Basic.Kernel.Objects.PosImage,
     Wumpus.Basic.Kernel.Objects.TraceDrawing,
     Wumpus.Basic.System.FontLoader.Afm,
     Wumpus.Basic.System.FontLoader.GhostScript,